FILEMAN V22.2 PRODUCTION GRADE VERSION GT.M 28-MAR-2013 11:00:41 DDBR DDBR ;SFISC/DCL-VA FILEMAN BROWSER ; 18NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; EN N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM ; I '$$TEST^DDBRT W $C(7),!!,$$EZBLD^DIALOG(830),!! Q ;VEN/SMH - don't check for supportability D LIST^DDBR3(.DDBX) I DDBX'>0 W:DDBX=0 $C(7),!!,$$EZBLD^DIALOG(1404),!! Q ;** S DDBSA=DDBX(6) S DDBFLG=DDBX(4) S DDBPMSG=DDBX(5) D CONTNU D KTMP^DDBRU Q WP(DDBFN,DDBRN,DDBFLD,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBSA S DDBSA=$$GET^DIQG($G(DDBFN),$G(DDBRN),$G(DDBFLD),"B") I $G(DIERR) D CLEAN Q S DDBSA=$P(DDBSA,"$CREF$",2) I DDBSA']"" D ERR("FILE, RECORD and/or FIELD") Q I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q I $G(DDBFLG)["A" D .N DDBSAN .S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA)) .I '$D(@DDBSAN) D WP^DDBRAP($NA(@DDBSA)) .Q:$G(DDBPMSG)]"" .I $D(@DDBSAN@("TITLE")) S DDBPMSG=@DDBSAN@("TITLE") Q .Q S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser (wp) DOCUMENT 1") D CONTNU D:$G(DDBFLG)'["P" KTMP^DDBRU Q BROWSE(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,IOTM,IOBM) N DDBRLIST CONTNU I $G(U)'="^" N U S U="^" I $G(DDBFLG)["A" D .N DDBSAN .S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA)) .I '$D(@DDBSAN) D WP^DDBRAP($NA(@DDBSA)) .Q:$G(DDBPMSG)]"" .I $D(@DDBSAN@("TITLE")) S DDBPMSG=@DDBSAN@("TITLE") Q .Q S DDBPMSG=$S($G(DDBPMSG)]"":DDBPMSG,1:"VA FileMan Browser DOCUMENT 1") N %,D,DX,IOP,XY,X,Y D:$G(DDBFLG)'["H" INIT I $G(DIERR) D CLEAN Q I $G(DDBSA)']"" D ERR("SOURCE ARRAY") Q I '$D(@DDBSA) D ERR("SOURCE ARRAY") Q I $G(DDBFLG)'["N",DDBSA'="^TMP(""DDB"",$J)" D .I $NA(@DDBSA)=$NA(^TMP("DDB",$J)) S DDBSA="^TMP(""DDB"",$J)" Q .K ^TMP("DDB",$J) .D XY^%RCR($$OREF(DDBSA),"^TMP(""DDB"",$J,") .;M ^TMP("DDB",$J)=@DDBSA .S DDBSA="^TMP(""DDB"",$J)" .Q N DDBRE,DDBRPE,DDBPSA,DDBTO,DDBDM,DDBFNO,I,DDBFLGS,DDBRHT,DDBRHTF N DDBHDR,DDBHDRC,DDBFTR,DDBSP,DDBSF,DDBST,DDBTL,DDBTPG,DDBZN I '$G(DDBRLIST) N DDBSRL,DDBSX,DDBSY,DDBRSA S DDBFTR=$E("Col> |"_$$EZBLD^DIALOG(8074)_"| Line> Screen>"_$J("",IOM),1,IOM) ;** I '$G(DDBRLIST) S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1 S DDBRSA=0 D TB^DDBRS(.IOTM,.IOBM,.DDBRSA) S DDBSX="0;4;40;65" S DDBSY=DDBRSA(0,"DDBSY") I IOBM>(IOSL-1) D ERR($$EZBLD^DIALOG(833)) Q ;** I IOTM<2 D ERR($$EZBLD^DIALOG(832)) Q ;** I IOBM'>IOTM D ERR($$EZBLD^DIALOG(831)) Q ;** S DDBSRL=DDBRSA(0,"DDBSRL") I DDBSRL'>4,$G(DDBFLG)'["H" D ERR($$EZBLD^DIALOG(834)) Q ;** I DDBRSA(1,"DDBSRL")'>4 K DDBRSA(1),DDBRSA(2) S DDBHDR=$$CTXT(DDBPMSG,$J("",IOM+1),IOM),DDBHDRC=0 S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1) I DDBTL'>0 D I DDBTL'>0 D BLD^DIALOG(1700,$$EZBLD^DIALOG(1404)_DDBSA) D CLEAN Q ;** .N I S I=0 F S I=$O(@DDBSA@(I)) Q:I'>0 S DDBTL=I .Q S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBSF=1,DDBST=IOM S DDBDM=DDBSA="^TMP(""DDB"",$J)" I $G(DDBC)=+$G(DDBC) D ERR("TAB (Closed Array Root)") Q S:$G(DDBC)="" DDBC="^TMP(""DDBC"",$J)" I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)="" I $D(@DDBC@(1))'>9 N DDBC0,DDBC1 S @DDBC@(1)="",DDBC1=1,DDBC0=DDBC S DDBPSA=0,DDBFLG=$G(DDBFLG) S DDBFLGS=DDBFLG["S",DDBRHTF=DDBFLG["A" I DDBRHTF S $E(DDBFTR,1,9)="HYPER-TXT" G EN^DDBRGE DOCLIST(DDBDSA,DDBFLG,IOTM,IOBM) S IOP="HOME" D ^%ZIS N DDBPMSG,DDBL,DDBC,DDBSA,DDBSRL,DDBSX,DDBSY,DDBRSA,DDBRLIST S IOBM=$S($G(IOBM)>0:IOBM,1:$G(IOSL,24))-1,IOTM=$S($G(IOTM)>0:IOTM,1:1)+1 S DDBSX="0;4;40;65" S DDBSY=(IOTM-2)_";"_(IOTM-1)_";"_(IOBM-1)_";"_(IOBM) ;hdr,txttop,txtbot,ftr I IOBM>(IOSL-1) D ERR($$EZBLD^DIALOG(833)) Q ;** I IOTM<2 D ERR($$EZBLD^DIALOG(832)) Q ;** I IOBM'>IOTM D ERR($$EZBLD^DIALOG(831)) Q ;** S DDBSRL=(IOBM-IOTM)+1 ;scroll region lines I '$D(@DDBDSA) D ERR("DOCUMENT ARRAY INVALID") Q S DDBFLG=$TR($G(DDBFLG),"P")_"N" S DDBPMSG=$O(@DDBDSA@("")) S:DDBPMSG]"" DDBSA=@DDBDSA@(DDBPMSG) I DDBPMSG']""!(DDBSA']"") D ERR("DOCUMENT ARRAY INVALID") Q D I $G(DIERR) K ^TMP("DDBLST",$J) D CLEAN Q .N DOC,DOCSA .S DOC="" .K ^TMP("DDBLST",$J) .F S DOC=$O(@DDBDSA@(DOC)) Q:DOC="" D ..S DOCSA=@DDBDSA@(DOC) ..D LOADCL^DDBR4(DOCSA,"",DOC) ..Q .Q Q:$G(DDBENDR) S DDBRLIST=1 G CONTNU RTN G DR^DDBRU ROOT G EN^DDBRU2 CTXT(X,T,W) Q:X="" $G(T) N HW S W=$G(W,79),HW=W\2 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q $E(T,1,W) OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_"," OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q % INIT I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D INIT^DDGLIB0() I $G(DIERR) Q I '$D(IOSTBM)!('$D(IORI)) S X="IOSTBM;IORI" D ENDR^%ZISS D:$G(IOSTBM)="" TRMERR^DDGLIB0($$EZBLD^DIALOG(831)) ;** D:$G(IORI)="" TRMERR^DDGLIB0($$EZBLD^DIALOG(835)) W $P(DDGLCLR,DDGLDEL,2) ; VEN/SMH - Clear entire screen. ;TODO: Rollback IOSL to 24 if IOSL is >100; restore at exit (prob in CLEAN) - VEN/SMH Q ERR(DDBERR) N P S P(1)=DDBERR I $G(U)="^" N U S U="^" D BLD^DIALOG(202,.P),OUT^DDBRU:$D(DDGLDEL) CLEAN D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG)) Q DDBR0 DDBR0 ;SFISC/DCL-VA FILEMAN BROWSER FUNCTIONS ;04:01 PM 26 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q PU N I,J,K S I=DDBL-DDBSRL,J=I-(DDBSRL-1),K=DDBL S DX=$P(DDBSX,";"),DY=$P(DDBSY,";",2) I DDBZN D D:K'=DDBL RLPI Q .F I=I:-1:J Q:'$D(@DDBSA@(I,0)) D ..X IOXY ..W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) ..S DDBL=DDBL-1 F I=I:-1:J Q:I'>0!('$D(@DDBSA@(I))) D .X IOXY .W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) .S DDBL=DDBL-1 D:K'=DDBL RLPI Q PD N I,J,K S I=DDBL+1,J=DDBL+DDBSRL,K=DDBL S DX=0,DY=$P(DDBSY,";",3) X IOXY I DDBZN D D:K'=DDBL RLPI Q .F I=I:1:J Q:'$D(@DDBSA@(I,0)) W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) S DDBL=DDBL+1 .Q F I=I:1:J Q:'$D(@DDBSA@(I)) W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) S DDBL=DDBL+1 D:K'=DDBL RLPI Q LU N I S I=DDBL-DDBSRL S DX=0,DY=$P(DDBSY,";",2) X IOXY I DDBZN Q:'$D(@DDBSA@(I,0)) S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I,0),I) D RLPIR Q I I>0,$D(@DDBSA@(I)) S DDBL=DDBL-1 W IORI,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(I),I) D RLPIR Q Q LD S DX=0,DY=$P(DDBSY,";",3) X IOXY I DDBZN,$D(@DDBSA@(DDBL+1,0)) D Q .S DDBL=DDBL+1 .W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL,0),DDBL) .D RLPIR .Q I 'DDBZN,$D(@DDBSA@(DDBL+1)) D Q .S DDBL=DDBL+1 .W !,$P(DDGLCLR,DDGLDEL),$$HTD(@DDBSA@(DDBL),DDBL) .D RLPIR .Q Q COL(N) N X S X=$O(@DDBC@(DDBSF),N) Q:X'>0 S DDBSF=X COLENT S DDBST=DDBSF+(IOM-1),DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLR(DDBL+1),COLR I DDBHDRC D ENCHDR^DDBR4 Q COLJ N X COLA S X(2)="Col> " W $$WS^DDBR1(.X) D G:X=""!(X=U) OUT .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,1,"","KPW",.X) .K DIR0 .Q I $E(X)="?" G COLERR I X<1!(X>255) W $C(7) G COLERR S DDBSF=X G COLENT Q COLERR S X(1)=" * [ "_$$EZBLD^DIALOG(836)_" ] *" ;**'Enter a number between 1 and 255' G COLA OUT D PSR^DDBR0() Q RLE Q:$G(DDBRHTF) S DDBSF=1 G COLENT RRE Q:$G(DDBRHTF) S DDBSF=$O(@DDBC@(""),-1) G COLENT ; ONLINE Q RR I DDBRHTF D JUMP^DDBRAHTJ(1) Q D COL(1) Q RL I DDBRHTF D JUMP^DDBRAHTJ(-1) Q D COL(-1) Q TOP S DDBL=0 D SDLR(1),RLPIR Q BOT I DDBTL>DDBSRL S DDBL=DDBTL-DDBSRL D SDLR(DDBL+1),RLPIR Q EXIT S DDBRE="^" Q TO S DDBTO=DDBTO+1,DDBE=-1 S:DDBTO'<($G(DTIME,300)\5) DDBE="^" Q RCLSI D RLPIR,COLR Q PSR(PSR) S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D:$G(PSR) HFR D SDLR(DDBL+1),RLPIR,COLR Q SDL ; SDLR(L) N I,J,SFR,STO S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3),J=L S DY=SFR X IOXY I DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HTD(@DDBSA@(L,0),L) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q I 'DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HTD(@DDBSA@(L),L) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q Q HFR N FTR S FTR=1 HDR S DX=0 S DY=$P(DDBSY,";") X IOXY W $P(DDGLVID,DDGLDEL,6) W DDBHDR W $P(DDGLVID,DDGLDEL,10) G:$G(FTR) FTR Q FTR I DDBFLGS Q W $P(DDGLVID,DDGLDEL,6) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4) S DY=$P(DDBSY,";",4) X IOXY W DDBFTR S DX=$P(DDBSX,";",3) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6)," of ",DDBTL S DX=$P(DDBSX,";",4) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5)," of ",DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S DX=$P(DDBSX,";",2) X IOXY W:'DDBRHTF $J(DDBSF,4) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10) W $P(DDGLVID,DDGLDEL,10) Q RLPI ; RLPIR I DDBFLGS Q S DX=$P(DDBSX,";",3),DY=$P(DDBSY,";",4) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4) W $P(DDGLVID,DDGLDEL,6) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL),6) S DX=$P(DDBSX,";",4) X IOXY W $J($S(DDBL>DDBTL:" ",DDBL<1:" ",1:DDBL-1\DDBSRL+1),5) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10) W $P(DDGLVID,DDGLDEL,10) Q COLR I DDBFLGS!(DDBRHTF) Q S DX=$P(DDBSX,";",2),DY=$P(DDBSY,";",4) X IOXY I DDBRSA=1 W $P(DDGLVID,DDGLDEL,4) W $P(DDGLVID,DDGLDEL,6) W $J(DDBSF,4) I DDBRSA=1 W $P(DDGLVID,DDGLDEL,10) W $P(DDGLVID,DDGLDEL,10) Q ; HTD(X,WPIEN) ; Q:'DDBRHTF $E(X,DDBSF,DDBST) Q:$L(X,"$.")'>2 X S:$L(X,"$.$")>2 X=$$HT(X,"$.$","","") S:$L(X,"$.%")>2 X=$$HT(X,"$.%",$P(DDGLVID,DDGLDEL),$P(DDGLVID,DDGLDEL,3)) Q X ; HT(Y,D,C1,C2) ; Q:$L(Y,D)'>2 Y N YL,I,Y1 S YL=$L(Y,D),Y1="" F I=1:1:YL D .S:I#2 Y1=Y1_$P(Y,D,I) .I '(I#2),+$G(DDBRHT)=WPIEN,$P(DDBRHT,DDGLDEL,4)=DDBSA,$P(DDBRHT,DDGLDEL,2)=$P(Y,D,I) D Q ..S Y1=Y1_C1_$P(DDGLVID,DDGLDEL,4)_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_$P(DDGLVID,DDGLDEL,5)_C2 ..Q .S:'(I#2) Y1=Y1_C1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_C2 .Q Q Y1 DDBR1 DDBR1 ;SFISC/DCL-VA FILEMAN BROWSER PROTOCOLS ;06:01 PM 31 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q GOTO N X GTR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(1408)_" >" W $$WS(.X) D G:X=""!(X=U) OUT ;** .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,"","","KPW",.X) .K DIR0 .Q I $E(X)="?" S X(1)="* "_$$EZBLD^DIALOG($S(DDBRHTF:1409,1:1409.1))_" *" G GTR ;** I X S X=X*DDBSRL G LINE S $E(X)=$TR($E(X),"bclst","BCLST") I X["S",$TR($P(X,"S",2)," ") S X=$TR($P(X,"S",2)," ")*DDBSRL G LINE I X["L",$TR($P(X,"L",2)," ") S X=$TR($P(X,"L",2)," ") G LINE I X["C",'DDBRHTF,$TR($P(X,"C",2)," ") S X=$TR($P(X,"C",2)," ") I X>0&(X<256) S DDBSF=X G COLENT^DDBR0 I $E(X)="T" G TOP^DDBR0 I $E(X)="B" G BOT^DDBR0 G OUT LINE S DDBL=$S(X'>DDBSRL:0,X>DDBTL:DDBTL,1:X) D PSR^DDBR0() Q NOOF N N S N=1 I $D(DDBFNO) N D,X G FNO S X(1)=" * ["_$$EZBLD^DIALOG(1406)_"] *" ;**'NO PREVIOUS FIND STRING AVAILABLE' N Q S N=0 G BPR FIND N D,Q,X N N S N=0 BPR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(8126) W $$WS(.X) D G:X="" OUT ;** .N Y .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,$P($G(DDBFNO),U,3,255),100,"","","KPW",.X,.Y) .K DIR0 .S:$P($G(Y),U)="U" X=X_"/U" .Q S Q=$TR($E(X,$L(X)-1,$L(X)),"u","U") S D=$S(Q="/U":-1,1:1) S:D=-1 X=$E(X,1,$L(X)-2) Q:X="" I $E(X)="?" S X(1)=" * [ "_$$EZBLD^DIALOG(1407)_" ] *" G BPR ;** FNO N I,MATCHI,MATCHX I N S D=$P(DDBFNO,"^",2),X=$P(DDBFNO,"^",3,255) S X(1)="",X(2)=" * ["_$$EZBLD^DIALOG(1405,X)_"] *" W $$WS(.X) ;**'SEARCHING' D S:I<0 I=0 .I N&(D=1) S I=DDBL Q .I N S I=DDBL-(DDBSRL-1) Q .I D=1 S I=DDBL-DDBSRL Q .S I=DDBL+1 .Q D .N XUC .S XUC=$$U(X) .I DDBDM D Q ..I DDBZN D Q ...F S I=$O(^TMP("DDB",$J,I),D) Q:I'>0 I $$U($G(^(I,0)))[XUC S MATCHI=I,MATCHX=^(0) Q ...Q ..F S I=$O(^TMP("DDB",$J,I),D) Q:I'>0 I $$U(^(I))[XUC S MATCHI=I,MATCHX=^(I) Q ..Q .I DDBZN D Q ..F S I=$O(@DDBSA@(I),D) Q:I'>0 I $$U($G(@DDBSA@(I,0)))[XUC S MATCHI=I,MATCHX=@DDBSA@(I,0) Q ..Q .F S I=$O(@DDBSA@(I),D) Q:I'>0 I $$U(@DDBSA@(I))[XUC S MATCHI=I,MATCHX=@DDBSA@(I) Q .Q I $G(MATCHI) D S DDBFNO=DDBL_"^"_D_"^"_X Q .S DDBSF=1,DDBST=IOM F Q:$F(MATCHX,X)'>DDBST D ..S DDBSF=$O(@DDBC@(DDBSF)) S:DDBSF="" DDBSF=$O(@DDBC@("")) ..S DDBST=DDBSF+(IOM-1) ..Q .I I+(DDBSRL)>DDBTL S I=DDBTL-(DDBSRL-1) .I DDBTL'>DDBSRL S I=1 .S DDBL=I-1 D SDLRH(I,X),RCLSI^DDBR0 .Q NO S X(1)="",X(2)=" * ["_$$EZBLD^DIALOG($S(N:8006.11,1:8006.1))_" ] *" W $C(7),$$WS(.X) H 3 ;**'NO MATCH FOUND' D PSRH Q OUT D PSR^DDBR0() Q PSRH S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLRH(DDBL+1,X) Q SDL ; SDLRH(L,HLS) N I,J,SFR,STO S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3),J=L S DY=SFR X IOXY I DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HL($$HTD^DDBR0(@DDBSA@(L,0),L),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,7)) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q I 'DDBZN F I=SFR:1:STO D .W:I'=SFR ! .W $P(DDGLCLR,DDGLDEL) .I J=L,$D(@DDBSA@(L)) W $$HL($$HTD^DDBR0(@DDBSA@(L),L),HLS,$P(DDGLVID,DDGLDEL,6),$P(DDGLVID,DDGLDEL,7)) S DDBL=DDBL+1,L=L+1 .S J=J+1 .Q Q HL(X,S,ON,RS,F) S X=$G(X),S=$G(S),F=$G(F)=1 G:F CS N C,I,P,T,XU,SU,SL,TL,XL S XU=$$U(X),SU=$$U(S),SL=$L(S),C=$L(XU,SU)-1,T="",XL=0 Q:'C X F I=1:1:C S P=$F(XU,SU,XL),T=T_$E(X,XL,P-SL-1)_ON_$E(X,P-SL,P-1)_RS,XL=P S T=T_$E(X,XL,255) Q T U(X) Q $$UP^DILIBF(X) ;**CCO/NI UPPER-CASE CS Q:$L(X,S)'>1 X N C,I,P,T S T="",C=$L(X,S) F I=1:1:C S P=$P(X,S,I),T=T_P_$S(I'=C:ON_S_RS,1:"") Q T HELPS N DDBHELPS S DDBHELPS=$S(DDBFLG["A":83,1:71)+DDBSRL HELP I $E(DDBSA,1,11)="^DI(.84,920" S DDBL=0 D SDLR^DDBR0(1),RLPIR^DDBR0 Q N DDBHA S DDBHA=$S(DDBFLG["A":9202,1:9201) Q:'$D(^DI(.84,DDBHA,2)) S DDBHA=$NA(^(2)) I $G(DUZ("LANG"))>1,$D(^(4,DUZ("LANG"),1)) S DDBHA=$NA(^(1)) ;**CCO/NI I $D(^TMP("DDBLST",$J,"J")) D .K ^TMP("DDBLST",$J,"JS") .M ^TMP("DDBLST",$J,"JS")=^TMP("DDBLST",$J,"J") .K ^TMP("DDBLST",$J,"J") .Q D BROWSE^DDBR(DDBHA,"PNH"_$S(DDBFLG["A":"A",1:""),"VA FileMan Help Document",$G(DDBHELPS),"",IOTM-1,IOBM+1) K ^TMP("DDBLST",$J,"J") I $D(^TMP("DDBLST",$J,"JS")) M ^TMP("DDBLST",$J,"J")=^TMP("DDBLST",$J,"JS") K ^TMP("DDBLST",$J,"JS") W @IOSTBM D PSR^DDBR0(1) Q LC(L,C) Q:$G(L)'>0 "" S C=$G(C,"-") Q $TR($J("",L)," ",C) WS(X) S DX=0,DY=$P(DDBSY,";",3)-3 X IOXY W $P(DDGLGRA,DDGLDEL) W $TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3)) W $P(DDGLGRA,DDGLDEL,2) W !,$P(DDGLCLR,DDGLDEL),$G(X(1)) W !,$P(DDGLCLR,DDGLDEL),$G(X(2)) W !,$P(DDGLCLR,DDGLDEL),$G(X(3)) S DY=$P(DDBSY,";",3),DX=$L($G(X(2)))+2 X IOXY Q "" DDBR2 DDBR2 ;SFISC/DCL-VA FILEMAN BROWSER ;2JAN2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q SWITCH(DDBLST,DDBRET) ;Switch to another document in list or FileMan Database I $E(DDBSA,1,11)="^DI(.84,920" D EXIT^DDBR0 Q ;!(DDBSA="^XTMP(""DDBDOC"")") Q I DDBSA=$NA(^TMP("DDWB",$J)) G EXIT^DDBR0:$G(DDBRET)["R",SWITCH^DDBRWB Q N DDBLN,DDBZ,DIC,DIR,X,Y,DIRUT,DIROUT,DUOUT,DILN S DILN=DDBRSA(DDBRSA,"DDBSRL")-2 S:$G(DDBLST)="" DDBLST="^TMP(""DDBLST"",$J)" S DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) I DDBFLG["R",'$D(@DDBLST) D SFR() G PS I DDBFLG["A" D SFR() G PS I $G(DDBRET)["R" D G:$G(Y) PS Q .Q:DDBPSA'>0 .Q:'$D(@DDBLST@("APSA",DDBPSA)) S X=^(DDBPSA) S:$D(@DDBLST@("A",X)) Y=^(X) .I $G(Y) S DDBPSA=DDBPSA-1 N DDBPSA D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y) .Q BRMC D BRM I $D(@DDBLST) D .I $O(@DDBLST@(" "),-1)=1,$G(@DDBLST@(1,"DDBSA"))=DDBSA Q .;W "Current list: ",! .S DDBZ=$G(@DDBLST@("A",DDBSA),0) .;S X=0 F S X=$O(@DDBLST@(X)) Q:X'>0 W:X'=DDBZ !,$J(X,3)," ",$E(@DDBLST@(X,0),1,75) .W ! .K DIR0 CUR .I DDBFLG'["R" S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8142),DIR("B")="YES" D ^DIR Q:$D(DIRUT)!(Y'>0) ;"Do you wish to select from current list" .S DIC=$$OREF^DIQGU(DDBLST),DIC(0)="EMQ",DIC("S")="I +Y'=DDBZ",DIC("W")="W:$E(^(0))=U ^(0)",X="??" D ^DIC ;K DIC("S") Q:Y'>0 .S DIC(0)="AEMQ" .D ^DIC K DIC("S") Q:Y'>0 .D SAVEDDB(DDBLST,DDBLN),USAVEDDB(DDBLST,+Y) .S DIROUT=1 N DDBLNA S:DDBFLG["R" DIROUT=1 I '$D(DIROUT) D LIST^DDBR3(.DDBLNA) I $G(DDBLNA,-1)=-1 G PS I $G(DDBLNA(6))=DDBSA G PS ;if current document selected again I $G(DDBLNA(6))]"",$D(@DDBLST@("APSA",DDBSA)) G PS ;if already in list NO I DDBLNA'>0 W $C(7),!!,$$EZBLD^DIALOG(1404),DDBLNA(5) H 3 ;** D:DDBLNA>0 SAVEDDB(DDBLST,DDBLN),WP(.DDBLNA) PS D PSR^DDBR0(1) Q ; WP(DDBX) ; S DDBSA=DDBX(6) S DDBPMSG=DDBX(5) S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM) S DDBTL=$P(@DDBSA@(0),"^",3) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S DDBZN=1 S DDBDM=0 S DDBSF=1 S DDBST=IOM S DDBC="^TMP(""DDBC"",""DDBC"",$J)" I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)="" S DDBL=0 Q ; SAVEDDB(DDBLIST,IEN,NSAPSA) ;Save local varialbes into ^TMP("DDBLIST",$J,IEN) ;DDBS array to save list ;IEN internal entry ;NSAPSA Not Set "APSA" x-ref if undefined, pass 1 to not set NSAPSA (optional - default is to set "APSA") S NSAPSA=+$G(NSAPSA) N I,X F I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@DDBLIST@(IEN,X)=@X ;I $D(DDBFNO) S @DDBLIST@(IEN,DDBFNO)=DDBFNO ;decided to keep it the same throughout the browse session (Next Find String) S @DDBLIST@(IEN,0)=DDBPMSG S:'$D(@DDBLIST@(0)) ^(0)="CURRENT LIST^1" S:'$D(@DDBLIST@("A",DDBSA)) @DDBLIST@("A",DDBSA)=IEN S:'$D(@DDBLIST@("B",DDBPMSG,IEN)) @DDBLIST@("B",DDBPMSG,IEN)="" I $G(DDBRET)["R",DDBRPE=DDBRE Q Q:NSAPSA S X=$O(@DDBLST@("APSA"," "),-1)+1 I $G(@DDBLIST@("APSA",X-1))=DDBSA S DDBPSA=X-1 Q S @DDBLIST@("APSA",X)=DDBSA,DDBPSA=X Q ; USAVEDDB(DDBLIST,IEN) ;Unsave varialbes in ^TMP("DDBLIST",$J,IEN) to locals ;DDBS array to save list ;IEN internal entry N I,X F I="HDR","HDRC","SA","ZN","DM","PMSG","L","C","TL","SF","ST","RE","RPE" S X="DDB"_I,@X=@DDBLIST@(IEN,X) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) ;I $D(@DDBLIST@(IEN,"DDBFNO")) S DDBFNO=@DDBLIST@(IEN,"DDBFNO") Q ; ; CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width Q:X="" $G(T) N HW S W=$G(W,79),HW=W\2 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_"," OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q % ; BRM ;BROWSE MANAGER SCREEN N DX,DY,X S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR("BROWSE SWITCH MANAGER",$J("",IOM+1),IOM) X IOXY W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff W @IOSTBM S DY=$P(DDBSY,";",2) X IOXY Q ; SFR(Y) N X S X(1)="",X(2)=$$CTXT^DDBR("<< "_$$EZBLD^DIALOG($S($G(Y):7076.1,1:7076))_" >>","",IOM) ;** 'SWITCH FUNCTION RESTRICTED' W $$WS^DDBR1(.X),$C(7) R X:3 Q DDBR3 DDBR3 ;SFISC/DCL-SELECT FILE & WP FIELD TO BROWSE ;NOV 04, 1996@13:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. LIST(DDBLIST) ;DDBLIST=Target array for file number,ien,field,... S DDBLIST=-1 ;no selection EN ; N %,%H,%ZISOS,A,D,D0,D1,DA,DDBB,DDBDDF,DDBDIC,DDBFRCD,DDBIEN,DDBRCR,DDBX,DIC,DICS,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DX,I,POP,S,X,Y ;S DIC=1,DIC(0)="AEMQ" D ^DIC Q:+Y'>0 ;Select file D ^DICRW Q:Y'>0 S DIC="^DD("_+Y_",",DIC(0)="AEMQ" M S DIC("W")="I $P(^(0),U,2) W $S($P(^DD(+$P(^(0),U,2),.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" S DIC("S")="I $P(^(0),U,2)" D ^DIC I +Y'>0,$D(@(DIC_"0,""UP"")")) S DIC="^DD("_+^("UP")_"," G M ;Select field/back out of multiples Q:+Y'>0 I $P(@(DIC_+Y_",0)"),U,2) S DIC="^DD("_+$P(^(0),U,2)_",",Y=.01 G D:$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",M D ; K DIC("S") S DDBDIC=$$UP^DIQGU(+$P(DIC,"^DD(",2),.DDBDIC),(DDBX,DDBIEN)="" S DDBFRCD=$$GET^DIQGDD(DDBDIC,"","NAME")_":[",DDBB=0 F S DDBX=$O(DDBDIC(DDBX)) Q:DDBX'<0 D Q:$G(Y)'>0 .K DA D IEN(","_DDBIEN,.DA) .S DIC=$$ROOT^DIQGU(+DDBDIC(DDBX),","_DDBIEN),DIC(0)="AEMQ" Q:DIC']"" .S DDBRCR=$$CREF^DILF(DIC) .I $P($G(@DDBRCR@(0)),U,4)'>0 D K DDBIEN Q ..W $C(7),!!,"No Records at "_$S(DDBDIC=+DDBDIC(DDBX):"FILE",1:$P(^DD(+DDBDIC(DDBX),.01,0),U))_" Level.",! ..Q .D ^DIC I Y'>0 K DDBIEN Q .S DDBIEN=+Y_","_DDBIEN .S DDBFRCD=DDBFRCD_$S(DDBB:"\",1:"")_$$GET^DIQG(+DDBDIC(DDBX),DDBIEN,.01),DDBB=1 .K DA D IEN(DDBIEN,.DA) .Q DISP ; S DDBDDF=$O(^DD(+DDBDIC(-1),"SB",+DDBDIC(0),"")) Q:'DDBDDF S DDBFRCD=DDBFRCD_"] (wp): "_$P(^DD(DDBDIC(0),.01,0),"^") I $D(DDBIEN) D Q .N DDBX S DDBX=$P($$GET^DIQG(+DDBDIC(-1),DDBIEN,DDBDDF,"B"),"$CREF$",2) .S DDBLIST=$D(@DDBX) .S DDBLIST(1)=+DDBDIC(-1) .S DDBLIST(2)=DDBIEN .S DDBLIST(3)=DDBDDF .S DDBLIST(4)="N" .S DDBLIST(5)=DDBFRCD .S DDBLIST(6)=DDBX .Q Q IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)="" S DA(I-1)=$P(IEN,",",I) Q DDBR4 DDBR4 ;SFISC/DCL-LOAD CURRENT LIST ;NOV 04, 1996@13:49 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. LOADCL(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,DDBLST) ; ;DDBSA=source array by value ;DDGFLG=no flags currently available ;DDBPMSG=text to be displayed (centered) on top line ;DDBL=display line default 1st screen/line (22 in most cases) ;DDBC=location of column tab array used with right/left arrow keys ;DDBLST=location of current list (BROWSER expects ^TMP("DDBLST",$J)) I $G(DDBSA)']"" N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q I '$D(@DDBSA) N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q N DDBRE,DDBLN,DDBRPE,DDBPSA,DDBTO,I,X,Y N DDBFNO,DDBDM,DDBSF,DDBTL,DDBTPG,DDBZN,DDBFTR,DDBHDR,DDBHDRC,DDBST S DDBHDR=$$CTXT($G(DDBPMSG,"VA FileMan Browser"),$J("",IOM+1),IOM) S DDBHDRC=+$G(DDBHDRC) S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1) I DDBTL'>0 D I DDBTL'>0 D BLD^DIALOG(1700,"*NO TEXT* "_DDBSA) Q .N I S I=0 F S I=$O(@DDBSA@(I)) Q:I'>0 S DDBTL=I .Q S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBDM=DDBSA="^TMP(""DDB"",$J)",DDBSF=1 S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)") S DDBPSA=0,DDBFLG=$G(DDBFLG) S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL S (DDBRE,DDBRPE)="",DDBTO=0,DDBST=IOM S DDBLST=$G(DDBLST,"^TMP(""DDBLST"",$J)"),DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) D SAVEDDB^DDBR2(DDBLST,DDBLN,1) Q ; CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width Q:X="" $G(T) N HW S W=$G(W,79),HW=W\2 S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_"," OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q % ; CHDR(D) ;Change Header Message in Window Title ;D=direction 1 is down, -1 is up, if 0 restore back to original msg. N C S C=DDBHDRC+D I C<0!(C>DDBTL) W $C(7) Q S DDBHDRC=C ENCHDR I 'DDBHDRC S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM) E D .I DDBZN S DDBHDR=$$CTXT^DDBR($E(@DDBSA@(DDBHDRC,0),DDBSF,DDBST)_$J("",IOM+1),"",IOM) Q .S DDBHDR=$$CTXT^DDBR($E(@DDBSA@(DDBHDRC),DDBSF,DDBST)_$J("",IOM+1),"",IOM) .Q I DDBRSA S DDBRSA(DDBRSA,"DDBHDRC")=DDBHDRC,DDBRSA(DDBRSA,"DDBHDR")=DDBHDR ; repaint screen D RPS^DDBRGE Q DDBRAHT DDBRAHT ;SFISC/DCL-BROWSER ANCHOR & HYPERTEXT PROCESSOR ;NOV 04, 1996@13:50 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q TAB ; S DDBRHT=$G(DDBRHT) I $P(DDBRHT,DDGLDEL,4)'=DDBSA S DDBRHT="" N LIM,ULCLR,ULNEW S LIM=DDBL,ULCLR=DDBRHT'>0,ULNEW=0 PSR S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLR(DDBL+1) Q SDLR(L) N I,J,SFR,STO I +DDBRHTLIM) S DDBRHT="",ULCLR=1 S DX=0,SFR=$P(DDBSY,";",2),STO=$P(DDBSY,";",3) S DY=SFR X IOXY F I=SFR:1:STO D .I $D(@DDBSA@(L)) S X=$S(DDBZN:@DDBSA@(L,0),1:@DDBSA@(L)),DDBL=DDBL+1,L=L+1 .E Q .I ULCLR,ULNEW Q .Q:$L(X,"$.%")'>2 .S WRF=0,J=$P(X,"$.%",$P(DDBRHT,DDGLDEL,3)),X=$$HTD(X,L-1) .I +DDBRHT,J=$P(DDBRHT,DDGLDEL,2) S ULCLR=1,WRF=1 .Q:'WRF .S DY=I .X IOXY .W $P(DDGLCLR,DDGLDEL),X .Q ; I 'ULNEW S DDBRHT="" Q ; HTD(X,WPIEN) ;text Q:'DDBRHTF $E(X,DDBSF,DDBST) Q:$L(X,"$.")'>2 X S:$L(X,"$.$")>2 X=$$HT(X,"$.$","","","","","","") S:$L(X,"$.%")>2 X=$$HT(X,"$.%",$P(DDGLVID,DDGLDEL),$P(DDGLVID,DDGLDEL,3),WPIEN'<+DDBRHT,$S(WPIEN=+DDBRHT:$P(DDBRHT,DDGLDEL,3)+2,1:2),$P(DDGLVID,DDGLDEL,4),$P(DDGLVID,DDGLDEL,5)) Q X ; HT(Y,D,C1,C2,UF,UP,U1,U2) ; Q:$L(Y,D)'>2 Y N YL,I,Y1 S YL=$L(Y,D),Y1="" F I=1:1:YL D .S:I#2 Y1=Y1_$P(Y,D,I) .I UF,I=UP,'ULNEW D Q ..S Y1=Y1_C1_U1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_U2_C2,ULNEW=1,WRF=1 ..S DDBRHT=WPIEN_DDGLDEL_$P(Y,D,I)_DDGLDEL_I_DDGLDEL_DDBSA .S:'(I#2) Y1=Y1_C1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_C2 .Q Q Y1 DDBRAHTE DDBRAHTE ;SFISC/DCL-BROWSER ANCHOR & HYPERTEXT JUMP EDIT ;NOV 04, 1996@13:51 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q REDIT ; root edit for hypertext jump - CLOSED_ROOT Q ;prototype - phasing out Q:'$$CHKI N DDBSAN,DDBSANS,DDBSANX,DDBSANR,X S DDBSAN=$$NROOT^DDBRAP(DDBSA),DDBSANX=$P(DDBRHT,DDGLDEL,2) S X(1)=" < Edit Hypertext Jump Closed_Root >" S DDBSANS=$G(@DDBSAN@("H",DDBSANX)),DDBSANR=$G(@DDBSAN@("H",DDBSANX,0)) Q:DDBSAN=""!(DDBSANS="") GTR S X(1)=$G(X(1)),X(2)=" "_$E(DDBSANX,1,30)_" >" W $$WS^DDBR1(.X) D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,44,1,DDBSANR,100,1,"","KPW",.X) K DIR0 I $E(X)="?" S X(1)="* Enter closed_root jump for hypertext: "_$E(DDBSANX,1,35)_$S($L(DDBSANX)>35:"...",1:"")_" *" G GTR I DDBSANR'=X S @DDBSAN@("H",DDBSANX,0)=X G OUT ; IEDIT ; interactive edit/switch Q:'$$CHKI Q ANCH ; enter Anchor for jump Q ;prototype - phasing out Q:'$$CHKI N DDBSAN,DDBSANS,DDBSANX,DDBSANR,DDBSANCH,X S DDBSAN=$$NROOT^DDBRAP(DDBSA),DDBSANX=$P(DDBRHT,DDGLDEL,2) S X(1)=" < Edit Anchor Jump >" S DDBSANS=$G(@DDBSAN@("H",DDBSANX)),DDBSANR=$G(@DDBSAN@("H",DDBSANX,0)) S DDBSANCH=$P(DDBSANS,"^",4) Q:DDBSAN=""!(DDBSANS="") AGTR S X(1)=$G(X(1)),X(2)=" "_$E(DDBSANX,1,30)_" >" W $$WS^DDBR1(.X) D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,44,1,DDBSANCH,100,1,"","KPW",.X) K DIR0 I $E(X)="?" S X(1)="* Enter FILE#;IEN;FIELD;ANCHOR for: "_$E(DDBSANX,1,35)_$S($L(DDBSANX)>35:"...",1:"")_" *" G AGTR I DDBSANCH'=X S $P(@DDBSAN@("H",DDBSANX),"^",4)=X G OUT Q ; TEDIT ; edit hypertext document title I 'DDBRHTF!($G(DUZ(0))'["@") Q N DDBSAN,DDBSANX,X S DDBSAN=$$NROOT^DDBRAP(DDBSA),DDBSANX=$G(@DDBSAN@("TITLE")) S X(1)=" < Edit Hypertext Document Title >" TGTR S X(1)=$G(X(1)),X(2)=" Title >" W $$WS^DDBR1(.X) D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,44,1,DDBSANX,100,1,"","KPW",.X) K DIR0 I $E(X)="?" S X(1)="* Enter Document Name for Title *" G TGTR I X'="^" D D RPS^DDBRGE Q .S @DDBSAN@("TITLE")=X .S DDBPMSG=X,DDBHDR=$$CTXT^DDBR(X,$J("",IOM+1),IOM) .Q G OUT ; CHKI() ;return 1 if ok 0 not ok to continue also init DDBRHT if undefined S DDBRHT=$G(DDBRHT) Q:DDBRHT="" 0 I 'DDBRHTF!($G(DUZ(0))'["@") Q 0 I $P(DDBRHT,DDGLDEL,4)'=DDBSA Q 0 I +DDBRHT>DDBL Q 0 I +DDBRHT<($S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1) Q 0 Q 1 ; OUT D PSR^DDBR0() Q ; RA ;Rebuild Anchors I 'DDBRHTF!($G(DUZ(0))'["@") Q N X,DDBSAN S DDBSAN=$$NROOT^DDBRAP(DDBSA) S X(1)="",X(2)=" < Rebuilding Anchor Index for HyperText Jumps >" W $$WS^DDBR1(.X) D WP^DDBRAP(DDBSA,"",$G(@DDBSAN@("TITLE"),DDBPMSG)) R X:2 G OUT DDBRAHTJ DDBRAHTJ ;SFISC/DCL-BROWSER HYPERTEXT JUMP ; 18NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q JUMP(DDBRDIR) ; pass direction 1/forward -1/backward ; ; N DDBSAN,DDBRAFLG,DDBLST S DDBSAN=$$NROOT^DDBRAP($NA(@DDBSA)),DDBLST=$NA(^TMP("DDBLST",$J)) I $G(DDBRDIR)=1 D FRWD Q D BCK Q FRWD ; forward Q:'$$CHKI N DDBRAHP,DDBRAHA,DDBSANX,DDBRAAH,DDBRAHL,DDBRSET,DIERM S DDBSANX=$P(DDBRHT,DDGLDEL,2),DDBRAAH=$P(DDBSANX,"^"),DDBRSET=1 ;jump to another root I DDBSANX["$CREF$" D G STKPT:DDBSANX]"" G PS^DDBR2 .N DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT,DDBRXC2,DDBRXC3 .S DDBRATR=$P(DDBSANX,"$CREF$",2) .S DDBRAAH=$P($P(DDBSANX,"$CREF$",3),"^") .I DDBRATR="" S DDBRAAH="" Q .I $D(@DDBRATR)'>9,$E($G(@DDBRATR),1,5)="$XC$^" D Q:$D(@DDBRATR)'>9 ..N X,DDBRNR ..S DDBRXC3=$P(@DDBRATR,"$XC$^",3) ..S X(1)="",X(2)=$$CTXT^DDBR("Loading "_DDBRXC3,"",IOM),X(3)="" ..W $$WS^DDBR1(.X) ..S DDBRXC2=$P(@DDBRATR,"$XC$^",2) X DDBRXC2 ..I $D(@DDBRATR)'>9 Q ..I DDBRXC3]"" D WP^DDBRAP(DDBRATR,"",DDBRXC3) ..Q .I $D(@DDBRATR)'>9,$E($G(@DDBRATR),1,6)="$XCR$^" D W @IOSTBM Q ..N X,IOTM,IOBM,IOSTBM ..S DDBRXC2=$P(@DDBRATR,"$XCR$^",2),DDBSANX="" X DDBRXC2 ..W:$D(IOF) @IOF ..S X=0 X ^DD("OS",DISYS,"RM") ..W $P(DDGLVID,DDGLDEL,8) ..Q .I '$D(@DDBRATR) S DDBRAAH="" Q .S DDBRANRT=$$NROOT^DDBRAP(DDBRATR) .I '$D(@DDBRANRT) D WP^DDBRAP(DDBRATR) .S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) .D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET .S DDBRSET=0 .S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1 .S DDBSA=DDBRATR,DDBSAN=DDBRANRT UP .S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG=$$UP^DILIBF($P(DDBSANX,"^",$L(DDBSANX,"^"))) ;** .D SAVSET .Q ;jump to another file, w-pDD#,entry:entry#anchor I DDBRAAH,DDBRAAH["@" D G STKPT .N DDBRAB,DDBRABR,DDBLSTN,DDBRATR,DDBRANRT .S DDBRAB=$P(DDBRAAH,"#") .I DDBRAB="" S DDBRAAH="" Q .S DDBRATR=$$GETR^DDBRAP($P(DDBRAB,"@"),$P($P(DDBRAB,"@",2),"#")) .I DDBRATR="" D Q ..S DDBRAAH="" ..I $G(DIERR) S DIERM=$$CTXT^DDBR($G(^TMP("DIERR",$J,+DIERR,"TEXT",1))) ..K DIERR,^TMP("DIERR",$J) ..Q .S DDBRANRT=$$NROOT^DDBRAP(DDBRATR) .I '$D(@DDBRANRT) D WP^DDBRAP(DDBRATR) .S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) .D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET .S DDBRSET=0 .S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1 .S DDBSA=DDBRATR,DDBSAN=DDBRANRT .S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG="HYPERTEXT JUMP ID#"_$O(@DDBLST@("J",""),-1)+1 .D SAVSET .Q ;jump to another entry in the same file, same level I DDBRAAH["#",$P(DDBRAAH,"#")]"" D .N DDBRAB,DDBRABR,DDBRAIEN,DDBLSTN,DDBRALEV,DDBRANRT .S DDBRAB=$P(DDBRAAH,"#") .I DDBRAB="" S DDBRAAH="" Q .S DDBRALEV="",DDBRABR=$$IENROOT^DDBRAP($NA(@DDBSA),.DDBRALEV) .S DDBRAIEN=$O(@DDBRABR@("B",DDBRAB,"")) .I 'DDBRAIEN S DDBRAAH="" Q .S DDBRANRT=$$NROOT^DDBRAP($NA(@DDBRABR@(DDBRAIEN,DDBRALEV))) .I '$D(@DDBRANRT) D WP^DDBRAP($NA(@DDBRABR@(DDBRAIEN,DDBRALEV))) .S DDBLSTN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1) .D SAVEDDB^DDBR2(DDBLST,DDBLSTN,1),SET .S DDBRSET=0 .S DDBRAAH=$P(DDBRAAH,"#",2),DDBRAFLG=1 .S DDBSA=$NA(@DDBRABR@(DDBRAIEN,DDBRALEV)) .S DDBSAN=DDBRANRT .S DDBPMSG=$G(@DDBSAN@("TITLE")) S:DDBPMSG="" DDBPMSG="HYPERTEXT JUMP ID#"_$O(@DDBLST@("J",""),-1)+1 .D SAVSET .Q STKPT S:DDBRAAH["#" DDBRAAH=$P(DDBRAAH,"#",2) I DDBRAAH]"" S DDBRAHA=$G(@DDBSAN@("A",DDBRAAH)) I DDBRSET,$G(DDBRAHA)'>0 D NOHTJ($G(DIERM)) G PS^DDBR2 S DDBRAHL=$S($G(DDBRAHA):DDBRAHA+DDBSRL-1,1:0) D SET:DDBRSET,GOTO Q Q ; SET ; set and save jump info S DDBRAHP=$O(@DDBLST@("J",""),-1)+1 S @DDBLST@("J",DDBRAHP)=DDBSA_DDGLDEL_DDBL_"^"_+$G(DDBLSTN)_DDGLDEL_DDBRHT Q ; GOTO ; jump to line in current document S DDBL=$S(DDBRAHL'>DDBSRL:0,DDBRAHL>DDBTL:DDBTL,1:DDBRAHL) D PSR^DDBR0(+$G(DDBRAFLG)) Q BCK ; backward Q:'$D(@DDBLST@("J")) N DDBX,DDBY,DDBRAFLG S DDBX=$O(@DDBLST@("J",""),-1),DDBY=@DDBLST@("J",DDBX) K @DDBLST@("J",DDBX) I $P(DDBY,DDGLDEL)'=DDBSA D S DDBRAFLG=1 .D USAVEDDB^DDBR2(DDBLST,$P($P(DDBY,DDGLDEL,2),"^",2)) S DDBL=+$P(DDBY,DDGLDEL,2),DDBRHT=$P(DDBY,DDGLDEL,3,255) D PSR^DDBR0(+$G(DDBRAFLG)) Q CHKI() ;return 1 if ok 0 not ok to continue also init DDBRHT if undefined S DDBRHT=$G(DDBRHT) Q:DDBRHT="" 0 I $P(DDBRHT,DDGLDEL,4)'=DDBSA Q 0 I +DDBRHT>DDBL Q 0 I +DDBRHT<($S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1) Q 0 Q 1 ; NOHTJ(EM) ; no hypertext jump available N X,Y S Y=$P(DDBSANX,"^",$S(DDBSANX["$CREF$":$L(DDBSANX,"^"),1:2)),X(1)=$$CTXT^DDBR(Y,"",IOM),EM=$G(EM) S:$P(EM,"Error:",2)]"" EM="<< "_$P(EM,"Error:",2)_" >>" S X(2)="" S X(3)=$$CTXT^DDBR($S(EM]"":EM,1:"<< "_$$EZBLD^DIALOG(7077)_" >>"),"",IOM) ;**NO HYPERTEXT JUMP W $$WS^DDBR1(.X),$C(7) R X:5 Q ; SAVSET ; S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM) S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S DDBZN=$D(@DDBSA@(DDBTL,0))#2 S DDBDM=0 S DDBSF=1 S DDBST=IOM S DDBC=$NA(^TMP("DDBC","DDBC",$J)) I '$D(@DDBC) F I=1,22:22:176 S @DDBC@(I)="" Q DDBRAHTR DDBRAHTR ;SFISC/DCL-BROWSER ANCHOR & HYPERTEXT PROCESSOR REVERSE TAB ;NOV 04, 1996@13:52 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q REVTAB ; Reverse Tab S DDBRHT=$G(DDBRHT) I $P(DDBRHT,DDGLDEL,4)'=DDBSA S DDBRHT="" N LIM,ULCLR,ULNEW S LIM=DDBL,ULCLR=DDBRHT'>0,ULNEW=0 PSR ;S DDBL=$S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL) D SDLR($S(DDBL'>DDBSRL:0,1:DDBL-DDBSRL)+1) Q SDLR(L) N I,J,SFR,STO I +DDBRHTLIM) S DDBRHT="",ULCLR=1 S DX=0,SFR=$P(DDBSY,";",3),STO=$P(DDBSY,";",2),L=L+DDBSRL F I=SFR:-1:STO S L=L-1 Q:$S(DDBZN:$D(@DDBSA@(L,0)),1:$D(@DDBSA@(L))) S (SFR,DY)=I X IOXY F I=SFR:-1:STO D .I $D(@DDBSA@(L)) S X=$S(DDBZN:@DDBSA@(L,0),1:@DDBSA@(L)),L=L-1 .E Q .I ULCLR,ULNEW Q .Q:$L(X,"$.%")'>2 .S WRF=0,J=$P(X,"$.%",$P(DDBRHT,DDGLDEL,3)),X=$$HTD(X,L+1) .I +DDBRHT,J=$P(DDBRHT,DDGLDEL,2) S ULCLR=1,WRF=1 .Q:'WRF .S DY=I .X IOXY .W $P(DDGLCLR,DDGLDEL),X .Q ; I 'ULNEW S DDBRHT="" Q ; HTD(X,WPIEN) ;text Q:'DDBRHTF $E(X,DDBSF,DDBST) Q:$L(X,"$.")'>2 X S:$L(X,"$.$")>2 X=$$HT(X,"$.$","","","","","","") S:$L(X,"$.%")>2 X=$$HT(X,"$.%",$P(DDGLVID,DDGLDEL),$P(DDGLVID,DDGLDEL,3),(WPIEN'>+DDBRHT!(DDBRHT="")),$S(WPIEN=+DDBRHT:$P(DDBRHT,DDGLDEL,3)-2,1:$L(X,"$.%")-1),$P(DDGLVID,DDGLDEL,4),$P(DDGLVID,DDGLDEL,5)) Q X ; HT(Y,D,C1,C2,UF,UP,U1,U2) ; Q:$L(Y,D)'>2 Y N YL,I,Y1 S YL=$L(Y,D),Y1="" F I=1:1:YL D .S:I#2 Y1=Y1_$P(Y,D,I) .I UF,I=UP,'ULNEW D Q ..S Y1=Y1_C1_U1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_U2_C2,ULNEW=1,WRF=1 ..S DDBRHT=WPIEN_DDGLDEL_$P(Y,D,I)_DDGLDEL_I_DDGLDEL_DDBSA .S:'(I#2) Y1=Y1_C1_$P($P(Y,D,I),"^",$S($P(Y,D,I)["$CREF$":$L($P(Y,D,I),"^"),1:2),255)_C2 .Q Q Y1 DDBRAP DDBRAP ;SFISC/DCL-BROWSER WP ANCHOR PROCESSOR ;06:56 PM 31 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q WP(DDBROOT,DDBRFLG,DDBRTLE) ; ;Pass existing wp root, flag=c/clear all -indexes, title I $G(DDBROOT)="" Q I '$D(@DDBROOT) Q S DDBROOT=$NA(@DDBROOT),DDBRFLG=$G(DDBRFLG),DDBRTLE=$G(DDBRTLE) N DDBRINDX,DDBRSUB,DDBRSUBL,DDBNROOT,DDBSROOT,DDBAXRT,DDBRCHK,DDBRCHK1 N DDBRSX,DDBRSXL,DDBRI,DDBRSXP,DDBRX,DDBRTLER S DDBRINDX=0,DDBNROOT=$$NROOT(DDBROOT),DDBAXRT=$NA(@DDBNROOT@("A")),DDBRCHK1=0 Q:DDBNROOT=""!(DDBAXRT="") K @DDBAXRT F S DDBRINDX=$O(@DDBROOT@(DDBRINDX)),DDBRCHK=1 Q:DDBRINDX'>0 D:$L($G(@DDBROOT@(DDBRINDX,0)),"$.$")>1 I DDBRCHK,$L($G(@DDBROOT@(DDBRINDX)),"$.$")>1 S DDBRCHK1=1 D .S DDBRCHK=0 .I DDBRCHK1 S DDBRSX=@DDBROOT@(DDBRINDX),DDBRSXL=$L(DDBRSX,"$.$") .E S DDBRSX=@DDBROOT@(DDBRINDX,0),DDBRSXL=$L(DDBRSX,"$.$") .F DDBRI=2:2:DDBRSXL S DDBRSXP=$P(DDBRSX,"$.$",DDBRI) S:'$D(@DDBAXRT@(DDBRSXP)) @DDBAXRT@(DDBRSXP)=DDBRINDX .Q S DDBRX="" I DDBRTLE]"" D .I '$D(@DDBNROOT@("TITLE")) S @DDBNROOT@("TITLE")=DDBRTLE .Q I $G(@DDBNROOT@("TITLE"))']"" D .Q:$$QL(DDBROOT)'>1 .S DDBRTLER=$NA(@DDBROOT,$$QL(DDBROOT)-1) .S DDBRTLE=$P($G(@DDBRTLER@(0)),"^") .I DDBRTLE]"" S @DDBNROOT@("TITLE")=DDBRTLE Q .Q S @DDBNROOT@("DATE")=$H Q ; NROOT(DDBROOT) ; *FUNCTION* return new (negative) root for wp field X-REF ;Q $NA(@DDBROOT@(.001)) ;tested ok Q $NA(@DDBROOT@(-1)) ;tested ok and in use ;Q $NA(@DDBROOT@(0,0)) ;tested ok ; BINDEX(DDBROOT,DDBRNR,DDBRNRN) ; *FUNCTION* return "B" index root N DDBRSUBL,DDBSROOT S DDBRSUBL=$$QL(DDBROOT) Q:DDBRSUBL'>1 "" S DDBSROOT=$NA(@DDBROOT,(DDBRSUBL-2)) S DDBRNR=DDBSROOT,DDBRNRN=$$QS(DDBROOT,DDBRSUBL) Q $NA(@DDBSROOT@("B")) ; IENROOT(DDBROOT,DDBRLEV) ;pass root,.variable~by reference to return ; $qs(ddbroot,$ql(ddbroot))~ N DDBRSUBL,DDBSROOT S DDBRSUBL=$$QL(DDBROOT) Q:DDBRSUBL'>1 "" S DDBRLEV=$$QS(DDBROOT,DDBRSUBL) Q $NA(@DDBROOT,(DDBRSUBL-2)) ; EN ;create anchors and jumps on existing wp entry N DDBC,DDBFLG,DDBL,DDBPMSG,DDBSA,DDBX,IOTM,IOBM I '$$TEST^DDBRT W $C(7),!!,$$EZBLD^DIALOG(830),!! Q ;** D LIST^DDBR3(.DDBX) I DDBX'>0 W:DDBX=0 $C(7),!!,$$EZBLD^DIALOG(1404),!! Q ;**NO TEXT S DDBSA=DDBX(6) S DDBFLG=DDBX(4) S DDBPMSG=DDBX(5) W !,"...." ;** D WP(DDBSA,$G(DDBRFLG),DDBPMSG) W !,"done!",! Q ; ENP ;create anchors & jumps and 'P'urge non-referenced jumps N DDBRFLG S DDBRFLG="P" G EN ; ENC ;create anchors and jumps and "C"lear out all jumps prior to building N DDBRFLG S DDBRFLG="C" G EN ; ; THE FOLLOWING CODE WAS COPIED FROM KERNEL'S XLFUTL ROUTINE QL(X) ;$QLENGTH OF GLOBAL STRING N %,%1 S %1="" F %=0:1 Q:%1=$NA(@X,%) S %1=$NA(@X,%) Q %-1 ; QS(X1,X2) ;$QSUBSCRIPT OF GLOBAL STRING N %,%1,Y I X2=-1,X1?1"^"1"[".E1"]".E Q $TR($P($P($NA(@X1,0),"]"),"[",2),"""") I X2=-1,X1?1"^"1"|".E1"|".E Q $TR($P($NA(@X1,0),"|",2,$L($NA(@X1,0),"|")-1),"""") I X2=0,(X1'?1"^"1"[".E)&(X1'?1"^"1"|".E) Q $NA(@X1,X2) I X2=0,X1?1"^"1"[".E1"]".E Q "^"_$P($NA(@X1,X2),"]",2,999) I X2=0,X1?1"^"1"|".E Q "^"_$P($NA(@X1,X2),"|",$L($NA(@X1,X2),"|")) S %1=$NA(@X1,X2-1) I $E(%1,$L(%1))=")" S %1=$E(%1,1,$L(%1)-1) S Y=$P($NA(@X1,X2),%1,2,999),Y=$E(Y,1,$L(Y)-1) I X2=1,$E(Y)="(" S Y=$E(Y,2,999) I X2>1,$E(Y)="," S Y=$E(Y,2,999) I $A(Y)=34,$A(Y,$L(Y))=34 S Y=$E(Y,2,$L(Y)-1) Q Y ; GETR(DDBRWPDD,DDBRENS,DDBRFLG) ;return root ;pass Word-processing DD#, entries (external format)[separated by(:)] ;ie.999008.02,ENTRYONE:SUBENTRY) ; N DDBRA,DDBROOT,DDBREL,DDBRLVLS,DDBRI,DDBREN,DDBRIEN,DDBRDA,DDBRX,DDBRDD,DDBREEN,X,Y Q:'$$UP^DIQGU(DDBRWPDD,.DDBRA) S DDBREL=$L(DDBRENS,":"),DDBRLVLS=$O(DDBRA("")),DDBREN=1,DDBRIEN="," I $G(DDBRFLG)'["I",$G(DUZ(0))'="@" D Q:$G(DIERR) "" .N DIFILE,DIAC,% .S DIFILE=+DDBRA(DDBRLVLS),DIAC="RD" .D ^DIAC .Q:% .D ERR("Read access denied, for file #"_DIFILE) .Q I ("-"_DDBREL)'=DDBRLVLS Q "" F DDBRI=DDBRLVLS:1:-1 D Q:$G(DIERR) .S DDBRDD=+DDBRA(DDBRI),DDBREEN=$P(DDBRENS,":",DDBREN),DDBREN=DDBREN+1 .D DA^DILF(DDBRIEN,.DDBRDA) .S DDBRIEN=","_+$$DIC($$ROOT^DILFD(DDBRDD,DDBRIEN),DDBREEN,.DDBRDA)_DDBRIEN .Q I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q "" S DDBRX=$$GET^DIQG(+DDBRA(-1),$P(DDBRIEN,",",2,99),$O(^DD(+DDBRA(-1),"SB",+DDBRA(0),"")),"B") I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q "" Q $P(DDBRX,"$CREF$",2) ; DIC(DIC,X,DA) ;dic call for exaxt match Q:DIC=""!(X="") "" S DIC(0)="X" S:$E(X)="`" DIC(0)="N" D ^DIC Q $G(Y) ; ERR(DDBERR) N P S P(1)=DDBERR I $G(U)="^" N U S U="^" D BLD^DIALOG(1700,.P) Q DDBRGE DDBRGE ;SFISC/DCL-BROWSE GET/EXECUTE EVENT ;2013-01-22 3:34 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; EN N DDBGF D GETKEY S DDBRPE=0 W @IOSTBM S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1) S DX=0,DY=$P(DDBSY,";",3) X IOXY X DDGLZOSF("EOFF") F S DDBRE=$$READ D Q:DDBRE="^" .I $T(@DDBRE)="" W $C(7) Q .X DDGLZOSF("EON") .D @DDBRE .I DDBRSA S DDBRSA(DDBRSA,"DDBL")=DDBL .S DX=0,DY=$P(DDBSY,";",3) X IOXY .S DDBRPE=DDBRE .X DDGLZOSF("EOFF") X DDGLZOSF("EON") I $G(DDBFLG)["H" Q CLS S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) I DDBRSA S X=DDBL D .N DDBL S DDBL=X .D SR^DDBRS(DDBRSA,$S(DDBRSA=2:1,1:2),.DDBRSA) .W @IOSTBM .S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) .Q I $G(DDBC1),$G(DDBC0)]"" K @DDBC0@(1) K ^TMP("DDBC","DDBC",$J) S IOTM=1,IOBM=IOSL W @IOSTBM,$P(DDGLVID,DDGLDEL,9) D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG)) S DX=0,DY=IOSL-1 X IOXY I DDBSRL+2=IOSL W @IOF D:$G(DDBFLG)'["P" KTMP END Q KTMP D KTMP^DDBRU Q READ() N S,Y F R *Y:DTIME D C Q:Y'=-1 Q Y C I Y<0 S Y="TO" Q ;I Y=13 S Y="COLR" Q S S="" C1 S S=S_$C(Y) I DDBGF("DDBIN")'[(U_S) D I Y=-1 W $C(7) Q . I $C(Y)'?1L S Y=-1 Q . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDBGF("DDBIN")'[(U_S_U) Y=-1 I DDBGF("DDBIN")[(U_S_U),S'=$C(27) S Y=$P(DDBGF("DDBOUT"),U,$L($P(DDBGF("DDBIN"),U_S_U),U)) Q R *Y:5 G:Y'=-1 C1 W $C(7) Q GETKEY N AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T N FIND,SELECT,PREVSC,NEXTSC,HELP,KP7,KP8 S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S F2=$P(DDGLKEY,U,7) S F3=$P(DDGLKEY,U,8) S F4=$P(DDGLKEY,U,9) S FIND=$P(DDGLKEY,U,10) S SELECT=$P(DDGLKEY,U,11) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) S HELP=$P(DDGLKEY,U,16) S KP7=$P(DDGLKEY,U,25) S KP8=$P(DDGLKEY,U,26) F N="DDB" D . S DDBGF(N_"IN")="",DDBGF(N_"OUT")="" . F I=1:1 S T=$P($T(@(N_"MAP")+I),";;",2,999) Q:T="" D .. S @("K="_$P(T,";",2)) .. I DDBGF(N_"IN")'[(U_K) D ... S DDBGF(N_"IN")=DDBGF(N_"IN")_U_K ... S DDBGF(N_"OUT")=DDBGF(N_"OUT")_$P(T,";")_U . S DDBGF(N_"IN")=DDBGF(N_"IN")_U . S DDBGF(N_"OUT")=$E(DDBGF(N_"OUT"),1,$L(DDBGF(N_"OUT"))-1) Q TO S DDBRE="^" Q HELP D HELP^DDBR1 Q HELPS D HELPS^DDBR1 Q RETURN D SWITCH^DDBR2("","R") Q SWITCH D SWITCH^DDBR2() Q RPS I 'DDBRSA D PSR^DDBR0(1) Q N DDBRNI F DDBRNI=1,2 D .I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q .I DDBRSA=1 S DDBL=DDBRSA(DDBRSA,"DDBL") D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q .Q Q PRINT ;Print document N DX,DY,X S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR("PRINT DOCUMENT",$J("",IOM+1),IOM) X IOXY W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff W @IOSTBM S DY=$P(DDBSY,";",2) X IOXY D PT^DDGLIBP(DDBSA,DDBPMSG),RPS Q NEXT D NOOF^DDBR1 Q FIND D FIND^DDBR1 Q GOTO D GOTO^DDBR1 Q BOT D BOT^DDBR0 Q TOP D TOP^DDBR0 Q PD D PD^DDBR0 Q PU D PU^DDBR0 Q QUIT ; EXIT D EXIT^DDBR0 Q COLR D RR^DDBR0 Q COLL D RL^DDBR0 Q COLRE D RRE^DDBR0 Q COLLE D RLE^DDBR0 Q COLJ D COLJ^DDBR0 Q LND D LD^DDBR0 Q LNU D LU^DDBR0 Q HU D CHDR^DDBR4(-1) Q HD D CHDR^DDBR4(1) Q PH D PRTHELP^DDBRP Q STPB D STPB^DDBRWB Q VIEW D VIEW^DDBRWB Q AHT I DDBRHTF D TAB^DDBRAHT Q G BQT AHTR I DDBRHTF D REVTAB^DDBRAHTR Q G BQT TEHT I DDBRHTF D TEDIT^DDBRAHTE Q G BQT RA I DDBRHTF D RA^DDBRAHTE Q G BQT SCRN1 I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM G RPS G BQT SCRN2 I DDBRSA=1 D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM G RPS G BQT SPLIT I 'DDBRSA,$D(DDBRSA(1)) D SPLIT^DDBRS Q G BQT FULL I DDBRSA D FULL^DDBRS(.DDBRSA) Q G BQT RESIZU I DDBRSA,(DDBRSA(1,"IOBM")-1)>(DDBRSA(0,"IOTM")+2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")-1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")-1 D 2,1,ENTB^DDBRS(.DDBRSA,-1) G RPS G BQT RESIZD I DDBRSA,(DDBRSA(2,"IOTM")+1)<(DDBRSA(0,"IOBM")-2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")+1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")+1 D 1,2,ENTB^DDBRS(.DDBRSA,+1) G RPS G BQT BQT W $C(7) Q 1 S DX=0,DY=$P(DDBRSA(1,"DDBSY"),";",4) X IOXY W $P(DDGLCLR,DDGLDEL) Q 2 S DX=0,DY=$P(DDBRSA(2,"DDBSY"),";") X IOXY W $P(DDGLCLR,DDGLDEL) Q DDBMAP ; (CTRL+E ($C(5)) added by VEN/SMH for Fileman V22.2 ;;LNU;AU; ;;LND;AD; ;;COLR;AR; ;;COLL;AL; ;;EXIT;F1_"E"; ;;QUIT;F1_"Q"; ;;QUIT;$C(5); ;;PU;F1_AU; ;;PU;PREVSC; ;;PD;F1_AD; ;;PD;NEXTSC; ;;COLRE;F1_AR; ;;COLLE;F1_AL; ;;STPB;F1_"C"; ;;VIEW;F1_"V"; ;;TOP;F1_"T"; ;;BOT;F1_"B"; ;;GOTO;F1_"G"; ;;FIND;F1_"F"; ;;FIND;FIND; ;;NEXT;"N"; ;;NEXT;F1_"N"; ;;RPS;F1_"P"; ;;SWITCH;F1_"S"; ;;SWITCH;SELECT; ;;RETURN;"R"; ;;HELP;F1_"H"; ;;HELP;"HELP"; ;;HELPS;F1_F1_"H"; ;;EXIT;"EXIT"; ;;SCRN1;F2_AU; ;;SCRN2;F2_AD; ;;SPLIT;F2_"S"; ;;FULL;F2_"F"; ;;RESIZU;F2_F2_AU; ;;RESIZD;F2_F2_AD; ;;HU;F1_F1_AU; ;;HD;F1_F1_AD; ;;PH;F1_F1_F1_"H"; ;;STPB;F1_F1_"C"; ;;AHT;$C(9); ;;AHTR;"Q"; ;;TEHT;F4_"T"; ;;RA;F4_"A"; ;;COLR;$C(13); ;;PRINT;F1_F1_"P"; DDBRP DDBRP ;SFISC/DCL-BROWSER PRINT UTILITY ; 30NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PRTHELP ; Print Help ; N DDGLI,DDGLHN1,DDGLHN2 S (DDGLHN1,DDGLHN2)=$S(DDBRHTF:9202,1:9201) ; BRM ;Clear scroll region, title bar and N DX,DY,X S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR($$EZBLD^DIALOG(7076.4),$J("",IOM+1),IOM) ;**'PRINT BROWSER HELP' X IOXY W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL) W $P(DDGLVID,DDGLDEL,6) ;rvon W $P(DDGLVID,DDGLDEL,4) ;uon W X W $P(DDGLVID,DDGLDEL,10) ;rvoff W @IOSTBM S DY=$P(DDBSY,";",2) X IOXY ; ;Reset for Roll/Scroll mode S X=$G(IOM,80) X ^DD("OS",DISYS,"RM") W $P(DDGLVID,DDGLDEL,9) ; N POP,XQH N IOF,IOSL,DDBUC,DDBLC,DDBRZIS N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%K,%M,%N N %P,%S,%T,%W,%X,%Y,%XX,%YY N %A0,%D1,%D2,%DT,%J1,%W0 ; DEVICE ; ; Save $R, otherwise, it becomes ^%ZTSK in standalone-FM. Fails in DIALOG which saves ^(0) ; ^(0) doesn't exist, and it fails on both GT.M and Cache. N DINAKED S DINAKED=$NA(^(0)) S %ZIS=$S($D(^%ZTSK):"Q",1:""),%ZIS("B")="" S %ZIS("S")="I $$UP^DILIBF($P(^(0),U))'[""BROWSE"",$E($$GET1^DIQ(3.5,Y,""SUBTYPE""))=""P""" ;** S IOF="#",IOSL=DDBSRL D ^%ZIS K %ZIS ; ; Restore $R for DIALOG call. D:DINAKED]"" .I DINAKED["(" Q:$O(@(DINAKED)) Q .I $D(@(DINAKED)) ; I POP D .W !!,$$EZBLD^DIALOG(1901) ;**REPORT CANCELLED .H 2 ; ;Queue report ; E I $D(IO("Q")),$D(^%ZTSK) D .S ZTRTN="PRINTHLP^DDBRP" .S ZTDESC="Browser help printout." .N I F I="DDGLHN1","DDGLHN2" S ZTSAVE(I)="" .D ^%ZTLOAD .; .; Restore $R again .D:DINAKED]"" ..I DINAKED["(" Q:$O(@(DINAKED)) Q ..I $D(@(DINAKED)) .; .; Done with DINAKED .K DINAKED .; QUEUED .I $D(ZTSK)#2 W !,$$EZBLD^DIALOG(8161,ZTSK),! ;** .E W !,$$EZBLD^DIALOG(1901),! ;**REPORT CANCELLED .K ZTSK .S IOP="HOME" D ^%ZIS ; E I $E(IOST,1,2)="C-" D .W !,$C(7)_$$EZBLD^DIALOG(7076.3),! ;**NOT ON CRT .H 2 ; ;Non-queued report E D .W !,"..." ;** .U IO .D PRINTHLP .X $G(^%ZIS("C")) ; ;Reset for Screen Mode S X=0 X ^DD("OS",DISYS,"RM") W $P(DDGLVID,DDGLDEL,8) ; ;Repaint help screen D RPS^DDBRGE Q ; PRINTHLP ; ; N DDGLJ,DDGLL,DDGLP F DDGLI=DDGLHN1:1:DDGLHN2 D . I DDGLI'=DDGLHN1 D .. I $Y+$O(^DI(.84,DDGLI,2," "),-1)+2'0:1,1:0) Q S TA(1,"DDBL")=TA(1,"DDBL")+$S(TA(1,"DDBL")DDBTL DDBL=DDBTL D PSR^DDBR0(1) Q ; SPLIT ;Split Screen N I F I="IOBM","IOTM","DDBSY","DDBSRL" S @I=DDBRSA(2,I) S DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1) S I=1 D INIT("",.DDBRSA) W @IOSTBM S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1) D SR(2,1,.DDBRSA) W @IOSTBM S DDBL=DDBL-(DDBSRL+2),DDBRSA(1,"DDBL")=DDBL S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1) Q ; ;;NOTE: DDBRSA=0 - full screen ;; DDBRSA=1 - top of split screen ;; DDBRSA=2 - bottom of split screen DDBRT DDBRT ;SFISC/DCL-BROWSER TEST ROUTINE ;NOV 04, 1996@13:55 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q TEST() ;TEST IF CRT CAN USE BROWSER;USER MUST GO THRU ZU OR XUP FIRST Q:$G(IOST(0)) $$GET(+IOST(0)) Q:$G(IOS) $$GET($$GET1^DIQ(3.5,+IOS,"SUBTYPE","I")) Q:$G(^XUTL("XQ",$J,"IOST(0)")) $$GET(+^("IOST(0)")) Q:$G(^XUTL("XQ",$J,"IOS")) $$GET($$GET1^DIQ(3.5,+^("IOS"),"SUBTYPE","I")) Q 0 GET(DDBRTIEN) ; I $$GET1^DIQ(3.2,DDBRTIEN,"SET TOP & BOTTOM MARGINS")="" Q 0 I $$GET1^DIQ(3.2,DDBRTIEN,"REVERSE INDEX")="" Q 0 Q 1 DDBRU DDBRU ;SFISC/DCL-BROWSER UTILITIES AND EXTRINSIC FUNCTIONS ; 19JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CTRLCH() ;Extrinsic function - returns control characters 1-31 N I,X S X="" N I F I=1:1:31 S X=X_$C(I) Q X ; COL(DDBC) ;Set up colums used by Fileman Print Set DIOEND="D COL^DDBRU()" when calling Browser N H,I,P,Q,T,X S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)") I $D(^TMP("DDBC",$J)) K ^($J) S X=0 F S X=$O(^UTILITY($J,99,X)) Q:X'>0 S T=^(X) D .S:T["D ^" H=$P(T,"^",2) .S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)="" .Q I $G(H)]"" F X=1:1 S T=$T(@"HEAD"+X^@H) Q:T="" D .S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)="" .Q Q ; KTMP K ^TMP("DDB",$J),^TMP("DDBC",$J) K ^TMP("DDBLST",$J) Q ; TRMERR(DDGLCH) ;Terminal type errors N P S P(1)=DDGLCH,P(2)=IOST D BLD^DIALOG(842,.P) Q ; RTN(RTN,TMPGBL) ; N I,F,X F I=1:1 S X=$T(+I^@RTN) Q:X="" S F=$F(X," ")-1,$E(X,F)=$E(" ",1,$S(F'>8:8-F,1:1)),@TMPGBL@(I)=$TR(X,$C(9)," ") Q ; RTNTB(DDBRTOP,DDBRBOT) ;PASS TOP AND BOTTOM MARGINS G DR ; ENDR N DDBENDR S DDBENDR=1 ; DR ;Display Routine(s) D:'$D(DISYS) OS^DII N DESC,RN,RSA,RTN,X,Y K ^TMP($J,"DDBDR"),^TMP($J,"DDBDRL"),^UTILITY($J) ;DR LIST X ^DD("OS",DISYS,"RSEL") Q:$O(^UTILITY($J,""))']"" S RTN=" ",RN=1 F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" D ; VEN/SMH - Make starting point " " for RTN so it won't crash on Cache .S DESC=$P($P($T(+1^@RTN),";",2),"-",2),DESC=$S($L(DESC)>45:$E(DESC,1,45)_"...",1:DESC) .S RSA=$NA(^TMP($J,"DDBDR",RN)),RN=RN+1,^TMP($J,"DDBDRL",RTN_$E(" ",1,8-$L(RTN))_": "_DESC)=RSA .W !,"...loading ",RTN .D RTN^DDBRU(RTN,RSA) .Q W !,"...building ""Current List"" tables" D DOCLIST^DDBR("^TMP($J,""DDBDRL"")","",$G(DDBRTOP),$G(DDBRBOT)) K K ^TMP($J,"DDBDRL"),^TMP($J,"DDBDR"),^UTILITY($J) Q ; OUT ; D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG)) D:$G(DDBFLG)'["P" KTMP Q ; RE(DDBRTN) G EDIT RTNEDIT N DDBRTN EDIT ;ROUTINE EDIT VIA VA FILEMAN SCREEN EDITOR ;EITHER PASS ROUTINE NAME RE^DDBRU("ROUTINE_NAME") OR USE ;RTNEDIT^DDBRU AND BE PROMPTED FOR ROUTINE NAME I '$D(^DD("OS",^DD("OS"),"ZS")) W !,"ROUTINE SAVE NODE NOT DEFINED IN MUMPS OPERATING SYSTEM FILE",! Q N DDBRI,DDBRX,X,Y,%,%X,%Y I $G(DDBRTN)]"" S X=DDBRTN X ^DD("OS",^DD("OS"),18) I '$T W !,DDBRTN," Invalid",! X ^DD("OS",^DD("OS"),"EON") R:$G(DDBRTN)="" !,"Enter Routine> ",DDBRTN:DTIME I DDBRTN="" W !,"NO ROUTINE SELECTED",! Q S X=DDBRTN X ^DD("OS",^DD("OS"),18) I '$T W !,"NO SUCH ROUTINE",! Q K ^TMP("DDBRTN",$J) W !,"Loading ",DDBRTN F DDBRI=1:1 S DDBRX=$T(+DDBRI^@DDBRTN) Q:DDBRX="" S ^TMP("DDBRTN",$J,DDBRI)=$$SP(DDBRX) D EDIT^DDW("^TMP(""DDBRTN"",$J)","M",DDBRTN,"Routine: "_DDBRTN) K ^UTILITY($J,0) S DDBRI=0,$P(^TMP("DDBRTN",$J,1),";",3)=$$NOW F S DDBRI=$O(^TMP("DDBRTN",$J,DDBRI)) Q:DDBRI'>0 S ^UTILITY($J,0,DDBRI)=$$TAB(^(DDBRI)) S X=DDBRTN X ^DD("OS",^DD("OS"),"ZS") K ^TMP("DDBRTN",$J),^UTILITY($J,0) X ^DD("OS",^DD("OS"),"EON") Q TAB(X) ;CONVERT 1ST SPACE TO TAB IF NO TAB N E,L,T S X=$G(X) Q:X="" "" S T=$C(9) Q:$E(X)=T X S L=$L(X) F E=1:1:L Q:$E(X,E)=T I $E(X,E)=" " S $E(X,E)=T D Q .S E=E+1 .F Q:$E(X,E)'=" " S $E(X,E)="" .Q Q X ; SP(X) ;MAKE SURE A TAB OR 1ST SPACE IS SET TO SPACES N E,L,S,SPS,T S X=$G(X) Q:X="" "" S S=8,$P(SPS," ",S)=" ",T=$E(9) I $E(X)=T S $E(X)=" " ;Q " "_X S L=$L(X) F E=1:1:L I $E(X,E)=" " D S $E(X,E)=$E(SPS,1,S-(E#S)) Q .S E=E+1 .F Q:$E(X,E)'=" " S $E(X,E)="" .S E=E-1 .Q Q X ; NOW() ; N %DT,X,Y S %DT="T",X="NOW" D ^%DT Q $$FMTE^DILIBF(Y,"1U") ; MSMCON ;MSM CONSOLE FOR 132/80 MODES ;OR VT TERMINALS 80 W $C(27),"[?",3,$C(108) S (IOM,X)=80 X ^DD("OS",^DD("OS"),"RM") Q 132 W $C(27),"[?",3,$C(104) S (IOM,X)=132 X ^DD("OS",^DD("OS"),"RM") Q DDBRU2 DDBRU2 ;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS ;2AUG2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q EN N DDBNCC G CNTNU ROOT(DDBNCC,DDBRTOP,DDBRBOT) ; Browse Array Root Descendants ; DDBNCC node count check (default=1000) CNTNU K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J) ;W !!,"Enter Root> " R DDBROOT W !! ;I DDBROOT="^"!(DDBROOT="") Q D ARSEL I $O(^TMP("DDBARDL",$J,""))']"" Q N DDBARDX,N,X S DDBARDX="",DDBNCC=$G(DDBNCC,1000) F S DDBARDX=$O(^TMP("DDBARDL",$J,DDBARDX)) Q:DDBARDX="" S X=^(DDBARDX) D .S N=$O(^TMP("DDBARD",$J,""),-1)+1 .S ^TMP("DDBARDL",$J,DDBARDX)=$NA(^TMP("DDBARD",$J,N)) .W !,"...loading ",DDBARDX .D BLD(DDBNCC,X,N) .Q W !,"...building ""Current List"" tables" D DOCLIST^DDBR("^TMP(""DDBARDL"",$J)","",$G(DDBRTOP),$G(DDBRBOT)) END K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J) Q ; BLD(DDBNCC,DDBROOT,DDBN) ;build structures N DDBMAXL,DDBR1X S DDBMAXL=$G(DDBMAXL,255) S DDBNCC=$G(DDBNCC,1000) S DDBR1X=$$OREF^DIQGU(DDBROOT) N DDBR1,DDBR1A,DDBR1B,DDBR1I,DDBR1Q,DDBI,DDBII,DDBX,DDBX1,DDBX1L,DDBX2,DDBX2L,DDBX3,DDBX3L,DDBXT S DDBR1A=$$OREF^DIQGU($NA(@$$CREF^DIQGU(DDBR1X))),DDBR1Q="""""" I $L(DDBR1A,",")>1,$P(DDBR1A,",",$L(DDBR1A,","))]"" S DDBR1Q=$P(DDBR1A,",",$L(DDBR1A,",")),$P(DDBR1A,",",$L(DDBR1A,","))="" S DDBR1=DDBR1A_DDBR1Q_")",DDBR1B=$L(DDBR1A)+1,DDBX2=" = ",DDBX2L=$L(DDBX2),DDBII=0 F DDBI=1:1 S DDBR1=$Q(@DDBR1) Q:$P(DDBR1,DDBR1A)]""!(DDBR1="") D Q:DDBII .I '(DDBI#DDBNCC) D ..W $C(7),!,DDBROOT,!,"Node count: ",DDBI,!!,"Do you wish to continue //Yes " ..R DDBX:$G(DTIME,300) W !! ..I DDBX=""!($TR($E(DDBX),"y","Y")="Y") Q ..S DDBII=1 ..Q .S DDBX1=DDBR1 .S DDBX3=@DDBR1 .S DDBX1L=$L(DDBX1),DDBX3L=$L(DDBX3) .S DDBXT=DDBX1L+DDBX2L+DDBX3L .I DDBXT'>DDBMAXL S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_DDBX3 Q .I DDBX1L+DDBX2L'>DDBMAXL D Q ..S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_$E(DDBX3,1,DDBMAXL-(DDBX1L+DDBX2L)) ..S DDBI=DDBI+1 ..S ^TMP("DDBARD",$J,DDBN,DDBI)=$E(DDBX3,(DDBMAXL-(DDBX1L+DDBX2L)+1),DDBMAXL) ..Q .Q Q ; ARSEL ; Array Root Select N DDBERR,DDBRLVD,X,Y W !! SEL R !,"Select Root> ",X:$G(DTIME,300) I X="" Q I X="^" K ^TMP("DDBARDL",$J) Q I $E(X)="?" D HLP G SEL I X="^TMP"!(X="^TMP(")!($E(X,1,14)="^TMP(""DDBARDL""") D HLP G SEL S Y=$$OREF^DIQGU(X),DDBERR=0,Y=$$R(Y) I DDBERR W $C(7)," ...INVALID",!!,"'",X,"' CAN NOT BE RESOLVED",! G SEL S DDBRLVD=$$CREF^DIQGU(Y) S Y=$$CREF^DIQGU(X) I $D(@Y)'>9 S Y=$X W $C(7)," ...INVALID",!!,"'",X,"' HAS NO DESCENDANTS",! G SEL I DDBRLVD'=Y S X=X_" ["_DDBRLVD_"]" S ^TMP("DDBARDL",$J,X_" | DESCENDANTS |")=Y G SEL ; HLP ; W !!,"Enter a valid local or global array root" W !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",! Q ; R(%R) ; N %C,%F,%G,%I,%R1,%R2 S %R1=$P(%R,"(")_"(" I $E(%R1)="^" S %R2=$E($P(%R1,"("),2,99) D Q:$G(DDBERR) %R .I $L(%R2)'>0 S DDBERR=1 Q .I %R2="%" Q .I $E(%R2)="%" D Q ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q ..Q .I %R2?1N.E S DDBERR=1 Q .I %R2?.E1P.E S DDBERR=1 Q .Q .;I %R2'="%"&(%R2'?.A) S DDBERR=1 Q %R I $E(%R1)'="^" S %R2=$P(%R1,"(") D Q:$G(DDBERR) %R .I $L(%R2)'>0 S DDBERR=1 Q .I %R2="%" Q .I $E(%R2)="%" D Q ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q ..Q .I %R2?1N.E S DDBERR=1 Q .I %R2?.E1P.E S DDBERR=1 Q .Q .;,$E(%R1)'="%",$E(%R1)'?.A S DDBERR=1 Q %R I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2 S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99) S %C=$L(%R2,","),%F=1 F %I=1:1 Q:%I'<%C S %G=$P(%R2,",",%F,%I) Q:%G="" I ($L(%G,"(")=$L(%G,")")&($L(%G,"""")#2))!(($L(%G,"""")#2)&($E(%G)="""")&($E(%G,$L(%G))="""")) D .S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1,%C=%C+($L(%G,",")-1) .Q S:'DDBERR DDBERR=%F'=%C Q %R1_%R2 S(%Z) ; I $G(%Z)']"" Q "" I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z I +%Z=%Z Q %Z I $E(%Z)?1N,+%Z'=%Z S DDBERR=1 Q %Z I %Z="""""" Q "" I $E(%Z)="""" Q %Z I $E(%Z)'?1A,"%$+@"'[$E(%Z) S DDBERR=1 Q %Z I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z) I $D(@%Z) Q $$Q(@%Z) S DDBERR=1 ;Unable to resolve a variable within a reference Q %Z Q(%Z) ; S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1) DDBRWB DDBRWB ;SFISC/DCL-VA FILEMAN BROWSER PROTOCOLS ;01:54 PM 3 Sep 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q STPB ; Save To Paste Buffer I DDBSA=$NA(^TMP("DDWB",$J)) D G PS^DDBR2 .N X .S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.3),"",IOM) ;**RESTRICTED .W $$WS^DDBR1(.X),$C(7) .R X:5 .Q I $E(DDBSA,1,11)="^DI(.84,920" D G PS^DDBR2 .N X .S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.4),"",IOM) ;**RESTRICTED .W $$WS^DDBR1(.X),$C(7) .R X:5 .Q N X,XF,XT GTR S X(1)=$G(X(1)),X(2)=$$EZBLD^DIALOG(7078) ;**COPY TEXT W $$WS(.X) D G:X=""!(X=U) OUT .D EN^DIR0($P(DDBSY,";",3)-1,$L($G(X(2)))+2,30,1,"",100,1,"","KPW",.X) .K DIR0 .Q I $E(X)="?" S X(1)=$$EZBLD^DIALOG(7078.1) G GTR ;**ENTER LINES I 'X&($E(X)'="*") G OUT I $E(X)="*" S X=$TR(X,"a","A"),XF=1,XT=DDBTL E S X=$TR(X,"a-/;|* ","A:::::"),XF=+X,XT=+$P(X,":",2) I XF<1!(XF>DDBTL) S X(1)=$$EZBLD^DIALOG(7078.2,DDBTL) G GTR ;**ERROR I XT,XT<1!(XT>DDBTL) S X(1)=$$EZBLD^DIALOG(7078.2,DDBTL) G GTR ;** I XT>0,XT0:XF,1:XT),X["A") K X S X(2)="Text Copied to Buffer" W $$WS(.X) R X:3 G OUT ; SAVE(FR,TO,APN) ; Save From To (lines) APN=append to end of current list K:'APN ^TMP("DDWB",$J) N I,II S II=$O(^TMP("DDWB",$J,""),-1)+1 I DDBZN D Q .F I=FR:1:TO S ^TMP("DDWB",$J,II)=@DDBSA@(I,0),II=II+1 .Q F I=FR:1:TO S ^TMP("DDWB",$J,II)=@DDBSA@(I),II=II+1 Q VIEW I DDBSA=$NA(^TMP("DDWB",$J)) S DDBL=0 D SDLR^DDBR0(1),RLPIR^DDBR0 Q I $E(DDBSA,1,11)="^DI(.84,920" D G PS^DDBR2 .N X .S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.5),"",IOM) ;**RESTRICTED .W $$WS^DDBR1(.X),$C(7) .R X:5 .Q N DDBHA,DDBHAT S DDBHA=$NA(^TMP("DDWB",$J)),DDBHAT=0 I $D(^TMP("DDWB",$J))'>9 S ^TMP("DDWB",$J,1)="< No Text >",DDBHAT=1 D BROWSE^DDBR(DDBHA,"PNH","View Paste Buffer",$G(DDBHELPS),"",IOTM-1,IOBM+1) K:DDBHAT ^TMP("DDWB",$J) W @IOSTBM D PSR^DDBR0(1) Q ; SWITCH ; Switching Restricted while in View N X S X(1)="",X(2)=$$CTXT^DDBR($$EZBLD^DIALOG(7078.6),"",IOM) ;**RESTRICTED W $$WS^DDBR1(.X),$C(7) R X:5 G PS^DDBR2 ; OUT D PSR^DDBR0() Q ; WS(X) S DX=0,DY=$P(DDBSY,";",3)-3 X IOXY W $P(DDGLGRA,DDGLDEL) W $TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3)) W $P(DDGLGRA,DDGLDEL,2) W !,$P(DDGLCLR,DDGLDEL),$G(X(1)) W !,$P(DDGLCLR,DDGLDEL),$G(X(2)) W !,$P(DDGLCLR,DDGLDEL),$G(X(3)) S DY=$P(DDBSY,";",3),DX=$L($G(X(2)))+2 X IOXY Q "" DDBRZIS DDBRZIS ;SFISC/DCL-BROWSER DEVICE UTILITIES ; 18NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. OPEN ; ;DDBRZIS AND DDBDMSG ARE KILLED IN POST S DDBRZIS=1,DDBDMSG=$G(DDBDMSG) U IO(0) I $G(DDBDMSG)="" D Q:DDBDMSG="$$DTOUT$$" .N DIR,X,Y .S DIR(0)="FUO^0:78",DIR("A")="BROWSER TITLE (optional)" .S DIR("B")="VA FileMan Browser" .S DIR("?")="Enter any free text, which will appear in the Title Bar" .D ^DIR .I $G(DTOUT) S DDBDMSG="$$DTOUT$$" K DTOUT,DUOUT,DIRUT,DIROUT Q .S DDBDMSG=$S(Y="":DDBDMSG,1:Y) .Q W !,"...one moment..." U IO Q:DDBDMSG]"" I $G(DHD)="W """" D ^DIDH" S DDBDMSG="DATA DICTIONARY" Q S DDBDMSG="VA FileMan Browser" Q ; CLOSE ; Q:$G(DDBDMSG)="$$DTOUT$$" S DDBRZIS=$G(DDBRZIS,1) N C,CHAR,EOF,X K ^TMP("DDB",$J) S EOF="EOF-End Of File" S CHAR="" F I=1:1:31 S CHAR=CHAR_$C(I) U IO W !,EOF,! S DDBRZIS("REWIND")=$$REWIND^%ZIS(IO,IOT,IOPAR) I 'DDBRZIS("REWIND") S DDBRZIS=0 U IO(0) W $C(7),!!?5,"<< UNABLE TO REWIND FILE>>",! H 3 Q U IO S C=0 F R X:2 Q:X="EOF-End Of File" D .S X=$TR(X,CHAR) .S:X']"" X=" " .S C=C+1,^TMP("DDB",$J,C)=$E(X,1,255) Q IHS I C=1,^TMP("DDB",$J,C)=" " S ^TMP("DDB",$J,2)="BROWSER: No display data sent" Q ; POST ; I $G(DDBDMSG)="$$DTOUT$$" K DDBDMSG,DDBRZIS W $C(7) Q I $G(DDBRZIS) D BROWSE^DDBR("^TMP(""DDB"",$J)","NR",$G(DDBDMSG)) K DDBRZIS,DDBDMSG Q ; DEVICE(MSG) ;TEST IF BROWSER IS BEING INVOKED VIA DEVICE HANDLER ;EXTRINSIC FUNCTION I $D(DDBRZIS)#2,$G(MSG)]"" S DDBDMSG=MSG Q 1 Q 0 ; MSG(TXT) ;PASS TEXT FOR BROWSER TITLE WHEN BROWSER INVOKED VIA DEVICE HANDLER ;PROCEDURE CALL S DDBDMSG=$G(TXT) Q STR(X) ; Remove windows N I,Y I $L(X,"|")'>2 Q X I X["|WRAP|"!(X["| NO WRAP|")!(X["|NOWRAP|") S Y="" F I=1:1:$L(X,"|") S:(I#2) Y=Y_$P(X,"|",I) Q $S(X'["|":X,1:$G(Y)) DDD DDD ; GFT/DI* - Build Meta Data Dictionary ;20JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. MAKE ; N DDD,FLD,Z,I,L,F D DT^DICRW I '$D(^DDD(0)) D ^DDDINIT Q:'$D(^DDD(0)) G AC:$D(^DIC("AC","DDD")) W !,"SINCE NO FILE IS IN APPLICATION GROUP 'DDD',",!,"the entire FileMan database will be scanned, and" D OK Q:'$D(%) F DDD=1.99:0 S DDD=$O(^DIC(DDD)) Q:'DDD D BLD G END ; AC W !,"Based on all Files identified as belonging to the 'DDD' Application Group," D OK Q:'$D(%) F DDD=0:0 S DDD=$O(^DIC("AC","DDD",DDD)) Q:DDD="" D BLD END S DIK="^DDD(" D IXALL^DIK W !,"" Q ; BLD N FILE S FILE=DDD,F=$P(^DIC(DDD,0),"^")_"_" FILE W "." F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:'FLD S I=I+1 D FLD I $D(FILE)>9 S FILE=$O(FILE(0)) S F=FILE(FILE) K FILE(FILE) G FILE DDDA N FN,IEN Q:'$D(^DIC("AC","DDDA",DDD)) S FN=$$CREF^DILF(^DIC(DDD,0,"GL")),F=$P(^DIC(DDD,0),U) F IEN=0:0 S IEN=$O(@FN@(IEN)) Q:'IEN S L=$P(@FN@(IEN,0),U),I=$O(^DDD("A"),-1)+1,^DDD(I,0)=F_"_"_L_U_L_U_DDD_U_.01_U_1 Q ; ; FLD Q:'$D(^DD(FILE,FLD,0)) S Z=^(0),%=$P(Z,U,2) I % Q:'$D(^DD(+%,.01,0)) S:$P(^(0),U,2)'["W" FILE(+%)=F_$P(Z,U)_"_" S ^DDD(I,0)=F_$P(Z,U)_U_$P(Z,U)_U_FILE_U_FLD S L=0,^DDD(I,1,0)="" DESCR I $D(^DD(FILE,FLD,3)),^(3)]"" S L=1,^DDD(I,1,1,0)=^(3) F Z=0:0 S Z=$O(^DD(FILE,FLD,21,Z)) Q:'Z S L=L+1,^DDD(I,1,L,0)=$E(" ",L=2)_^(Z,0) I L=0,%["P" S Z=+$P(%,"P",2) I $D(^DD(Z,.01,0)) S %=$P(^(0),U,2) N FILE,FLD S FILE=Z,FLD=.01 D DESCR Q ; OK W !,"a Central Data Dictionary will now be compiled.",!?7,"OK" S %=2 D YN^DICN I %-1 K % Q S I=0 S ^DDD(0)=$P(^DDD(0),U,1,2) N J F J=0:0 S J=$O(^DDD(J)) Q:J="" K ^(J) ; Kill all nodes including indexes. Q ; ; ; BUILDS(FILE,FIELD) ;BUILDs in which a field appears Q:'FILE!'FIELD N D,I,J D IJ^DIUTL(FILE) F D=0:0 S D=$O(^XPD(9.6,D)) Q:'D I $D(^(D,4,J(0),2,FILE,1,FIELD)) N D0 S D0=D,X=$P(^XPD(9.6,D,0),U) X DICMX Q:'$D(D) DDDIN001 DDDIN001 ; ;14MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q:'DIFQ(.9) F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^DIC(.9,0,"GL") ;;=^DDD( ;;^DIC("B","META DATA DICTIONARY",.9) ;;= ;;^DD(.9,0) ;;=FIELD^^25^6 ;;^DD(.9,0,"DT") ;;=3021101 ;;^DD(.9,0,"ID","WDI.03") ;;=W " ",$P(^(0),U,3)_",",$P(^(0),U,4) ;;^DD(.9,0,"IX","AFF",.9,.03) ;;= ;;^DD(.9,0,"IX","AFF2",.9,.04) ;;= ;;^DD(.9,0,"IX","C",.9,.02) ;;= ;;^DD(.9,0,"NM","META DATA DICTIONARY") ;;= ;;^DD(.9,.01,0) ;;=NAME^RF^^0;1^K:$L(X)>60!($L(X)<3)!'(X'?1P.E) X ;;^DD(.9,.01,1,0) ;;=^.1 ;;^DD(.9,.01,3) ;;=Answer must be 3-60 characters in length ;;^DD(.9,.01,"DT") ;;=3021101 ;;^DD(.9,.02,0) ;;=LOOKUP TERM^F^^0;2^K:$L(X)>30!($L(X)<2) X ;;^DD(.9,.02,1,0) ;;=^.1 ;;^DD(.9,.02,1,1,0) ;;=.9^C ;;^DD(.9,.02,1,1,1) ;;=S ^DDD("C",$E(X,1,30),DA)="" ;;^DD(.9,.02,1,1,2) ;;=K ^DDD("C",$E(X,1,30),DA) ;;^DD(.9,.02,1,1,"DT") ;;=3021101 ;;^DD(.9,.02,3) ;;=Answer must be 2-30 characters in length ;;^DD(.9,.02,"DT") ;;=3021101 ;;^DD(.9,.03,0) ;;=DATA DICTIONARY NUMBER^NJ22,6^^0;3^K:+X'=X!(X>999999999999999)!(X<0)!(X?.E1"."7.N) X ;;^DD(.9,.03,1,0) ;;=^.1 ;;^DD(.9,.03,1,1,0) ;;=.9^AFF^MUMPS ;;^DD(.9,.03,1,1,1) ;;=N Y S Y=$P(^DDD(DA,0),U,4) S:Y ^DDD("AFF",$E(X,1,30),Y,DA)="" ;;^DD(.9,.03,1,1,2) ;;=N Y S Y=$P(^DDD(DA,0),U,4) K:Y ^DDD("AFF",$E(X,1,30),Y,DA) ;;^DD(.9,.03,1,1,3) ;;=MULTIPLE CROSS-REF OF FILE,FIELD ;;^DD(.9,.03,1,1,"DT") ;;=3021101 ;;^DD(.9,.03,3) ;;=Type a number between 0 and 999999999999999 ;;^DD(.9,.03,"DT") ;;=3021101 ;;^DD(.9,.04,0) ;;=FIELD NUMBER^NJ18,6^^0;4^K:+X'=X!(X>99999999999)!(X<.001)!(X?.E1"."7.N) X ;;^DD(.9,.04,1,0) ;;=^.1 ;;^DD(.9,.04,1,1,0) ;;=.9^AFF2^MUMPS ;;^DD(.9,.04,1,1,1) ;;=N Y S Y=$P(^DDD(DA,0),U,3) S:Y ^DDD("AFF",Y,$E(X,1,30),DA)="" ;;^DD(.9,.04,1,1,2) ;;=N Y S Y=$P(^DDD(DA,0),U,3) K:Y ^DDD("AFF",Y,$E(X,1,30),DA) ;;^DD(.9,.04,1,1,3) ;;=FILE-FIELD XREF ;;^DD(.9,.04,1,1,"DT") ;;=3021102 ;;^DD(.9,.04,3) ;;=Type a number between .001 and 99999999999 ;;^DD(.9,.04,"DT") ;;=3021102 ;;^DD(.9,.05,0) ;;=DATA^S^1:YES^0;5 ;;^DD(.9,1,0) ;;=DESCRIPTION^.901^^1;0 ;;^DD(.9,9.6,0) ;;=BUILD(S)^Cm^^ ; ^S %=^DDD(D0,0),X="" D BUILDS^DDD($P(%,U,3),$P(%,U,4)) ;;^DD(.9,25,0) ;;=DATA^S^1:YES^0;4 ;;^DD(.9,25,0) ;;=TYPE^CJ20^^ ; ^S %=^DDD(D0,0),X="" I $P(%,U,3) N D0,DCC S DCC="^DD("_$P(%,U,3)_",",D0=$P(%,U,4) X:D0 $P(^DD(0,.25,0),U,5,99) ;;^DD(.9,25,9.01) ;;= ;;^DD(.9,25,9.1) ;;=S %=^DDD(D0,0),X="" I $P(%,U,3) N D0,DCC S DCC="^DD("_$P(%,U,3)_",",D0=$P(%,U,4) X:D0 $P(^DD(0,.25,0),U,5,99) ;;^DD(.9,25,"DT") ;;=3021101 ;;^DD(.901,0) ;;=DESCRIPTION SUB-FIELD^^.01^1 ;;^DD(.901,0,"DT") ;;=3021101 ;;^DD(.901,0,"NM","DESCRIPTION") ;;= ;;^DD(.901,0,"UP") ;;=.9 ;;^DD(.901,.01,0) ;;=DESCRIPTION^W^^0;1 ;;^DD(.901,.01,"DT") ;;=3021101 ;;^UTILITY(U,$J,"SBF",.9,.9) ;;= ;;^UTILITY(U,$J,"SBF",.9,.901) ;;= DDDINIT DDDINIT ; ;06:35 PM 2 Nov 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT S DIOVRD=1,U="^",DIFQ=0,DIFROM="1" W !,"This version (#1) of 'DDDINIT' was created on 02-NOV-2002" EN ; S DIFQ=0 K DIRUT,DTOUT,DUOUT K ^UTILITY("DIF",$J) S ^UTILITY("DIF",$J,2)="",^(1)=" ;;.9I;META DATA DICTIONARY;^DDD(;0;y;;;;;;n" S DIFRDIFI=3,I=1 W !,"I AM GOING TO SET UP THIS FILE:" S DIF(1)=^UTILITY("DIF",$J,1) D 1 G Q:DIFQ!$D(DIRUT) K DIF(1) S DIFROM="1" D PKG:'$D(DIFROM(0)),^DDDINIT1 G Q:'$D(DIFQ) S DIK(0)="AB" F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N) K DIFQR D ^DDDINIT2,^DDDINIT3 L S DUZ=DIDUZ W:1 !,$C(7),"OK, I'M DONE.",! I DIFROM F DIF=1:2:2 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%) I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0 D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U) S DIFQR=DIFQR(+N) I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "." Q R G REP^DDDINIT2 ; 1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 S DIFQ(N)=$P(DIF(I),";",7)'="n" I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 Q Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 ; PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC Q ; IXF ;;;0 DDDINIT1 DDDINIT1 ; ;06:44 PM 2 Nov 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; LOADS AND INDEXES DD'S ; K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q ASKNOT I %=1,$D(DIFQ(0)) S DSEC=1 Q:'$D(DIFQ) S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0 S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD D ^DDDIN001 F S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0 K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0 K ^(D) D IX NODATA Q ; W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0)) S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W S:%=2 DIFQ(X)=0 K:%<0 DIFQ Q ; OPT ;OPTION RTN ;ROUTINE DOCUMENTATION NOTE FUN ;FUNCTION BUL ;BULLETIN KEY ;SECURITY KEY HEL ;HELP FRAME DIP ;PRINT TEMPLATE DIE ;INPUT TEMPLATE DIB ;SORT TEMPLATE DIS ;FORM REM ;REMOTE PROCEDURE ; SBF ;FILE AND SUB FILE NUMBERS IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK) S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK Q DDDINIT2 DDDINIT2 ; ; 02-NOV-2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD Q ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0 S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR S DIK=DIC HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R="" W !,"'"_R_"' Help Frame filed." S DA=^(R) F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99) S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0) I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I IX D IX1^DIK G HELP ; U I $D(DIRUT) S DIFQ=1 W ! Q REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT) I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q S DIR("A")="Shall I replace your file with mine" S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y S DIU(0)="E",DIR("A")="Do you want to keep the Data" S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"D" S DIR("A")="Do you want to keep the Templates" S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T" S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q DDDINIT3 DDDINIT3 ; ;05:27 PM 2 Nov 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0)) S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X="" W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins." I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=% OR ; NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J) I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD S DIC=.5,DLAYGO=0,N="FUN" D ADD I $P($G(^DIC(8994,0)),U)="REMOTE PROCEDURE" S (DIC,DLAYGO)=8994,N="REM" D ADD S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ K ^UTILITY("DIFROM",$J) Q DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII E S DISYS=^DD("OS") Q:'$D(^DD("OS",DISYS,"ZS")) S DIFR1="" DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1="" F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z") G DZ1 ; OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=% S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0)) S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C") F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A Q Q A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0)) K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^") I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%) I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!" .Q I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1) I N="DIST(.403," D BLK S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT I N="DIST(.403," D .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA) .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled" .Q Q BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1 K A0,A1,A2,J,L Q B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X) .Q S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X) .Q S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK") Q KAD(D0) N D1,X S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1) Q DDFIX DDFIX ;SFCIOFO/S0/MKO VARIOUS DD AND DIC FIXES ;9:17 AM 15 Mar 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; FIXPT ; ==> Fix Bad "PT" Nodes <== ; N EP,ESC I '$D(XPDNM) S EP="PT" D DEVICE I $D(ESC) G EXIT DEQPT N DICFILE,DDFILE,DDFIELD,PGLEN,PG,RPTDT,X U IO D RPTDT S PGLEN=IOSL-5,PG=0 I '$D(XPDNM) D PTHDR ; Loop thru DIC(, S DICFILE=1.99999 F S DICFILE=$O(^DIC(DICFILE)) Q:DICFILE'>1.99999!$D(ESC) D . ; Loop thru DD(DICFILE,0,"PT", . S DDFILE=1.99999 . F S DDFILE=$O(^DD(DICFILE,0,"PT",DDFILE)) Q:DDFILE'>1.99999!$D(ESC) D .. I $D(^DD(DDFILE,0))#2 D Q ; File Exists ... ; Check Fields Exists ... S DDFIELD=0 ... F S DDFIELD=$O(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) Q:'DDFIELD!$D(ESC) D .... I $D(^DD(DDFILE,DDFIELD,0))#2 D Q ; Field is still in DD ..... I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D Q ; Field Still A Pointer? ...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" is Not a Pointer Type." D RPTOUT ...... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q ..... I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DICFILE D Q ; Field Still Point To Same File? ...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" Does Not Point To File: "_DICFILE_"." D RPTOUT ...... S X=" Deleting ""PT"" Node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q .... ; **Field No Longer Exists .... S X="*Field: "_DDFIELD_" in File: "_DDFILE_" does Not Exist." D RPTOUT .... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q .. ; **File No Longer Exists .. S X="*File: "_DDFILE_" Does Not Exist." D RPTOUT .. S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE)) D RPTOUT .. K ^DD(DICFILE,0,"PT",DDFILE) G EXIT ; GoTo Common Exit K1 ; Kill at Field Level K ^DD(DICFILE,0,"PT",DDFILE,DDFIELD) Q PTHDR ; Fix "PT" nodes Report Header I $E(IOST,1,2)="C-" D Q:$D(ESC) . I PG D PAUSE Q:$D(ESC) . W @IOF I PG W @IOF S PG=PG+1 W "Fix ""PT"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,! N X S X="",$P(X,"-",(IOM-1))="" W X,! Q ; FIXNM ; ==> Fix Duplicate 'NM' Nodes <== ; From patch DI*21*50, routine DIPR50 ; N EP,ESC I '$D(XPDNM) S EP="NM" D DEVICE I $D(ESC) G EXIT DEQNM N DDFILE,DDNAME,DDNEW,PGLEN,PG,RPTDT,X U IO D RPTDT S PGLEN=IOSL-5,PG=0 I '$D(XPDNM) D NMHDR S DDFILE=1.99999 F S DDFILE=$O(^DD(DDFILE)) Q:'DDFILE!$D(ESC) D . ; Check and repair duplicate "NM" nodes . S DDNAME=$O(^DD(DDFILE,0,"NM","")) Q:DDNAME="" . I $O(^DD(DDFILE,0,"NM",DDNAME))="" Q . S X="*File/Subfile: "_DDFILE_" has duplicate 'NM' nodes." . D RPTOUT . S DDNEW=$S($D(^DIC(DDFILE,0))#2:$P(^(0),U),1:$P(^DD(DDFILE,0)," SUB-FIELD")) . Q:DDNEW="" . K ^DD(DDFILE,0,"NM") . S ^DD(DDFILE,0,"NM",DDNEW)="" . S X=" ""NM"" node will be set to: "_DDNEW . D RPTOUT G EXIT ; GoTo Common Exit Point NMHDR ; Fix "NM" nodes Report Header I $E(IOST,1,2)="C-" D Q:$D(ESC) . I PG D PAUSE Q:$D(ESC) . W @IOF I PG W @IOF S PG=PG+1 W "Fix Duplicate ""NM"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,! N X S X="",$P(X,"-",(IOM-1))="" W X,! Q ; FIXAG ; ==> Application Group Multiple Bad Xrefs <== ; From patch DI*21*58, routine DIPR58 ; N EP,ESC I '$D(XPDNM) S EP="AG" D DEVICE I $D(ESC) G EXIT DEQAG N DDAGPKG,DDFILE,IEN,PGLEN,PG,RPTDT,X U IO D RPTDT S PGLEN=IOSL-5,PG=0 I '$D(XPDNM) D AGHDR S DDFILE=1.99999 F S DDFILE=$O(^DIC(DDFILE)) Q:DDFILE<1.99999 D . I '$D(^DIC(DDFILE,"%")) Q ; No App. Group Multiple . S DDAGPKG="" . F S DDAGPKG=$O(^DIC(DDFILE,"%","B",DDAGPKG)) Q:DDAGPKG="" D .. S IEN=0 .. F S IEN=$O(^DIC(DDFILE,"%","B",DDAGPKG,IEN)) Q:'IEN D ... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)=DDAGPKG Q ... S X="Deleting App. Group "_DDAGPKG_" ""B"" xref: "_$NA(^DIC(DDFILE,"%","B",DDAGPKG,IEN)) ... D RPTOUT ... K ^DIC(DDFILE,"%","B",DDAGPKG,IEN) AC ; Loop Thru "AC" xref and Remove Any Entries That Point to ; Files That Do Not Exist S DDAGPKG="" F S DDAGPKG=$O(^DIC("AC",DDAGPKG)) Q:DDAGPKG="" D . S DDFILE=1.99999 . F S DDFILE=$O(^DIC("AC",DDAGPKG,DDFILE)) Q:DDFILE<1.99999 D .. I $D(^DIC(DDFILE,0))[0 D Q ... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE)) ... D RPTOUT ... K ^DIC("AC",DDAGPKG,DDFILE) .. S IEN=0 .. F S IEN=$O(^DIC("AC",DDAGPKG,DDFILE,IEN)) Q:'IEN D ... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)'=DDAGPKG D .... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE,IEN)) .... D RPTOUT .... K ^DIC("AC",DDAGPKG,DDFILE,IEN) G EXIT ; GoTo Common Exit Point AGHDR ; Fix Application Group Xrefs Report Header I $E(IOST,1,2)="C-" D Q:$D(ESC) . I PG D PAUSE Q:$D(ESC) . W @IOF I PG W @IOF S PG=PG+1 W "Fix Application Group Xrefs Report "_RPTDT,?(IOM-10),"Page: "_PG,! N X S X="",$P(X,"-",(IOM-1))="" W X,! Q ; ; Common For All Entry Points ; DEVICE ; Output Device Selection S %ZIS="MQ" D ^%ZIS I POP S ESC=1 Q ;User Escaped Device Selection I $D(IO("Q")) D . S ZTDESC=$S(EP="PT":"FIX PT NODES",EP="NM":"FIX DUPLICATE 'NM' NODES",EP="AG":"FIX APPLICATION GROUP XREFS",1:"") . S ZTRTN=$S(EP="PT":"DEQPT",EP="NM":"DEQNM",EP="AG":"DEQAG",1:"")_"^DDFIX" . S ZTSAVE("EP")="" . D ^%ZTLOAD . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),! . S ESC=1 . K ZTSK,ZTDESC,ZTRTN,ZTSAVE . D HOME^%ZIS Q RPTDT ; Get Report Date/Time N %,%H,X,Y S %H=$H D YX^%DTC S RPTDT=$P(Y,"@")_"@"_$E($P(Y,"@",2),1,5) Q RPTOUT ; Print Messages I $D(XPDNM) D MES^XPDUTL(X) Q ; KIDS install being used W X,! ; KIDS install not being used I $Y'>PGLEN Q I EP="PT" D PTHDR Q I EP="NM" D NMHDR Q I EP="AG" D AGHDR Q Q PAUSE ; End of Page Pause N DIR,Y S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K DTOUT,DUOUT,DIRUT,DIROUT S ESC=1 Q Q EXIT ; Common Exit Point I $E(IOST,1,2)="P-" D ^%ZISC I $D(ZTQUEUED) S ZTREQ="@" K EP Q DDGF DDGF ;SFISC/MKO-FORM BUILDING TOOL ;7JAN2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;Program-wide variables ; DDGFILE = File number^File name ; DDGFFM = Form number^Form name ; DDGFPG = Page number ; DDGFWID = Window id for given page ; DDGFWIDB = Window id for block displayer for a given page ; DDGFREF = Global reference where data is stored ; DDGFLIM = Boundaries within which cursor can be moved ; $Y1^$X1^$Y2^$X2 ; DDGFBV = If defined, we're in the block view page ; DDGFMSG = Indicates there's a message on the message line. ; N %,%W,%X,%Y,C,D,D0,DI,DIC,DIEQ,DIW,DIZ,DQ,I,X,Y,DIOVRD I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D ^DDGF0 G:$G(DIERR) END^DDGF0 D SEL^DDGFFM G:$D(DDGFFM)[0 END^DDGF0 D ALL^DDGFASUB,^DDGF1,END^DDGF0 Q ; REFRESH ;Repaint all windows, status line D REPALL^DDGLIBW(),STATUS Q ; STATUS ;Paint status line N DX,DY,N,S K DDGFMSG S DY=IOSL-7,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL,3)_$TR($J("",IOM-1)," ","_") ; S DY=IOSL-6 X IOXY W "File: "_$P(DDGFFILE,U,2)_" (#"_$P(DDGFFILE,U)_")" I $D(DDGFBV)#2 S DX=46 X IOXY W "BLOCK VIEWER" W !,"Form: "_$P(DDGFFM,U,2)_" (#"_+DDGFFM_")" S N=$G(@DDGFREF@("F",+$G(DDGFPG))) W !,"Page: "_$S(N]"":$P(N,U,6)_" ("_$P(N,U,5)_")",1:""),!!! I $D(DDGFBV)#2 W $P(DDGLVID,DDGLDEL)_"V=Main Screen H=Help"_$P(DDGLVID,DDGLDEL,10) E W $P(DDGLVID,DDGLDEL)_"Q=Quit E=Exit S=Save V=Block Viewer H=Help"_$P(DDGLVID,DDGLDEL,10) Q ; MSG(M) ;Print message N DDGFDY,DDGFDX S DDGFDY=DY,DDGFDX=DX S:$D(M)[0 M="" S DY=IOSL-2,DX=0 X IOXY ; W $E(M,1,79)_$P(DDGLCLR,DDGLDEL) S:M]"" DDGFMSG=1 K:M="" DDGFMSG S DY=DDGFDY,DX=DDGFDX X IOXY Q ; RESET ;Reset terminal and cleanup S DDGFREF="^TMP(""DDGF"",$J)",DDGLREF="^TMP(""DDGL"",$J)" K DDSFILE,DDSPAGE,DDSPARM,DR G KILL^DDGF0 DDGF0 DDGF0 ;SFISC/MKO-SETUP, CLEANUP ;09:58 AM 9 Sep 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 20 ;Per VHA Directive 2004-038, this routine should not be modified. ; D INIT^DDGLIB0() Q:$G(DIERR) D SET,GETKEY Q ; SET ;Setup variables D:$D(DT)[0 DT^DICRW S (DIOVRD,DDGFR)=1,DDGFREF="^TMP(""DDGF"",$J)",DDGFCHG=0 K @DDGFREF,DDGFFM Q ; END ;Clear screen, clean up variables I $D(DDGFFM)#2 D RECOMP KILL ; D:$G(DIERR) MSG^DIALOG("BW") X:$D(DDGLZOSF) DDGLZOSF("EON"),DDGLZOSF("TRMOFF") D KILL^DDGLIB0() K:$D(DDGFREF) @DDGFREF,DDGFREF K ^TMP("DDGFH",$J) K DDGF,DDGFBV,DDGFCHG,DDGFE,DDGFFILE,DDGFFM,DDGFLIM,DDGFMSG K DDGFPG,DDGFR,DDGFWID,DDGFWIDB K DDH Q ; RECOMP ;Recompile form N DDGFLIST S DDGFLIST=$NA(^TMP("DDGFOF",$J)) D MSG^DDGF("Recompiling ...") ; D GETBLKS(+DDGFFM,DDGFLIST) S DDSQUIET=1 D EN^DDSZ(DDGFFM) K DDSQUIET I $D(@DDGFLIST) D . N DDGFI . S DDGFI="" . F S DDGFI=$O(@DDGFLIST@(DDGFI)) Q:'DDGFI D EN^DDSZ(DDGFI) . K @DDGFLIST ; D MSG^DDGF("") S DX=0,DY=IOSL-1 X IOXY Q ; GETBLKS(F,L) ; ;Determine if any of the blocks loaded are ;used on other forms. ; L(Form#)="" Other forms that need recompiling ; N P,B S P=0 F S P=$O(@DDGFREF@("F",P)) Q:'P D . S B=0 . F S B=$O(@DDGFREF@("F",P,B)) Q:'B D:'$D(@L@("B",B)) .. S @L@("B",B)="" .. D OTHER(B,F,L) K @L@("B") Q ; OTHER(B,F,L) ; ;Return list L of forms other than F that use block B ; L(Form#)="" N F1 S F1="" F S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1="" I F1'=F S @L@(F1)="" S F1="" F S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1="" I F1'=F S @L@(F1)="" Q ; GETKEY ;Get key sequences and defaults N AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S F2=$P(DDGLKEY,U,7) S F3=$P(DDGLKEY,U,8) S F4=$P(DDGLKEY,U,9) ; F N="","S","D" D . S DDGF(N_"IN")="",DDGF(N_"OUT")="" . F I=1:1 S T=$P($T(@(N_"MAP")+I),";;",2,999) Q:T="" D .. S @("K="_$P(T,";",2)) .. I DDGF(N_"IN")'[(U_K) D ... S DDGF(N_"IN")=DDGF(N_"IN")_U_K ... S DDGF(N_"OUT")=DDGF(N_"OUT")_$P(T,";")_U . S DDGF(N_"IN")=DDGF(N_"IN")_U . S DDGF(N_"OUT")=$E(DDGF(N_"OUT"),1,$L(DDGF(N_"OUT"))-1) Q ; MAP ;Keys for main screen ;;LNU;AU; line up ;;LND;AD; line down ;;CHR;AR; char right ;;CHL;AL; char left ;;ELR;$C(9); element right ;;ELL;"Q"; element left ;;TBR;"S"; tab right ;;TBL;"A"; tab left ;;EXIT;F1_"E"; exit ;;QUIT;F1_"Q"; quit ;;ROWCOL;"R"; row/col indicator toggle ;;SCT;F1_AU; top of screen ;;SCB;F1_AD; bottom of screen ;;SCR;F1_AR; right edge of screen ;;SCL;F1_AL; left edge of screen ;;SAVE;F1_"S"; save changes ;;SELECT;" "; select an element ;;SELECT;$C(13); select an element ;;SELFILE;F1_1; select file ;;VIEW;F1_"V"; view toggle ;;EDIT;F3; edit caption or data length ;;FLDADD;F2_"F"; add a new field ;;BKADD;F2_"B"; add a new block ;;NXTPG;F1_F1_AD; go to next page ;;PRVPG;F1_F1_AU; go to previous page ;;CLSPG;F1_"C"; close popup page ;;PGSEL;F1_"P"; select another page ;;PGADD;F2_"P"; add a new page ;;PGEDIT;F4_"P"; edit page attributes ;;FMSEL;F1_"M"; select another form ;;FMADD;F2_"M"; add a new form ;;FMEDIT;F4_"M"; edit form attributes ;;HELP;F1_"H" ;; SMAP ;Keys for moving selected gadgets ;;LNU;AU; line up ;;LND;AD; line down ;;CHR;AR; char right ;;CHL;AL; char left ;;TBR;$C(9); tab right ;;TBR;"S"; " " ;;TBL;"Q"; tab left ;;TBL;"A"; " " ;;ROWCOL;"R"; row/col indicator toggle ;;SCT;F1_AU; top of screen ;;SCB;F1_AD; bottom of screen ;;SCR;F1_AR; right edge of screen ;;SCL;F1_AL; left edge of screen ;;SUBPG;F1_"D"; go into a multiples pop-up page ;;DESELECT;" "; deselect an element ;;DESELECT;$C(13); deselect an element ;;EDIT;F4; edit properties ;;REORDER;F1_"O"; reorder fields in block ;; DMAP ;Keys for changing data length ;;CHR;AR; char right ;;CHL;AL; char left ;;DONE;$C(13); done ;;DONE;" "; done ;;DONE;F3; done ;; DDGF1 DDGF1 ;SFISC/MKO-MAIN SCREEN ;02:46 PM 12 Oct 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) S DDGFE=0 F S Y=$$READ W:$T(@Y)="" $C(7) D:$D(DDGFMSG) MSG^DDGF() D:$T(@Y)]"" @Y Q:DDGFE Q ; LNU I DY>$P(DDGFLIM,U) D RC(DY-1,DX) Q LND I DY<$P(DDGFLIM,U,3) D RC(DY+1,DX) Q CHR I DX<$P(DDGFLIM,U,4) D RC(DY,DX+1) Q CHL I DX>$P(DDGFLIM,U,2) D RC(DY,DX-1) Q ; ELR N Y,X S Y=DY,X=DX S X=$O(@DDGFREF@("RC",DDGFWID,Y,X)) D:X="" . S Y=$O(@DDGFREF@("RC",DDGFWID,Y)) . S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,"")) . S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,Y,"")) D:X]"" RC(Y,X) Q ELL N Y,X S Y=DY,X=DX S X=$O(@DDGFREF@("RC",DDGFWID,Y,X),-1) D:X="" . S Y=$O(@DDGFREF@("RC",DDGFWID,Y),-1) . S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,""),-1) . S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,Y,""),-1) D:X]"" RC(Y,X) Q ; TBR I DX<$P(DDGFLIM,U,4) D . D RC(DY,$S(DX+5'<$P(DDGFLIM,U,4):$P(DDGFLIM,U,4),1:DX+5)) E I DY<$P(DDGFLIM,U,3) D RC(DY+1,$P(DDGFLIM,U,2)) Q TBL I DX>$P(DDGFLIM,U,2) D . D RC(DY,$S(DX-5'>$P(DDGFLIM,U,2):$P(DDGFLIM,U,2),1:DX-5)) E I DY>$P(DDGFLIM,U) D RC(DY-1,$P(DDGFLIM,U,4)) Q ; SCT I DY>$P(DDGFLIM,U) D RC($P(DDGFLIM,U),DX) Q SCB I DY<$P(DDGFLIM,U,3) D RC($P(DDGFLIM,U,3),DX) Q SCR I DX<$P(DDGFLIM,U,4) D RC(DY,$P(DDGFLIM,U,4)) Q SCL I DX>$P(DDGFLIM,U,2) D RC(DY,$P(DDGFLIM,U,2)) Q ; SAVE ;Save data from DDGFREF I 'DDGFPG D ERR(110) Q G SAVE^DDGFSV ; SELECT ;Select an item I 'DDGFPG D ERR(110) Q G SELECT^DDGFEL ; EDIT ;Edit a caption or data length I 'DDGFPG D ERR(110) Q G EDIT^DDGFEL ; FLDADD ;Add a new field to the form I 'DDGFPG D ERR(110) Q G ADD^DDGFFLDA ; VIEW ;Go to block viewer I 'DDGFPG D ERR(110) Q I $O(@DDGFREF@("F",DDGFPG,""))="" D ERR(120) Q G ^DDGF3 ; BKADD ;Add a new block I 'DDGFPG D ERR(110) Q G ADD^DDGFBK ; HBKADD ;Add a header block I 'DDGFPG D ERR(110) Q G ADD^DDGFHBK ; NXTPG ;Go to next page I 'DDGFPG D ERR(110) Q D NXTPRV^DDGFPG(1) Q ; PRVPG ;Go to previous page I 'DDGFPG D ERR(110) Q D NXTPRV^DDGFPG(-1) Q ; CLSPG ;Close pop-up page G CLSPG^DDGFPG ; PGSEL ;Select a new page I 'DDGFPG D ERR(110) Q G PGSEL^DDGFPG ; PGADD ;Add a new page to the form G ADD^DDGFPG ; PGEDIT ;Edit attributes of a page I 'DDGFPG D ERR(110) Q G EDIT^DDGFPG ; FMSEL ;Select another form G SEL^DDGFFM ; FMADD ;Add a new form G ADD^DDGFFM ; FMEDIT ;Edit the form G EDIT^DDGFFM ; HELP ;Invoke help screens G HLP^DDGFH ; TO ;Time-out W $C(7) G QUIT ; QUIT ;Exit from form designer I DDGLSCR>1 G CLSPG^DDGFPG S DDGFE=1 Q EXIT ;Save and exit I DDGLSCR>1 G CLSPG^DDGFPG S DDGFE=1 G SAVE^DDGFSV ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N DDGFS I DDGFR D . S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W DDGFS_$J("",7-$L(DDGFS)) S DY=DDGFY,DX=DDGFX X IOXY Q ; READ() N S,Y F R *Y:DTIME D C Q:Y'=-1 Q Y ; C I Y<0 S Y="TO" Q S S="" C1 S S=S_$C(Y) I DDGF("IN")'[(U_S) D I Y=-1 W $C(7) Q . I $C(Y)'?1L S Y=-1 Q . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("IN")'[(U_S_U) Y=-1 ; I DDGF("IN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("OUT"),U,$L($P(DDGF("IN"),U_S_U),U)) Q R *Y:5 G:Y'=-1 C1 W $C(7) Q ; ERR(X) ; D MSG^DDGF($C(7)_$P($T(@X),";;",2,999)) H 3 D MSG^DDGF() Q 110 ;;There are no pages on this form. Use PF2-P to add a page. 120 ;;There are no blocks on this page. Use PF2-B to add a block. DDGF2 DDGF2 ;SFISC/MKO-ACTIONS FOR SELECTED FIELDS ;02:48 PM 12 Oct 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;Input: ; B = internal block number ; F = internal field order ; T = type of element ("C" = caption, "D" = data) ; C = caption ; C1 = $Y of caption ; C2 = $X of caption ; D = data representation (underlines) ; D1 = $Y of data ; D2 = $X of data ; L = length of data ; P1 = page $Y ; P2 = page $X N DDGFE S DDGFE=0,DDGFLSV=DDGFLIM S DDGFLIM=$P(@DDGFREF@("F",DDGFPG,B),U,1,2)_U_$P(DDGFLIM,U,3,4) ; D PAINTS S DDGFE=0 F S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE D END D:$G(DDGFSUBP) SUBPG1^DDGFPG Q ; END ;Redraw the field S DDGFLIM=DDGFLSV K DDGFLSV Q:$D(^DIST(.404,B,40,F,0))[0 ; S C3=C2+$L(C)-1 I T="C",C]"" D . D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2) . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")="" ; I $D(D) D . S D3=D2+L-1 . D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2) . S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")="" ; S @DDGFREF@("F",DDGFPG,B,F)=C1_U_C2_U_C3_U_C_U_$S($D(D):D1_U_D2_U_D3_U_L,1:"^^^")_U_1,DDGFCHG=1 X IOXY Q ; TO ;Time-out W $C(7) G DESELECT ; DESELECT ; S DDGFE=1 Q ; LNU I T="C" Q:C1'>$P(DDGFLIM,U) I $D(D),D1'>$P(DDGFLIM,U) Q D REDRAW S:T="C" C1=C1-1 S:$D(D) D1=D1-1 S DY=DY-1 D PAINTS Q LND I T="C" Q:C1'<$P(DDGFLIM,U,3) I $D(D),D1'<$P(DDGFLIM,U,3) Q D REDRAW S:T="C" C1=C1+1 S:$D(D) D1=D1+1 S DY=DY+1 D PAINTS Q CHR I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4) I $D(D),D2+L>$P(DDGFLIM,U,4) Q D REDRAW S:T="C" C2=C2+1 S:$D(D) D2=D2+1 S DX=DX+1 D PAINTS Q CHL I T="C" Q:C2'>$P(DDGFLIM,U,2) I $D(D),D2'>$P(DDGFLIM,U,2) Q D REDRAW S:T="C" C2=C2-1 S:$D(D) D2=D2-1 S DX=DX-1 D PAINTS Q TBR N X I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4) I $D(D),D2+L>$P(DDGFLIM,U,4) Q D REDRAW I T="C" D . S X=$$MIN(5,$P(DDGFLIM,U,4)-(C2+$L(C)),$S($D(D):$P(DDGFLIM,U,4)-(D2+L)+1,1:"")) . S C2=C2+X E S X=$$MIN(5,$P(DDGFLIM,U,4)-(D2+L)+1) S:$D(D) D2=D2+X S DX=DX+X D PAINTS Q TBL N X I T="C" Q:C2'>$P(DDGFLIM,U,2) I $D(D),D2'>$P(DDGFLIM,U,2) Q D REDRAW I T="C" D . S X=$$MIN(5,C2-$P(DDGFLIM,U,2),$S($D(D):D2-$P(DDGFLIM,U,2),1:"")) . S C2=C2-X E S X=$$MIN(5,D2-$P(DDGFLIM,U,2)) S:$D(D) D2=D2-X S DX=DX-X D PAINTS Q SCT N Y I T="C" Q:C1'>$P(DDGFLIM,U) I $D(D),D1'>$P(DDGFLIM,U) Q D REDRAW I T="C" S Y=$S('$D(D):C1,C1D1:C1,1:D1),C1=C1+Y E S Y=$P(DDGFLIM,U,3)-D1 S:$D(D) D1=D1+Y S DY=DY+Y D PAINTS Q SCR N X I T="C" Q:C2+$L(C)>$P(DDGFLIM,U,4) I $D(D),D2+L>$P(DDGFLIM,U,4) Q D REDRAW I T="C" D . S X=$P(DDGFLIM,U,4)-$S('$D(D):C2+$L(C),C2+$L(C)>(D2+L):C2+$L(C),1:D2+L)+1 . S C2=C2+X E S X=$P(DDGFLIM,U,4)-(D2+L)+1 S:$D(D) D2=D2+X S DX=DX+X D PAINTS Q SCL N X I T="C" Q:C2'>$P(DDGFLIM,U,2) I $D(D),D2'>$P(DDGFLIM,U,2) Q D REDRAW I T="C" S X=$S('$D(D):C2,C2$P(DDGFLIM,U) D RC(DY-1,DX) Q LND I DY<$P(DDGFLIM,U,3) D RC(DY+1,DX) Q CHR I DX<$P(DDGFLIM,U,4) D RC(DY,DX+1) Q CHL I DX>$P(DDGFLIM,U,2) D RC(DY,DX-1) Q ELR N Y,X S Y=DY,X=DX F D Q:Y=""!(X]"") . S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X)) . S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y)) D:X]"" RC(Y,X) Q ELL N Y,X S Y=DY,X=DX F D Q:Y=""!(X]"") . S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X),-1) . S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y),-1) D:X]"" RC(Y,X) Q TBR I DX<$P(DDGFLIM,U,4) D . D RC(DY,$S(DX+5'<$P(DDGFLIM,U,4):$P(DDGFLIM,U,4),1:DX+5)) E I DY<$P(DDGFLIM,U,3) D RC(DY+1,$P(DDGFLIM,U,2)) Q TBL I DX>$P(DDGFLIM,U,2) D . D RC(DY,$S(DX-5'>$P(DDGFLIM,U,2):$P(DDGFLIM,U,2),1:DX-5)) E I DY>$P(DDGFLIM,U) D RC(DY-1,$P(DDGFLIM,U,4)) Q ; SCT I DY>$P(DDGFLIM,U) D RC($P(DDGFLIM,U),DX) Q SCB I DY<$P(DDGFLIM,U,3) D RC($P(DDGFLIM,U,3),DX) Q SCR I DX<$P(DDGFLIM,U,4) D RC(DY,$P(DDGFLIM,U,4)) Q SCL I DX>$P(DDGFLIM,U,2) D RC(DY,$P(DDGFLIM,U,2)) Q SELECT ; Q:'$D(@DDGFREF@("BKRC",DDGFWIDB,DY)) G SELECT^DDGFBSEL ; SAVE ;Save data G SAVE^DDGFSV ; BKADD ;Add a new block G ADD^DDGFBK ; HBKADD ;Add a header block G ADD^DDGFHBK ; HELP ;Invoke help screens D ^DDGFH,REFRESH^DDGF,RC(DY,DX) Q ; TO W $C(7) QUIT ; EXIT ; VIEW S DDGFE=1 Q CLEANUP ; S DDGFDY=DY,DDGFDX=DX D CLOSE^DDGLIBW(DDGFWIDB,1) I $D(DDGFORIG) D . N A . S A=$$AREA^DDGLIBW(DDGFWID) . D DESTROY^DDGLIBW(DDGFWID,1) . D CREATE^DDGLIBW(DDGFWID,A,$P(@DDGFREF@("F",DDGFPG),U,3)]"") . D BLK^DDGFUPDB(.DDGFORIG) E D OPEN^DDGLIBW(DDGFWID) S DY=IOSL-6,DX=46 X IOXY W $J("",13) S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"Q=Quit E=Exit S=Save V=Block Viewer H=Help"_$P(DDGLVID,DDGLDEL,10) D RC(DDGFDY,DDGFDX) K DDGFDY,DDGFDX,DDGFBV,DDGFEBV,DDGFORIG Q ; PAINT ;Paint block displayer window N B,C,S,DY,DX D CLOSE^DDGLIBW(DDGFWID,1) S DY=IOSL-6,DX=46 X IOXY W "BLOCK VIEWER" S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"V=Main Screen H=Help"_$P(DDGLVID,DDGLDEL,10) I $$EXIST^DDGLIBW(DDGFWIDB) D FOCUS^DDGLIBW(DDGFWIDB) Q D CREATE^DDGLIBW(DDGFWIDB,$P(DDGFLIM,U,1,2)_U_($P(DDGFLIM,U,3)-$P(DDGFLIM,U,1)+1)_U_($P(DDGFLIM,U,4)-$P(DDGFLIM,U,2)+1),$P(@DDGFREF@("F",DDGFPG),U,3)]"") S B="" F S B=$O(@DDGFREF@("F",DDGFPG,B)) Q:B="" D . S C=@DDGFREF@("F",DDGFPG,B) . S S=$P(C,U,4) . S:$P(C,U,3)'$P(DDGFLIM,U)!DDGFHDR D REDRAW S C1=C1-1,DY=DY-1 D PAINTS Q LND Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR D REDRAW S C1=C1+1,DY=DY+1 D PAINTS Q CHR Q:C2'<$P(DDGFLIM,U,4)!DDGFHDR D REDRAW S C2=C2+1,DX=DX+1 D PAINTS Q CHL Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR D REDRAW S C2=C2-1,DX=DX-1 D PAINTS Q TBR N X Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR D REDRAW S X=$$MIN(5,$P(DDGFLIM,U,4)-C2-$L(C)+1) S C2=C2+X,DX=DX+X D PAINTS Q TBL N X Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR D REDRAW S X=$$MIN(5,C2-$P(DDGFLIM,U,2)) S C2=C2-X,DX=DX-X D PAINTS Q SCT Q:C1'>$P(DDGFLIM,U)!DDGFHDR D REDRAW S (C1,DY)=$P(DDGFLIM,U) D PAINTS Q SCB Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR D REDRAW S (C1,DY)=$P(DDGFLIM,U,3) D PAINTS Q SCR N X Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR D REDRAW S X=$P(DDGFLIM,U,4)-C2-$L(C)+1 S C2=C2+X,DX=DX+X D PAINTS Q SCL N X Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR D REDRAW S X=C2-$P(DDGFLIM,U,2) S C2=C2-X,DX=DX-X D PAINTS Q ; EDIT ;Edit block parameters G:'$G(DDGFHDR) EDIT^DDGFBK G EDIT^DDGFHBK ; REORDER ;Reorder fields on block D EN^DDGFORD(B) Q ; TO ;Time-out W $C(7) G DESELECT ; DESELECT ; S DDGFE=1 Q ; CLEANUP ; I '$G(DDGFBDEL) D . S C3=C2+$L(C)-1 . S @DDGFREF@("F",DDGFPG,B)=C1_U_C2_U_C3_U_C_U_1,DDGFCHG=1 . S @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)=$S($G(DDGFHDR):"H",1:"") ; I '$G(DDGFEBV),'$G(DDGFBDEL) D . D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2)) . X IOXY K DDGFHDR,DDGFBDEL Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q ; REDRAW ; D REPAINT^DDGLIBW(DDGFWIDB,(C1-$P(DDGFLIM,U))_U_(C2-$P(DDGFLIM,U,2))_U_1_U_$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1)) Q ; PAINTS ; N Y,X S Y=DY,X=DX S DY=C1,DX=C2 X IOXY W $P(DDGLVID,DDGLDEL,6)_$E(C,1,$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))_$P(DDGLVID,DDGLDEL,10) D RC(Y,X) Q ; MIN(X,Y,Z) ;Return the minimum of two or three numbers N A S A=$S(X$P(DDGFLIM,U) D MV(DY-1,DX) Q LND Q:DY'<$P(DDGFLIM,U,3) D MV(DY+1,DX) Q CHR Q:DX'<$P(DDGFLIM,U,4) D MV(DY,DX+1) Q CHL Q:DX'>$P(DDGFLIM,U,2) D MV(DY,DX-1) Q TBR Q:DX'<$P(DDGFLIM,U,4) D MV(DY,DX+$$MIN(5,$P(DDGFLIM,U,4)-DX)) Q TBL Q:DX'>$P(DDGFLIM,U,2) D MV(DY,DX-$$MIN(5,DX-$P(DDGFLIM,U,2))) Q SCT Q:DY'>$P(DDGFLIM,U) D MV($P(DDGFLIM,U),DX) Q SCB Q:DY'<$P(DDGFLIM,U,3) D MV($P(DDGFLIM,U,3),DX) Q SCR Q:DX'<$P(DDGFLIM,U,4) D MV(DY,$P(DDGFLIM,U,4)) Q SCL Q:DX'>$P(DDGFLIM,U,2) D MV(DY,$P(DDGFLIM,U,2)) Q ; MV(DDGFY,DDGFX) ; I T="PTOP" D . F DDGFC=P1_U_P2,P1_U_P4,P3_U_P2,P3_U_P4 D REPALL^DDGLIBW(DDGFC_"^1^1") . S P1=P1+DDGFY-DY,P2=P2+DDGFX-DX,P3=P3+DDGFY-DY,P4=P4+DDGFX-DX ; I T="PBRC" D . D:DDGFX'=DX REPALL^DDGLIBW(P1_U_P4_"^1^1") . D:DDGFY'=DY REPALL^DDGLIBW(P3_U_P2_"^1^1") . D REPALL^DDGLIBW(P3_U_P4_"^1^1") . S P3=P3+DDGFY-DY,P4=P4+DDGFX-DX ; D CORNER() S DY=DDGFY,DX=DDGFX K DDGFC Q ; CORNER(N) ;Draw corners of box ;In: P1,P2,P3,P4,T; if N:normal video N DY,DX S DY=P1,DX=P2 X IOXY W $P(DDGLGRA,DDGLDEL)_$S($G(N):"",1:$P(DDGLVID,DDGLDEL,6))_$P(DDGLGRA,DDGLDEL,5) S DY=P1,DX=P4 X IOXY W $P(DDGLGRA,DDGLDEL,6) S DY=P3,DX=P2 X IOXY W $P(DDGLGRA,DDGLDEL,7) S DX=P4 X IOXY W $P(DDGLGRA,DDGLDEL,8)_$S($G(N):"",1:$P(DDGLVID,DDGLDEL,10))_$P(DDGLGRA,DDGLDEL,2) Q ; MIN(X,Y,Z) ;Return the minimum of two or three numbers N A S A=$S(X0 @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B) K @DDGFREF@("F",DDGFPG,B) ; ;If no blocks on page, set DDGFEBV to exit Block Viewer ;DDGFBDEL indicates block name should not be painted I $G(DDGFBV) D:'$G(E) . I '$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2),'$O(^(40,0)) S DDGFEBV=1 . S DDGFBDEL=1 E D PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1) ; ;If used on no other forms, ask whether to delete from block file I '$O(^DIST(.403,"AB",B,"")),'$O(^DIST(.403,"AC",B,"")) D . K DDGFANS S DDGFBK=B . D DDS(.404,"[DDGF BLOCK DELETE]") . I $G(DDGFANS) S DIK="^DIST(.404,",DA=DDGFBK D ^DIK K DIK,DA . K DDGFANS,DDGFBK Q ; DDS(DDSFILE,DR,DA,DDSPAGE) ; ;Call DDS S DDSPARM="KTW" D ^DDS K DDSPARM Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFBSEL DDGFBSEL ;SFISC/MKO-SELECT BLOCK ;07:50 AM 23 Aug 1993 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;Sets: ; DDGFORIG(B) = original $Y^original $X for all blocks that were ; selected, since they were potentially moved SELECT ; N B,C,C1,C2,C3 N B1,X1,X2 ; ;Which element is the cursor on? ;Set B=Block S X1="" K B F S X1=$O(@DDGFREF@("BKRC",DDGFWIDB,DY,X1)) Q:X1=""!(DXX2 .. S B=$O(@DDGFREF@("BKRC",DDGFWIDB,DY,X1,X2,"")) .. I @DDGFREF@("BKRC",DDGFWIDB,DY,X1,X2,B)="H",$O(^(B)) S B=$O(^(B)) Q:'$G(B) ; ;Get caption and coordinates S B1=$G(@DDGFREF@("F",DDGFPG,B)) Q:B1="" S C1=$P(B1,U),C2=$P(B1,U,2),C3=$P(B1,U,3),C=$P(B1,U,4) ; S:@DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)="H" DDGFHDR=1 D COVER ; K B1,X1,X2 G ^DDGF4 ; COVER ; N H,O,L ;Clear and/or kill portions of DDGFREF K @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B) ; ;Remember original block coordinates S:$D(DDGFORIG(B))[0 DDGFORIG(B)=C1_U_C2 ; ;Look for covered (hidden) fields ;Set H(B) - array of hidden fields S X1="" F S X1=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1)) Q:X1="" D . S X2="" . F S X2=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1,X2)) Q:X2="" D .. S H=$O(@DDGFREF@("BKRC",DDGFWIDB,C1,X1,X2,"")) .. I H]"",$D(H(H))[0,$$OVERLAP(C2,C3,X1,X2) S H(H)="" ; ;Clear in buffer area occupied by element(s) selected ;If block on the page border, redraw the lines S L=$J("",$L(C)-$S(C3>$P(DDGFLIM,U,4):C3-$P(DDGFLIM,U,4),1:0)) D WRITE^DDGLIBW(DDGFWIDB,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1) ; I $P(@DDGFREF@("F",DDGFPG),U,3) D . I C1=$P(DDGFLIM,U)!(C1=$P(DDGFLIM,U,3)) D .. S L=$TR(L," ",$P(DDGLGRA,DDGLDEL,3)) .. S:C2=$P(DDGFLIM,U,2) $E(L)=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):5,1:7)) .. S:C3'<$P(DDGFLIM,U,4) $E(L,$L(L))=$P(DDGLGRA,DDGLDE,$S(C1=$P(DDGFLIM,U):6,1:8)) .. D WRITE^DDGLIBW(DDGFWIDB,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C2=$P(DDGFLIM,U,2) D .. D WRITE^DDGLIBW(DDGFWIDB,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C3'<$P(DDGFLIM,U,4) D .. D WRITE^DDGLIBW(DDGFWIDB,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),$P(DDGFLIM,U,4)-$P(DDGFLIM,U,2),"G",1) ; ;Write to buffer the overlapped blocks(s) I $D(H)>1 S H="" F S H=$O(H(H)) Q:H="" D . S B1=$G(@DDGFREF@("F",DDGFPG,H)) Q:B1="" . D WRITE^DDGLIBW(DDGFWIDB,$P(B1,U,4),$P(B1,U)-$P(DDGFLIM,U),$P(B1,U,2)-$P(DDGFLIM,U,2),"",1) Q ; OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2 N T I A1B2)!(A2'B2)) DDGFEL DDGFEL ;SFISC/MKO-SELECT OR EDIT ELEMENT ;07:25 AM 7 Aug 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; SELECT ;Select an element N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2 D GETELEM(DY,DX) Q:$G(F)="" ; I F="P" G ^DDGFAPC ; ;Clear and/or kill portions of DDGFREF S:T="D" $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)="" K:T="C" @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C"),@DDGFREF@("F",DDGFPG,B,F) K:$D(D) @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D") ; D COVER G ^DDGF2 ; EDIT ;Edit a caption or data length N B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2,X,Y D GETELEM(DY,DX) Q:"P"[$G(F) ; S DDGFCHG=1 I T="C" D . K D,D1,D2,D3,L . S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)="^^^" . K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C") . D COVER . D .. N DX,DY .. S DY=IOSL-6,DX=IOM-9 X IOXY W "EDIT " . ; . N DDGFCOD,DDGFX . D EN^DIR0(C1,C2,$L(C),1,C,"","","","KWT",.DDGFX,.DDGFCOD) . S X=DDGFX . I $P(DDGFCOD,U)="TO"!(X="!M") W $C(7) S X=C . E I X["^" S X=C . E X $P(^DD(.4044,1,0),U,5,999) I '$D(X) W $C(7) S X=C . S C3=C2+$L(X)-1 . ; . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")="" . D WRITE^DDGLIBW(DDGFWID,X,C1-P1,C2-P2) . I $L(X)<$L(C) D REPAINT^DDGLIBW(DDGFWID,(C1-P1)_U_(C3+1-P2)_U_1_U_($L(C)-$L(X))) . S $P(@DDGFREF@("F",DDGFPG,B,F),U,1,4)=C1_U_C2_U_C3_U_X,$P(^(F),U,9)=1 ; I T="D" D . K C,C1,C2,C3 . S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)="" . K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F) . D COVER,^DDGFADL . ; . S $P(@DDGFREF@("F",DDGFPG,B,F),U,5,8)=D1_U_D2_U_D3_U_L,$P(^(F),U,9)=1 . S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")="" . D WRITE^DDGLIBW(DDGFWID,D,D1-P1,D2-P2) ; D RC(DY,DX) Q ; GETELEM(DY,DX) ;Which element is the cursor on ;Returns P,B,F,T,C,C1,C2,C3,D,D1,D2,D3,L,P1,P2 ;If on pop-up page border, return only B="P",F="P",T="PTOP" or "PBRC" ;Set P=page,B=Block,F=DDO,T=type ("D" or "C") ;If cursor is not on anything, $G(F)="" ; Q:'$D(@DDGFREF@("RC",DDGFWID,DY)) N X1,X2,F1 S X1="" K F F S X1=$O(@DDGFREF@("RC",DDGFWID,DY,X1)) Q:X1=""!(DXX2 .. S B=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,"")) .. S F=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,"")) .. S T=$O(@DDGFREF@("RC",DDGFWID,DY,X1,X2,B,F,"")) Q:"P"[$G(F) ; S P1=$P(DDGFLIM,U),P2=$P(DDGFLIM,U,2) S F1=$G(@DDGFREF@("F",DDGFPG,B,F)) ; ;Get caption, data, and coordinates S C1=$P(F1,U),C2=$P(F1,U,2),C3=$P(F1,U,3),C=$P(F1,U,4) I $P(F1,U,8)]"" D . S D1=$P(F1,U,5),D2=$P(F1,U,6),D3=$P(F1,U,7) . S L=$P(F1,U,8),D=$TR($J("",L)," ","_") Q ; COVER ;Look for covered (hidden) fields ;Input: ; T,C,C1,C2,P1,P2 ;H(DDO) - array of hidden fields ;Erase the element we've selected from buffer ;Redraw the element(s) that were covered N H,O,X1,X2,Y F Y="C1","D1" D . I Y="C1",T'="C" Q . I Y="D1",'$D(D) Q . S X1="" . F S X1=$O(@DDGFREF@("RC",DDGFWID,@Y,X1)) Q:X1="" D .. S X2="" .. F S X2=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2)) Q:X2="" D ... N B ... S B=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,"")) ... S O=$O(@DDGFREF@("RC",DDGFWID,@Y,X1,X2,B,"")) ... I O]"",$D(H(O))[0 D .... I T="C",$$OVERLAP(C2,C3,X1,X2) S H(O)=DDGFPG_U_B .... E I $D(D),$$OVERLAP(D2,D3,X1,X2) S H(O)=DDGFPG_U_B ; ;Clear in buffer area occupied by element(s) selected D:T="C" CLEAR(C,C1,C2,C3) D:$D(D) CLEAR(D,D1,D2,D3) ; ;Write to buffer the overlapped field(s) I $D(H) S H="" F S H=$O(H(H)) Q:H="" D . S O=$G(@DDGFREF@("F",$P(H(H),U),$P(H(H),U,2),H)) Q:O="" . D WRITE^DDGLIBW(DDGFWID,$P(O,U,4),$P(O,U)-P1,$P(O,U,2)-P2,"",1) . I $P(O,U,8)>0 D WRITE^DDGLIBW(DDGFWID,$TR($J("",$P(O,U,8))," ","_"),$P(O,U,5)-P1,$P(O,U,6)-P2,"",1) Q ; OVERLAP(A1,A2,B1,B2) ;Does line with X-coords A1,A2 overlap B1,B2 N T I A1B2)!(A2'B2)) ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q ; CLEAR(C,C1,C2,C3) ;Clear in buffer area occupied by element(s) selected ;If on the page border, redraw the lines N L S L=$J("",$L(C)-$S(C3>$P(DDGFLIM,U,4):C3-$P(DDGFLIM,U,4),1:0)) D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1) ; I $P(@DDGFREF@("F",DDGFPG),U,3) D . I C1=$P(DDGFLIM,U)!(C1=$P(DDGFLIM,U,3)) D .. S L=$TR(L," ",$P(DDGLGRA,DDGLDEL,3)) .. S:C2=$P(DDGFLIM,U,2) $E(L)=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):5,1:7)) .. S:C3'<$P(DDGFLIM,U,4) $E(L,$L(L))=$P(DDGLGRA,DDGLDEL,$S(C1=$P(DDGFLIM,U):6,1:8)) .. D WRITE^DDGLIBW(DDGFWID,L,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C2=$P(DDGFLIM,U,2) D .. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"G",1) . E I C3'<$P(DDGFLIM,U,4) D .. D WRITE^DDGLIBW(DDGFWID,$P(DDGLGRA,DDGLDEL,4),C1-$P(DDGFLIM,U),$P(DDGFLIM,U,4)-$P(DDGFLIM,U,2),"G",1) Q DDGFFLD DDGFFLD ;SFISC/MKO-EDIT A FIELD ;01:47 PM 22 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EDIT ; Q:$D(^DIST(.404,B,40,F,0))[0 I T="D" Q:C]"" K @DDGFREF@("F",DDGFPG,B,F) ; S DDGFDY=DY,DDGFDX=DX S DDGFTYPE=$P(^DIST(.404,B,40,F,0),U,3) I 'DDGFTYPE D . I $G(^DIST(.404,B,40,F,20))'?."^" S DDGFTYPE=2 Q . I $P($G(^DIST(.404,B,0)),U,2),$G(^DIST(.404,B,40,F,1)) S DDGFTYPE=3 G:'DDGFTYPE EDITQ ; S DDGFB2=@DDGFREF@("F",DDGFPG,B) S DDGFB1=$P(DDGFB2,U),DDGFB2=$P(DDGFB2,U,2) S DDGFDD=$P(^DIST(.404,B,0),U,2) S (DDGFSUP,DDGFSUP0)=$S(C]""&(DDGFTYPE'=1):$E(C,$L(C))'=":",1:"") S (DDGFCAP,DDGFCAP0)=$S(DDGFTYPE=1!DDGFSUP0:C,1:$E(C,1,$L(C)-1)) S (DDGFCC,DDGFCC0)=$S(C]"":C1-DDGFB1+1_","_(C2-DDGFB2+1),1:"") I $D(D) D . S (DDGFDL,DDGFDL0)=L . S (DDGFDC,DDGFDC0)=D1-DDGFB1+1_","_(D2-DDGFB2+1) K DDGFB1,DDGFB2 ; S DDSFILE=.404,DDSFILE(1)=.4044,DDSPARM="KSTW" S DR="[DDGF FIELD "_$P("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]" S DA=F,DA(1)=B D . N B,F,T,C,C1,C2,D,D1,D2,L,P1,P2 . D ^DDS K DDSFILE,DDSPARM,DR,DDGFDD ; ;If caption, caption coords, data length, data coords, or suppress ;colon flag changed we need to update some local variables I $D(DA)#2,$G(DDSSAVE) D . S DDGFNDB=$G(@DDGFREF@("F",DDGFPG,B)) . S:DDGFCAP="" (DDGFSUP,DDGFCC)="" . S DR="" . ; . I DDGFCAP'=DDGFCAP0!(DDGFSUP'=DDGFSUP0) D .. S C=DDGFCAP_$S(DDGFCAP]""&(DDGFTYPE'=1)&'DDGFSUP:":",1:"") .. S:DDGFCAP'=DDGFCAP0 DR=DR_"1////"_$S(DDGFCAP]"":DDGFCAP,1:"@")_";" .. S:DDGFSUP'=DDGFSUP0 DR=DR_"5.2////"_$S(DDGFSUP:1,1:"@")_";" . ; . D:DDGFCC'=DDGFCC0 .. S C1=$S(DDGFCAP]"":$P(DDGFCC,",")-1+$P(DDGFNDB,U),1:"") .. S C2=$S(DDGFCAP]"":$P(DDGFCC,",",2)-1+$P(DDGFNDB,U,2),1:"") .. S DR=DR_"5.1////"_$S(DDGFCC]"":DDGFCC,1:"@")_";" . ; . D:$D(D) .. D:DDGFDC'=DDGFDC0 ... S D1=$P(DDGFDC,",")-1+$P(DDGFNDB,U) ... S D2=$P(DDGFDC,",",2)-1+$P(DDGFNDB,U,2) ... S DR=DR_"4.1////"_DDGFDC_";" .. D:DDGFDL'=DDGFDL0 ... S L=DDGFDL ... S D=$TR($J("",L)," ","_") ... S DR=DR_"4.2////"_DDGFDL_";" . ; . I T="D",C]"" D .. D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2,"",1) .. S @DDGFREF@("RC",DDGFWID,C1,C2,C2+$L(C)-1,B,F,"C")="" . ; . I DR]"" D .. N B,F,T,C,C1,C2,D,D1,D2,L,P1,P2 .. S DIE="^DIST(.404,"_DA(1)_",40," .. S DR=$E(DR,1,$L(DR)-1) .. D ^DIE ; K DA,DDGFNDB K DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0 K DDGFDL,DDGFDL0,DDGFDC,DDGFDC0,DDSSAVE K DIE,DR ; D REFRESH^DDGF,RC(DDGFDY,DDGFDX) EDITQ S DDGFE=1 K DDGFDY,DDGFDX,DDGFTYPE Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFFLDA DDGFFLDA ;SFISC/MKO-ADD A FIELD ;2:22 PM 13 Sep 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ADD ;Add a field I '$O(^DIST(.403,+DDGFFM,40,DDGFPG,40,0)) D Q . D MSG^DDGF($C(7)_"There are no blocks defined on this page. To add a block, press B.") . H 2 D MSG^DDGF() S DDGFDY=DY,DDGFDX=DX ; ;Invoke form to select block, field order, field type K DDGFBLCK,DDGFFORD,DDGFTYPE S DDSFILE=.404,DDSFILE(1)=.4044 S DR="[DDGF FIELD ADD]",DDSPARM="KTW" D ^DDS K DDSFILE,DA,DR,DDSPARM ; I '$D(DDGFBLCK)!'$D(DDGFFORD)!'$D(DDGFTYPE) G ADDQ ; ;Get relative field coordinates S (DDGFCAP,DDGFCAP0)="" S (DDGFSUP,DDGFSUP0)="" S (DDGFCC,DDGFCC0)="" ; S DDGFB2=@DDGFREF@("F",DDGFPG,DDGFBLCK) S DDGFB1=$P(DDGFB2,U),DDGFB2=$P(DDGFB2,U,2) ; I DDGFTYPE=1 D . S DDGFCC0=DDGFDY-DDGFB1+1_","_(DDGFDX-DDGFB2+1) E D . S DDGFD1=DDGFDY-DDGFB1+1,DDGFD2=DDGFDX-DDGFB2+1 . S (DDGFDC,DDGFDC0)=DDGFD1_","_DDGFD2 . S (DDGFDL,DDGFDL0)=1 ; I DDGFTYPE'=1,DDGFD1<1!(DDGFD2<1) D G ADDQ . D MSG^DDGF($C(7)_"Unable to add a field above or to the left of the block.") . H 2 D MSG^DDGF() ; K DDGFD1,DDGFD2 ; ;Add field order to block file S DIC="^DIST(.404,"_DDGFBLCK_",40,",DIC(0)="L" S DIC("P")=$P(^DD(.404,40,0),U,2) S DA(1)=DDGFBLCK,X=DDGFFORD K DD,DO D FILE^DICN I Y=-1 K DIC,DA,Y D MSG^DDGF($C(7)_"Unable to add field.") H 2 D MSG^DDGF() G ADDQ ; ;Stuff values for field type, data coordinate, and data length ;If form-only field, also stuff in default read type S DIE=DIC,DA(1)=DDGFBLCK,DA=+Y S DR="2////"_DDGFTYPE S:DDGFTYPE'=1 DR=DR_";4.1////"_DDGFDC_";4.2////1" S:DDGFTYPE=2 DR=DR_";20.1////F" D ^DIE K DIC,DIE,DR,Y ; ;Invoke appropriate form S DDSFILE=.404,DDSFILE(1)=.4044,DDSPARM="CKTW" S DDGFDD=$P(^DIST(.404,DDGFBLCK,0),U,2) S DR="[DDGF FIELD "_$P("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]" D ^DDS K DDSFILE,DR,DDSPARM,DDGFDD ; I $D(DA)#2,DDGFTYPE'=1,$G(DDSCHANG)'=1 D . S DIK="^DIST(.404,"_DA(1)_",40," . D ^DIK K DIK E I $D(DA)#2 D . D SAVE . D LOADF ; ADDQ ;Refresh and cleanup D REFRESH^DDGF D RC(DDGFDY,DDGFDX) ; K DA,DDSCHANG K DDGFB1,DDGFB2,DDGFD1,DDGFD2 K DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0 K DDGFDL,DDGFDL0,DDGFDC,DDGFDC0 K DDGFDY,DDGFDX,DDGFBLCK,DDGFFORD,DDGFTYPE Q ; SAVE ;Save changes to caption, coordinates, data length, and suppress ;colon flag S:DDGFCAP="" (DDGFSUP,DDGFCC)="" S DR="" ; S:DDGFCAP]"" DR=DR_"1////"_DDGFCAP_";" S:DDGFCC]"" DR=DR_"5.1////"_DDGFCC_";" S:DDGFSUP DR=DR_"5.2////1;" ; I DDGFTYPE'=1 D . S:DDGFDC'=DDGFDC0 DR=DR_"4.1////"_DDGFDC_";" . S:DDGFDL'=DDGFDL0 DR=DR_"4.2////"_DDGFDL_";" I DR="" K DR Q ; S DIE="^DIST(.404,"_DA(1)_",40," S DR=$E(DR,1,$L(DR)-1) D ^DIE K DIE,DR,Y Q ; LOADF ;Set DDGFREF and window buffer N C,C1,C2,C3,D,D1,D2,D3,L ; I DDGFCAP="" D . S (C,C1,C2,C3)="" . K @DDGFREF@("F",DDGFPG,DDGFBLCK,DA) E D . S C=DDGFCAP_$S(DDGFTYPE'=1&'DDGFSUP:":",1:"") . S C1=$P(DDGFCC,",")-1+DDGFB1 . S C2=$P(DDGFCC,",",2)-1+DDGFB2 . S C3=C2+$L(C)-1 . ; . S @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)=C1_U_C2_U_C3_U_C . S @DDGFREF@("RC",DDGFWID,C1,C2,C3,DDGFBLCK,DA,"C")="" . D WRITE^DDGLIBW(DDGFWID,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1) ; I DDGFTYPE'=1 D . S D1=$P(DDGFDC,",")-1+DDGFB1 . S D2=$P(DDGFDC,",",2)-1+DDGFB2 . S D3=D2+DDGFDL-1 . ; . S $P(@DDGFREF@("F",DDGFPG,DDGFBLCK,DA),U,5,8)=D1_U_D2_U_D3_U_DDGFDL . I D1]"",D2]"" S @DDGFREF@("RC",DDGFWID,D1,D2,D3,DDGFBLCK,DA,"D")="" . D:DDGFDL WRITE^DDGLIBW(DDGFWID,$TR($J("",DDGFDL)," ","_"),D1-$P(DDGFLIM,U),D2-$P(DDGFLIM,U,2),"",1) Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFFM DDGFFM ;SFISC/MKO-FORM ADD, EDIT, SELECT ;2AUG2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; SEL ;Select another form ADD ;Add a new form N X,DIR0 K DDGFABT S DDGFDY=+$G(DY),DDGFDX=+$G(DX),(DY,DX)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) X DDGLZOSF("EON"),DDGLZOSF("TRMOFF") ; ;Select file FIL S DDS1=8107 D W^DICRW K DDS1 G:Y<0 ADDQ ;**CCO/NI EDIT/CREATE FORM G:'$D(@(DIC_"0)")) ADDQ ; ;Select form W ! S DIC("S")="I $P(^(0),U,8)=+DDGFFILE" I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,3)) I DUZ(0)[$E($P(^(0),U,3),DDSI) Q" S DDGFFILE=Y,DIC=.403,DIC(0)="QEAL",D="F"_+Y D IX^DIC K DIC,D G:Y<0 ADDQ S DDGFY=Y ; ;Save data for previous form I DDGFCHG,$D(DDGFFM)#2 G:+DDGFFM=+DDGFY ADDQ D G:$G(DDGFABT) ADDQ . N DDGFFNAM . S DIR(0)="Y",DDGFFNAM=$P(DDGFFM,U,2) . S DIR("A")="Save changes to form "_DDGFFNAM . S DIR("B")="YES" . S DIR("?",1)=" Enter 'Y' or press 'Return' to save changes." . S DIR("?",2)=" Enter 'N' to discard changes." . S DIR("?")=" Enter '^' to return to form "_DDGFFNAM . W ! D ^DIR K DIR I $D(DIRUT) K DIRUT,DUOUT,DTOUT S DDGFABT=1 Q . D SAVE^DDGFSV ; I $D(DDGFFM)#2,+DDGFFM'=+DDGFY D RECOMP^DDGF0 ; S DDGFFM=$P(DDGFY,U,1,2) ; ;Stuff in values for form K DR S DIE=.403,DA=+DDGFY,DDGFNEW=$P(DDGFY,U,3) S:DDGFNEW DR="3////"_DUZ_";4///NOW" S DR=$S($G(DR)]"":DR_";",1:"")_"5///NOW" S:DDGFNEW DR=DR_";7////"_+DDGFFILE D ^DIE K DIE,DA,DR,D,%DT I DDGFNEW,$G(DUZ(0))]"" D . S $P(^DIST(.403,+DDGFFM,0),U,2,3)=DUZ(0)_U_DUZ(0) ; ;If this is a new form, create Page 1 N GFT I DDGFNEW D Q:$D(GFT) . K DD,DO . S DIC="^DIST(.403,+DDGFFM,40,",DIC("P")=$P(^DD(.403,40,0),U,2) . S DIC(0)="",DA(1)=+DDGFFM,X=1 . D FILE^DICN I Y=-1 K DIC,Y Q . S DIE=DIC,DA=+Y,DR="2////1,1;7////Page 1" . D ^DIE K DIC,DIE,DA,DR,D,Y SELPAGE .S Y=^DIC(+DDGFFILE,0,"GL") I $P($G(@(Y_"0)")),U,4)<999 D I Y=1 D GFT K DDGFFM W !!,"DONE!",! Q ..N DIR S DIR(0)="Y",DIR("A")="Do you want your Form to begin with a display of all entries, for selection" ..S DIR("?")="Answer YES to save setup time!",DIR("?",1)="Your Form can automatically present a scrolling list of all entries" ..I $O(^DD(+DDGFFILE,0,"ID",0)) S DIR("?",2)="including IDENTIFIER fields" ..D ^DIR ; ;Clear data for previous form W $P(DDGLCLR,DDGLDEL,2) I $D(@DDGFREF) K @DDGFREF D DESTALL^DDGLIBW ; ;Get first page, load form S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B","")) I DDGFPG]"" S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,"")) D PG^DDGFLOAD(+DDGFFM,DDGFPG),STATUS^DDGF S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2) ; ADDQQ X DDGLZOSF("EOFF"),DDGLZOSF("TRMON") D RC(DDGFDY,DDGFDX) K DDGFABT,DDGFDY,DDGFDX,DDGFNEW,DDGFY Q ; ; GFT ;BUILD A SELECTION PAGE N DIC,FLD,LN,L,DLAYGO,GFTQUIT,GFTID,GFTPOS,DDGH S (DLAYGO,DIC)=.404,X=$P(DDGFY,U,2),DIC(0)="LX",DIC("DR")="1////"_+DDGFFILE D FILE^DICN ;CREATE NEW BLOCK FOR DATA S DDGFBLK=+Y Q:'$P(Y,U,3) S (DLAYGO,DIC)=.404,X=$P(DDGFY,U,2)_" HEADER",DIC(0)="LX",DIC("DR")="1////"_+DDGFFILE D FILE^DICN ;CREATE NEW HEADER BLOCK S DDGH=+Y S FLD=0,GFTID=U,GFTPOS=2 S GFT=.01 F S FLD=FLD+1 D Q:$G(GFTQUIT) S GFT=$O(^DD(+DDGFFILE,0,"ID",GFT)) Q:'GFT .D FIELD^DID(+DDGFFILE,GFT,"","FIELD LENGTH;LABEL","GFT(GFT)") .S L=GFT(GFT,"LABEL") I $L(GFTID)+$L(L)+$L(GFTID,U)>74 S GFTQUIT=1,FLD=FLD-1 Q ;HEADER RESTRICTS NUMBER OF FIELDS .S LN=GFT(GFT,"FIELD LENGTH") S:LN>74 LN=74 S GFTID(FLD)=LN,GFTPOS(FLD)=GFTPOS,GFTPOS=GFTPOS+LN+2,GFTID(FLD,1)=GFT,GFTID=GFTID_L_U F S L=GFTPOS-79\FLD Q:L<1 S LN=0 F X=1:1:FLD D .I GFTID(X)-1<6 Q .S GFTID(X)=GFTID(X)-1,GFTPOS=GFTPOS-1,GFTPOS(X)=GFTPOS(X)-LN,LN=LN+1 ;TRIM FIELD LENGTHS BY 1 F X=1:1 Q:'$D(GFTID(X)) D .S DIC="^DIST(.404,"_DDGFBLK_",40,",DLAYGO=.4044,DA(1)=DDGFBLK,DIC(0)="LX" .S DIC("DR")="2////3;3.1////"_$P(GFTID,U,X+1)_";4////"_GFTID(X,1)_";4.1///2,"_GFTPOS(X)_";4.2///"_GFTID(X) .D FILE^DICN ;CREATE A DATA FIELD S DIC="^DIST(.404,"_DDGH_",40,",DA(1)=DDGH,DIC(0)="LX",X=1,DIC("DR")="2///4;4.1///1,1;4.2///80;30///S Y=$$HEADER^DDGFFM("_+DDGFFM_")" D FILE^DICN ;CREATE THE HEADER FIELD S GFT=^DIC(+DDGFFILE,0,"GL") I '$D(^DD(+DDGFFILE,0,"IX","B",+DDGFFILE,.01)) S GFT="F D=0:0 S D=$O("_GFT E S GFT="S GFT="""" F S GFT=$O("_GFT_"""B"",GFT)) Q:GFT="""" F D=0:0 S D=$O("_GFT_"""B"",GFT," ;SHOW ENTRIES ALPHABETICALLY IF THERE IS A "B" X-REF S GFT=GFT_"D)) Q:'D N Y S (Y,D0)=D "_$G(^DD(+DDGFFILE,0,"SCR"))_" X DICMX Q:'$D(D)" S DIE=.403,DA=+DDGFFM,DR="21///1" D ^DIE ;FORM'S RECORD SELECTION PAGE=1 S DIC="^DIST(.403,"_DA_",40,1,40,",DA(2)=DA,DA(1)=1,(X,DINUM)=DDGFBLK,DIC(0)="UXL",DIC("P")=".4032IP",DLAYGO=.4032 S DIC("DR")="1///1;2///2,1;3///e;5///15;98.1///"_+DDGFFILE_";98////^S X=GFT" D FILE^DICN ;ADD DATA BLOCK TO PAGE S DIE="^DIST(.403,"_+DDGFFM_",40,",DR="1////"_DDGH,DA=1 D ^DIE ;ADD HEADER BLOCK POINTER Q ; ; HEADER(FORM) ;GIVES NICE HEADER LINE. CALLED BY HEADER BLOCK COMPUTED EXPRESSION N B,X,F,S,L,D,FILE,Y,FILENAME,LABEL,LINE S X="",S=0,B=$O(^DIST(.403,FORM,"AY",1,0)) I 'B Q X S FILE=$P(^(B),U,3) Q:'FILE F F=0:0 S F=$O(^DIST(.403,FORM,"AY",1,B,F)) Q:'F S Y=$G(^(F,"D")) Q:'Y S:'$D(LINE) LINE=+Y Q:Y>LINE D .S L=$P(Y,U,3) Q:'L .S D=$P(Y,U,4),LABEL=$$LABEL^DIALOGZ(FILE,D) .D:$L(LABEL)>L S LABEL=$E(LABEL,1,L) ..N Z,T F Z=0:0 S Z=$O(^DIST(.404,B,40,Z)) Q:'Z I $G(^(Z,1))=D S T=$P(^(0),U,5) I T]"",$L(T)<$L(LABEL) S LABEL=T Q ;TRY SHORTER 'UNIQUE NAME' .I D=.01,$L(LABEL)+30 S DDGFLIST(+$P(DDGFLN,U,5),+$P(DDGFLN,U,6),DDO)="" . E I $P(DDGFLN,U,4)]"" S DDGFLIST(+$P(DDGFLN,U),+$P(DDGFLN,U,2),DDO)="" ; K ^DIST(.404,DDGFBK,40,"B") S DDGFN=0 S DDGFR="" F S DDGFR=$O(DDGFLIST(DDGFR)) Q:DDGFR="" D . S DDGFC="" F S DDGFC=$O(DDGFLIST(DDGFR,DDGFC)) Q:DDGFC="" D .. S DDO="" F S DDO=$O(DDGFLIST(DDGFR,DDGFC,DDO)) Q:DDO="" D ... S DDGFN=DDGFN+1 ... S DDGFO=$P(^DIST(.404,DDGFBK,40,DDO,0),U) ... S:DDGFO'=DDGFN $P(^DIST(.404,DDGFBK,40,DDO,0),U)=DDGFN ; S DIK="^DIST(.404,DDGFBK,40,",DA(1)=DDGFBK,DIK(1)=".01^B" D ENALL^DIK D MSG^DDGF("Reordering completed.") H 1 D MSG^DDGF() Q DDGFPG DDGFPG ;SFISC/MKO-ADD A NEW PAGE ;2:26 PM 13 Sep 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ADD ;Invoke forms to add a new page S DDGFDY=DY,DDGFDX=DX K DDGFPNUM ; ;Ask for new page number S DDSFILE=.403,DDSFILE(1)=.4031 S DA(1)=+DDGFFM,DA="",DR="[DDGF PAGE ADD]",DDSPARM="KTW" D ^DDS K DDSFILE,DA,DR,DDSPARM ; G:$D(DDGFPNUM)[0 ADDQ ; ;Ask 'are you sure' page should be added K DDGFANS S DDSFILE=.403,DDSFILE(1)=.4031 S DR="[DDGF PAGE ADD]",DA(1)=+DDGFFM,DA="",DDSPARM="KTW",DDSPAGE=11 D ^DDS K DDSFILE,DA,DR,DDSPARM,DDSPAGE ; I '$G(DDGFANS) K DDGFANS G ADDQ K DDGFANS ; ;Add page to form S DIC="^DIST(.403,+DDGFFM,40,",DIC(0)="L",DA(1)=+DDGFFM S DIC("P")=$P(^DD(.403,40,0),U,2),X=DDGFPNUM K DD,DO D FILE^DICN K DIC,DA,X G:Y=-1 ADDQ S DDGFPG=+Y ; ;Stuff in values for coordinates and name S DIE="^DIST(.403,"_+DDGFFM_",40,",DA(1)=+DDGFFM,DA=DDGFPG S DR="2////1,1;7////Page "_DDGFPNUM D ^DIE K DIE,DA,DR ; K DDGFPNUM D LOADPG S DDGFNEW=1 G EDIT ; ADDQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX) K DDGFPNUM,DDGFDY,DDGFDX Q ; EDIT ;Invoke form to edit a page ;Input: DDGFNEW (optional) ; Set by ADD to indicate this is a brand new page. ; S DDGFDY=DY,DDGFDX=DX S DDGFND=@DDGFREF@("F",DDGFPG) S (DDGFTLC,DDGFTLC0)=$P(DDGFND,U)+1_","_($P(DDGFND,U,2)+1) S (DDGFLRC,DDGFLRC0)=$S($P(DDGFND,U,3)]"":$P(DDGFND,U,3)+1_","_($P(DDGFND,U,4)+1),1:"") S (DDGFPNM,DDGFPNM0)=$P(DDGFND,U,5) S DDGFPAR=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2) ; S DDSFILE=.403,DDSFILE(1)=.4031,DDSPARM="KTW" S DA(1)=+DDGFFM,DA=DDGFPG,DR="[DDGF PAGE EDIT]" D ^DDS K DDSFILE,DA,DR,DDSPARM ; S DDGFND=$G(^DIST(.403,+DDGFFM,40,DDGFPG,0)) ; ;If page was deleted, destroy windows and set new page I DDGFND="" D Q:DDGFE . I $D(DDGFWID)#2,$$EXIST^DDGLIBW(DDGFWID) D DESTROY^DDGLIBW(DDGFWID) . I $D(DDGFWIDB)#2,$$EXIST^DDGLIBW(DDGFWIDB) D DESTROY^DDGLIBW(DDGFWIDB) . K @DDGFREF@("F",DDGFPG),@DDGFREF@("RC",DDGFWID),@DDGFREF@("BKRC",DDGFWIDB) . I $D(@DDGFREF@("ASUB","B",DDGFPG)) D DEL^DDGFASUB(DDGFPG) . S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B","")) . S:DDGFPG]"" DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,"")) . D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX) ; E D . S:DDGFPNM'=DDGFPNM0 $P(@DDGFREF@("F",DDGFPG),U,5)=DDGFPNM,$P(^(DDGFPG),U,7)=1,DDGFCHG=1 . D:DDGFPAR'=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2) EDIT^DDGFASUB(DDGFPG) . I DDGFTLC'=DDGFTLC0!(DDGFLRC'=DDGFLRC0) D .. D PAGE^DDGFUPDP($P(DDGFTLC,",")-1,$P(DDGFTLC,",",2)-1,$S(DDGFLRC]"":$P(DDGFLRC,",")-1,1:""),$S(DDGFLRC]"":$P(DDGFLRC,",",2)-1,1:""),$S(DDGFTLC=DDGFTLC0:"PBRC",1:"PTOP")) .. D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) . E D REFRESH^DDGF,RC(DDGFDY,DDGFDX) ; K DDGFDX,DDGFDY,DDGFND,DDGFNEW K DDGFLRC,DDGFLRC0,DDGFPOP,DDGFPOP0,DDGFTLC,DDGFTLC0 K DDGFPAR,DDGFPNM,DDGFPNM0 Q ; PGSEL ;Select a new page S DDGFDY=DY,DDGFDX=DX,DDGFPAGE=DDGFPG ; S DDSFILE=.403,DDSFILE(1)=.4031 S DR="[DDGF PAGE SELECT]",DDSPARM="KTW" D ^DDS K DDSFILE,DA,DR,DDSPAGE,DDSPARM ; I DDGFPAGE]"",DDGFPAGE'=DDGFPG S DDGFPG=DDGFPAGE D LOADPG ; D REFRESH^DDGF,RC(DDGFDY,DDGFDX) K DDGFPAGE,DDGFDY,DDGFDX Q ; NXTPRV(F) ;Go to page ;F=1:next page; -1:previous page S DDGFPAGE=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,0)),U,$S($G(F)=-1:5,1:4)) G:DDGFPAGE="" NXTPRVQ S DDGFPAGE=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPAGE,"")) G:$D(^DIST(.403,+DDGFFM,40,+DDGFPAGE,0))[0!(DDGFPAGE=DDGFPG) NXTPRVQ ; S DDGFPG=DDGFPAGE D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX) NXTPRVQ K DDGFPAGE,DDGFDY,DDGFDX Q ; CLSPG ;Close page Q:$G(DDGLSCR)'>1 D CLOSE^DDGLIBW(DDGFWID) S DDGFPG=$E(DDGLSCR(DDGLSCR),2,999) D PG^DDGFLOAD(+DDGFFM,DDGFPG,1) D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) Q ; SUBPG ;Go into subpage I $D(@DDGFREF@("ASUB",DDGFPG,B,F))#2 S DDGFSUBP=^(F) E D . S DDGFSUBP=+$P($G(^DIST(.404,B,40,F,7)),U,2) . S DDGFSUBP=+$O(^DIST(.403,+DDGFFM,40,"B",DDGFSUBP,"")) ; I $D(^DIST(.403,+DDGFFM,40,DDGFSUBP,0))[0 W $C(7) K DDGFSUBP Q I DDGFSUBP=DDGFPG K DDGFSUBP Q S DDGFE=1 Q ; SUBPG1 S DDGFPG=DDGFSUBP K DDGFSUBP D PG^DDGFLOAD(+DDGFFM,DDGFPG) D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2)) Q ; LOADPG ;Load new page D PG^DDGFLOAD(+DDGFFM,DDGFPG,1) S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2) Q ; RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor N S I DDGFR D . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1) . X IOXY W S_$J("",7-$L(S)) S DY=DDGFY,DX=DDGFX X IOXY Q DDGFSV DDGFSV ;SFISC/MKO- SAVE DATA ;12:41 PM 29 Mar 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SAVE ;Save in form/block files data in DDGFREF N P,B,F,P1,B1,F1,N ; I '$G(DDGFCHG) D MSG^DDGF("Nothing to save.") H 1 D MSG^DDGF() Q D MSG^DDGF("Saving data ...") ; ;Loop through all pages in DDGFREF S P="" F S P=$O(@DDGFREF@("F",P)) Q:P="" D PG ; D MSG^DDGF("Data saved.") H 1 D MSG^DDGF() S DDGFCHG=0 Q ; PG ;Save page data S P1=@DDGFREF@("F",P) I $P(P1,U,7),$D(^DIST(.403,+DDGFFM,40,P,0))#2 D . S N=^DIST(.403,+DDGFFM,40,P,0) . S $P(N,U,3)=$P(P1,U)+1_","_($P(P1,U,2)+1) . S $P(N,U,6,7)=$S($P(P1,U,3)="":U,1:1_U_($P(P1,U,3)+1)_","_($P(P1,U,4)+1)) . S ^DIST(.403,+DDGFFM,40,P,0)=$$STPU(N) . ; . S N=$G(^DIST(.403,+DDGFFM,40,P,1)) . I $P(N,U)'=$P(P1,U,5) D .. S DIE="^DIST(.403,"_+DDGFFM_",40," .. S DR="7////"_$P(P1,U,5),DA(1)=+DDGFFM,DA=P .. N P D ^DIE K DIE,DR,DA ; ;Loop through all blocks S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D BK Q ; BK ;Save block data S B1=@DDGFREF@("F",P,B) I $P(B1,U,5),$D(^DIST(.403,+DDGFFM,40,P,40,B,0))#2 D . S $P(^DIST(.403,+DDGFFM,40,P,40,B,0),U,3)=$P(B1,U)-$P(P1,U)+1_","_($P(B1,U,2)-$P(P1,U,2)+1) . I $P(^DIST(.404,B,0),U)'=$P(B1,U,4) D .. S DIE="^DIST(.404,",DR=".01////"_$P(B1,U,4),DA=B .. N B,P D ^DIE K DIE,DR,DA ; ;Loop through all fields S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D FD Q ; FD ;Save field data S F1=@DDGFREF@("F",P,B,F) I $P(F1,U,9),$D(^DIST(.404,B,40,F,0))#2 D . S N="" . S $P(N,U,1,2)=$S($P(F1,U,8):$S($P(F1,U,5)]""&($P(F1,U,6)]""):$P(F1,U,5)-$P(B1,U)+1_","_($P(F1,U,6)-$P(B1,U,2)+1),1:"")_U_$P(F1,U,8),1:U) . S $P(N,U,3,4)=$S($L($P(F1,U,4)):$S($P(F1,U)]""&($P(F1,U,2)]""):$P(F1,U)-$P(B1,U)+1_","_($P(F1,U,2)-$P(B1,U,2)+1),1:"")_U_$S($P(F1,U,4)?.E1":":"",1:1),1:U) . S:$P(^DIST(.404,B,40,F,0),U,3)=1 $P(N,U,4)="" . S ^DIST(.404,B,40,F,2)=$$STPU(N) . ; . ;Use DIE to stuff in new caption . I $P(^DIST(.404,B,40,F,0),U,2)'=$P(F1,U,4) D .. S DIE="^DIST(.404,"_B_",40," .. S DR="1////"_$S($P(F1,U,4)?.1":":"@",$P(F1,U,4)?1.E1":":$E($P(F1,U,4),1,$L($P(F1,U,4))-1),1:$P(F1,U,4)) .. S DA(1)=B,DA=F .. N P,B,F D ^DIE K DIE,DR,DA Q ; STPU(X) ;Strip trailing up-arrows from X N I F I=$L(X):-1:0 Q:$E(X,I)'="^" Q $E(X,1,I) DDGFU DDGFU ;SFISC/MKO-CALLED FROM THE FORMS ;10:49 AM 27 Jul 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; VAL1 ;Data validation code ;Form: DDS FIELD ADD I $$GET^DDSVALF("BLOCK","DDGF FIELD ADD")]"",$$GET^DDSVALF("FIELD ORDER","DDGF FIELD ADD")]"",$$GET^DDSVALF("FIELD TYPE","DDGF FIELD ADD")]"" Q ; S DDGFT(1)=$C(7)_"Unable to save values." S DDGFT(2)="All values must be filled in order to add a new field." D HLP^DDSUTL(.DDGFT) S DDSERROR=1 K DDGFT Q ; DDCAP ;Caption, Post action on change ;Form: DDGF FIELD DD N DDGFOPG S DDGFOPG=$$OTHPG D:DDSOLD="!M" PUT^DDSVAL(.4044,.DA,1.1,"") ; D:X="" CAPNULL(DDGFOPG) D:X]"" UPDDC(DDGFOPG) Q ; OTHPG() ;Return Other Params page# N FLD,SUB,OPG S FLD=$$GET^DDSVAL(.4044,.DA,4) I FLD D . S OPG=11 . S SUB=+$P($G(^DD(DDGFDD,FLD,0)),U,2) . S:SUB OPG=$S(SUB_$P($G(^DD(SUB,.01,0)),U,2)'["W":21,1:31) Q $G(OPG) ; FOCAP ;Caption, Post action on change ;Form: DDGF FIELD FORM ONLY D:X'="!M" PUT^DDSVAL(.4044,.DA,1.1,"") ; D:X="" CAPNULL(21) D:X]"" UPDDC(21) Q ; COMPCAP ;Caption, Post action on change ;Form: DDGF FIELD COMPUTED D:X'="!M" PUT^DDSVAL(.4044,.DA,1.1,"") ; D:X="" CAPNULL(11) D:X]"" UPDDC(11) Q ; CAPNULL(OPG) ;Caption changed to null N DC,SC ; ;Clear suppress colon S SC=$$GET^DDSVALF("SUPPRESS COLON AFTER CAPTION?") D PUT^DDSVALF("SUPPRESS COLON AFTER CAPTION?","","","","I") Q:'$G(OPG) ; ;Clear caption coords D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,"") ; ;Move data to the left S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG) S $P(DC,",",2)=$P(DC,",",2)-$L(DDSOLD)-1-'SC S:$P(DC,",",2)<1 $P(DC,",",2)=1 D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC,"I") Q ; UPDDC(OPG) ;Update data coords N DC,COL S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG) S COL=$P(DC,",",2),COL=COL+$L(X)-$L(DDSOLD) I DDSOLD="" D . D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,DC,"I") . S COL=COL+2 S:COL<1 COL=1 S $P(DC,",",2)=COL D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC) Q ; POSTCH1 ;Field, Post Action On Change ;Form: DDGF FIELD DD ; ;Reset (if caption not !M): caption, caption and data coords, ; data length ;Input: ; DDGFPG = Page # ; DA(1) = Block # ; DA = Field order ; X = Fld # ; DDSOLD = Prev fld # ; Q:X="" N FILE,FLD,DD,C,C0,CC,DC,SC,L,OPG,OPG0,PLRC ; S FLD=X S FILE=+$P(^DIST(.404,DA(1),0),U,2) Q:'FILE S DD=$G(^DD(FILE,FLD,0)) Q:DD?."^" S OPG=$$OTHPG ; S OPG0=11 I $G(DDSOLD)]"" D . N SUB . S SUB=+$P($G(^DD(FILE,DDSOLD,0)),U,2) . S:SUB OPG0=$S(SUB_$P($G(^DD(SUB,.01,0)),U,2)'["W":21,1:31) ; S (C,C0)=$$GET^DDSVALF("CAPTION",1,1) S:C]"" CC=$$GET^DDSVALF("CAPTION COORDINATE",1,OPG0) S DC=$$GET^DDSVALF("DATA COORDINATE",1,OPG0) ; I OPG'=OPG0 D . D:C]"" PUT^DDSVALF("CAPTION COORDINATE",1,OPG,CC) . D:DC]"" PUT^DDSVALF("DATA COORDINATE",1,OPG,DC) . D DESTROY^DDSUTL(OPG0) . ; I $D(DDGFREF),$D(DDGFPG) S PLRC=$P($G(@DDGFREF@("F",DDGFPG)),U,4) S PLRC=$S($G(PLRC)]"":PLRC-1,1:IOM-2)-$P($G(@DDGFREF@("F",DDGFPG,DA(1))),U,2) S L=$$LENGTH(FILE,FLD) S:'L L=1 ; I C'="!M",$P(DD,U)]"" D . S C=$P(DD,U) . I $P(DD,U,2),$P($G(^DD(+$P(DD,U,2),.01,0)),U,2)'["W" S C="Select "_C . D PUT^DDSVALF("CAPTION",1,1,C) . ; . I C0="" D .. S CC=DC .. S $P(DC,",",2)=$P(DC,",",2)+2 .. D PUT^DDSVALF("CAPTION COORDINATE",1,OPG,CC) . E Q:$P(CC,",")'=$P(DC,",") . ; . S $P(DC,",",2)=$P(DC,",",2)+$L(C)-$L(C0) . S:$P(DC,",",2)<1 $P(DC,",",2)=1 . D PUT^DDSVALF("DATA COORDINATE",1,OPG,DC) ; I C0'="!M",$P(DC,",",2)-2+L>PLRC S L=PLRC-$P(DC,",",2)+2 D PUT^DDSVALF("DATA LENGTH",1,OPG,L) Q ; HBVAL ;Validate hdr blk Q:X="" Q:'$O(@(DIE_DA_",40,""B"",X,"""")")) S DDSERROR=1 D HLP^DDSUTL($C(7)_DDSEXT_" already exists on this page.") Q ; LENGTH(DIFILE,DIFLD) ;Find max field length N DD,DIIT,DILEN,DITYPE S DILEN="" S DD=$G(^DD(DIFILE,DIFLD,0)) Q:DD?."^" DILEN S DITYPE=$P(DD,U,2),DIIT=$P(DD,U,5,999) ; I DIIT["$L(X)>" S DILEN=+$P($P(DIIT,"$L(X)>",2,999),"E") E I DITYPE["N" S DILEN=+$P(DITYPE,"J",2) E I DITYPE["P" S DILEN=$$LENGTH(+$P(DITYPE,"P",2),.01) ; E I DITYPE["S" D . N DICODE,DICODEA,DIPC . S DICODE=$P(DD,U,3) . F DIPC=1:1 S DICODEA=$P(DICODE,";",DIPC) Q:DICODEA="" D .. S DILEN=$$MAX(DILEN,$L($P(DICODEA,":")),$L($P(DICODEA,":",2))) ; E I DITYPE["D" D . N DIDT . S DIDT=$P($P(DIIT,"S %DT=""",2,999),"""") . S DILEN=$S(DIDT["S"&(DIDT["T"):20,DIDT["T":17,1:11) ; E I DITYPE["V" D . N DIL,DIX . S DIX=0 F S DIX=$O(^DD(DIFILE,DIFLD,"V",DIX)) Q:'DIX D .. Q:'$G(^DD(DIFILE,DIFLD,"V",DIX,0)) .. S DIL=$G(DIL)+1 .. S DIL(DIL)=$$LENGTH(+^DD(DIFILE,DIFLD,"V",DIX,0),.01) . S DILEN=$G(DIL(1)) . F DIL=1:1:$G(DIL)-1 S DILEN=$$MAX(DIL(DIL),DIL(DIL+1)) ; E I DITYPE D . Q:$D(^DD(+DITYPE,.01,0))[0 . S DILEN=$S($P(^DD(+DITYPE,.01,0),U,2)["W":1,1:$$LENGTH(+DITYPE,.01)) ; Q DILEN ; MAX(X,Y,Z) ;Return max of 2 or 3 numbers N M S M=$S(X>Y:+X,1:+Y),M=$S(M>$G(Z):M,1:+$G(Z)) Q M DDGFUPDB DDGFUPDB ;SFISC/MKO-UPDATE BLOCK COORDINATES ;03:28 PM 17 Aug 1993 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. BLK(DDGFORIG) ; ;Update image with adjusted block coordinates ; DDGFORIG(B) : defined for all blocks that changed coordinates ; = original $Y^original $X N P,P1,P2,B,B1,B2,F,C1,C2,C3,C,D1,D2,D3,L,X1,Y1,N,I ; ;Get page coordinates S P=DDGFPG S P1=$P(@DDGFREF@("F",P),U),P2=$P(@DDGFREF@("F",P),U,2) ; ;Loop through all blocks on page S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D BK Q ; BK ;Get block coordinates S B2=@DDGFREF@("F",P,B) S B1=$P(B2,U),B2=$P(B2,U,2) ; ;Get Y1=delta $Y, X1=delta $X I $D(DDGFORIG(B)) S Y1=B1-$P(DDGFORIG(B),U),X1=B2-$P(DDGFORIG(B),U,2) E S (Y1,X1)=0 I 'Y1,'X1 K DDGFORIG(B) ; ;Loop through all fields on block S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D FD Q ; FD ; ;Get field data S N=@DDGFREF@("F",P,B,F) S C1=$P(N,U),C2=$P(N,U,2),C3=$P(N,U,3),C=$P(N,U,4) S D1=$P(N,U,5),D2=$P(N,U,6),D3=$P(N,U,7),L=$P(N,U,8) ; I $D(DDGFORIG(B)) D . I Y1 S:C1]"" $P(N,U)=C1+Y1 S:L $P(N,U,5)=D1+Y1 . I X1 D .. I C]"" F I=2,3 S $P(N,U,I)=$P(N,U,I)+X1 .. I L F I=6,7 S $P(N,U,I)=$P(N,U,I)+X1 . S @DDGFREF@("F",P,B,F)=N . ; . I C]"" D .. K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C") .. S @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B,F,"C")="" . I L D .. K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D") .. S @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B,F,"D")="" ; I C]"" D WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2) I L D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2) Q DDGFUPDP DDGFUPDP ;SFISC/MKO-UPDATE PAGE COORDINATES ;01:37 PM 19 Jan 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PAGE(P1,P2,P3,P4,T,A) ; ; D DESTROY^DDGLIBW(DDGFWID,1),DESTROY^DDGLIBW(DDGFWIDB,1) I P3]"" D . D REPALL^DDGLIBW($G(A)) . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1),1) . S DDGFLIM=P1_U_P2_U_P3_U_P4 E D . D CLOSEALL^DDGLIBW() . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(IOSL-7-P1)_U_(IOM-1-P2)) . S DDGFLIM=P1_U_P2_U_(IOSL-8)_U_(IOM-2) D:T="PTOP" TOP(P1,P2,P3,P4) D:T="PBRC" BRC(P1,P2,P3,P4) Q ; TOP(P1,P2,P3,P4) ;Update page image ; N B,C,C1,C2,C3,D1,D2,D3,F,I,L,N,P,X1,Y1 ; S P=DDGFPG S N=@DDGFREF@("F",P) S Y1=P1-$P(N,U),X1=P2-$P(N,U,2) I 'Y1,'X1 Q ; I $P(N,U,3)]"" D . K @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,4),"P","P","PTOP") . K @DDGFREF@("RC",DDGFWID,$P(N,U,3),$P(N,U,4),$P(N,U,4),"P","P","PBRC") I $G(P3)]"" D . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")="" . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")="" ; S $P(N,U,1,4)=P1_U_P2_U_P3_U_P4,$P(N,U,7)=1,DDGFCHG=1 S @DDGFREF@("F",P)=N ; ;Loop through all blocks on page S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D . S N=@DDGFREF@("F",P,B) . S @DDGFREF@("BKRC",DDGFWIDB,$P(N,U)+Y1,$P(N,U,2)+X1,$P(N,U,3)+X1,B)=@DDGFREF@("BKRC",DDGFWIDB,$P(N,U),$P(N,U,2),$P(N,U,3),B) . K @DDGFREF@("BKRC",DDGFWIDB,$P(N,U),$P(N,U,2),$P(N,U,3),B) . S $P(N,U,1,3)=$P(N,U)+Y1_U_($P(N,U,2)+X1)_U_($P(N,U,3)+X1) . S @DDGFREF@("F",P,B)=N . ; . S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D .. S N=@DDGFREF@("F",P,B,F) .. S C1=$P(N,U),C2=$P(N,U,2),C3=$P(N,U,3),C=$P(N,U,4) .. S D1=$P(N,U,5),D2=$P(N,U,6),D3=$P(N,U,7),L=$P(N,U,8) .. ; .. I Y1 S:C1]"" $P(N,U)=C1+Y1 S:L $P(N,U,5)=D1+Y1 .. I X1 D ... I C]"" F I=2,3 S $P(N,U,I)=$P(N,U,I)+X1 ... I L F I=6,7 S $P(N,U,I)=$P(N,U,I)+X1 .. S @DDGFREF@("F",P,B,F)=N .. ; .. I C]"" D ... K @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C") ... S @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B,F,"C")="" .. I L D ... K @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D") ... S @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B,F,"D")="" .. ; .. D:C]"" WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2) .. D:L WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2) Q ; BRC(P1,P2,P3,P4) ;Change bottom right coordinate of page N B,C,F,L,N,P S P=DDGFPG S N=@DDGFREF@("F",P) I $P(N,U,3)]"" D . K @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,4),"P","P","PTOP") . K @DDGFREF@("RC",DDGFWID,$P(N,U,3),$P(N,U,4),$P(N,U,4),"P","P","PBRC") I $G(P3)]"" D . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")="" . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")="" ; S $P(N,U,1,4)=P1_U_P2_U_P3_U_P4,$P(N,U,7)=1,DDGFCHG=1 S @DDGFREF@("F",P)=N ; ;Loop through all blocks/fields on page S B="" F S B=$O(@DDGFREF@("F",P,B)) Q:B="" D . S F="" F S F=$O(@DDGFREF@("F",P,B,F)) Q:F="" D .. S N=@DDGFREF@("F",P,B,F) .. S C=$P(N,U,4),L=$P(N,U,8) .. ; .. I C]"" D WRITE^DDGLIBW(DDGFWID,C,$P(N,U)-P1,$P(N,U,2)-P2) .. I L D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),$P(N,U,5)-P1,$P(N,U,6)-P2) Q DDGLBXA DDGLBXA ;SFISC/MKO-A LIST BOX ;1:58 PM 26 Apr 1996 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; LIST(DDGLGLO,DDGLOUT,DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLSEL,DDGLFLG,DDGLMAP) ; ;Input: ; DDGLGLO = closed reference of local or global that contains ; the list of entries ; @DDGLGLO("B",entry,index)="" ; DDGLROW = $Y of top left corner ; DDGLCOL = $X of top left corner ; DDGLHT = height of box ; DDGLWD = width of box ; DDGLSEL = text of selected item ; DDGLFLG = flags ; DDGLMAP = array to customize key sequences ; ;Output: ; DDGLOUT = index of selected entry (if any) ; DDGLOUT(0) = selected entry ; DDGLOUT("C") = code indicates what terminated the read ; ;Other variables: N DDGLCID ; window (control) id N DDGLNL ; number of lines in list N DDGLNC ; number of columns in list N DDGLLINE ; current line number N DDGLITEM ; item array ; DDGLITEM(1..DDGLNL) = text of item displayed ; Q:$G(DDGLGLO)="" D INIT X DDGLZOSF("EOFF") W $P(DDGLVID,DDGLDEL,11) ; D ^DDGLBXA1 ; W $P(DDGLVID,DDGLDEL,12) X DDGLZOSF("EON") D DESTROY(DDGLCID,$G(DDGLFLG)) Q ; CREATE(DDGLGLO,DDGLCID,DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLSEL,DDGLMAP) ; ;Create a list box window ;Out: ; .DDGLCID array = properties of list box ; .DDGLCID(id,"SV") = cid^$Y^$X^NL^NC^LINE ; .DDGLCID(id,"ITEM",1..nl) = text of item n in display ; .DDGLCID(id,"GL") = DDGLGLO ; .DDGLCID(id,"KMAP","IN") ; .DDGLCID(id,"KMAP","OUT") ; .DDGLCID(id,"KMAP","KD") ; .DDGLCID(id,"KMAP","TO") ; Q:$G(DDGLGLO)="" N DDGLNL,DDGLNC,DDGLLINE,DDGLLAST,DDGLITEM D INIT D SETCID Q ; DESTROY(DDGLCID,DDGLFLG) ;Destroy the window and cleanup D DESTROY^DDGLIBW(DDGLCID) K DDGLCID(DDGLCID) D KILL^DDGLIB0($G(DDGLFLG)) Q ; READ(DDGLCID,DDGLOUT) ; N DDGLGLO,DDGLROW,DDGLCOL,DDGLNL,DDGLNC,DDGLLINE,DDGLSEL,DDGLITEM N DX,DY ; D SETPARM X DDGLZOSF("EOFF") W $P(DDGLVID,DDGLDEL,11) ; D ^DDGLBXA1 ; D SETCID W $P(DDGLVID,DDGLDEL,12) X DDGLZOSF("EON") Q ; UPDATE(DDGLCID,DDGLVAL) ; N DDGLGLO,DDGLROW,DDGLCOL,DDGLNL,DDGLNC,DDGLLINE,DDGLSEL,DDGLITEM N DDGLI,DDGLT,DX,DY ; D SETPARM ; ;Get closest match incl. or foll. DDGLVAL S DDGLSEL=$G(DDGLVAL) I $G(DDGLSEL)="" S DDGLSEL=$O(@DDGLGLO@("")) E I '$D(@DDGLGLO@(DDGLSEL)) S DDGLSEL=$O(@DDGLGLO@(DDGLSEL)) Q:DDGLSEL="" ; ;Check whether DDGLVAL is already on the screen I DDGLITEM(1)']]DDGLSEL,DDGLSEL']]DDGLITEM(DDGLNL) D . D CUP(DDGLLINE,1) . W $E(DDGLITEM(DDGLLINE),1,DDGLNC) . F DDGLLINE=1:1:DDGLNL Q:DDGLITEM(DDGLLINE)=DDGLSEL . D CUP(DDGLLINE,1) . W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10) ; ;If not, adjust the array E D . S DDGLT=DDGLSEL . F DDGLI=1:1:DDGLNL D .. S DDGLITEM(DDGLI)=DDGLT .. S:DDGLT]"" DDGLT=$O(@DDGLGLO@(DDGLT)) . D DISP(DDGLSEL) ; D SETCID Q ; SETCID ;Set DDGLCID array K DDGLCID(DDGLCID) S DDGLCID(DDGLCID,"SV")=DDGLCID_U_DDGLROW_U_DDGLCOL_U_DDGLNL_U_DDGLNC_U_DDGLLINE M DDGLCID(DDGLCID,"ITEM")=DDGLITEM S DDGLCID(DDGLCID,"GL")=DDGLGLO M DDGLCID(DDGLCID,"KMAP")=DDGLKEY("KMAP") Q ; SETPARM ;Set parameters from DDGLCID array N DDGLI S DDGLGLO=DDGLCID(DDGLCID,"GL") ; K DDGLKEY("KMAP") M DDGLKEY("KMAP")=DDGLCID(DDGLCID,"KMAP") M DDGLITEM=DDGLCID(DDGLCID,"ITEM") ; S DDGLI=DDGLCID(DDGLCID,"SV") S DDGLROW=$P(DDGLI,U,2) S DDGLCOL=$P(DDGLI,U,3) S DDGLNL=$P(DDGLI,U,4) S DDGLNC=$P(DDGLI,U,5) S DDGLLINE=$P(DDGLI,U,6) S DDGLSEL=DDGLITEM(DDGLLINE) K DDGLCID(DDGLCID) Q ; INIT ;Create list box (window) and setup variables ;In: DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLSEL,DDGLGLO,DDGLMAP ;Returns: DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLIND ; DDGLCID,DDGLNL,DDGLNC,DDGLLINE,DDGLITEM,DDGLKEY("KMAP") ; N DDGLAREA,DDGLI,DDGLT D INIT^DDGLIB0() ; ;Check and default DDGLROW,DDGLCOL,DDGLHT,DDGLWD,DDGLIND I $G(DDGLROW,-1)<0 S DDGLROW=5 E I DDGLROW+3>IOSL S DDGLROW=IOSL-3 I $G(DDGLCOL,-1)<0 S DDGLCOL=5 E I DDGLCOL+5>IOM S DDGLCOL=IOM-5 ; S DDGLHT=$S($D(DDGLHT)[0:7,DDGLHT<3:3,1:DDGLHT) S:DDGLROW+DDGLHT+1>IOSL DDGLHT=IOSL-DDGLROW ; S DDGLWD=$S($D(DDGLWD)[0:14,DDGLWD<5:5,1:DDGLWD) S:DDGLCOL+DDGLWD+1>IOM DDGLWD=IOM-DDGLCOL ; I $G(DDGLSEL)="" S DDGLSEL=$O(@DDGLGLO@("")) E I '$D(@DDGLGLO@(DDGLSEL)) S DDGLSEL=$O(@DDGLGLO@(DDGLSEL)) ; ;Initialize variables F DDGLI=1:1 Q:'$$EXIST^DDGLIBW("LBOX"_DDGLI) S DDGLCID="LBOX"_DDGLI S DDGLAREA=DDGLROW_U_DDGLCOL_U_DDGLHT_U_DDGLWD S DDGLNL=DDGLHT-2 S DDGLNC=DDGLWD-4 S DDGLLINE=1 ; ;Fill DDGLITEM array S DDGLT=DDGLSEL F DDGLI=1:1:DDGLNL D . S DDGLITEM(DDGLI)=DDGLT . S:DDGLT]"" DDGLT=$O(@DDGLGLO@(DDGLT)) ; ;Get key sequences, create window, display list D GETKEY D CREATE^DDGLIBW(DDGLCID,DDGLAREA,1) D DISP(DDGLSEL) Q ; DISP(DDGLSEL) ;Display the list ;In: DDGLSEL = text of selected item ; N DDGLI,DDGLT F DDGLI=1:1:DDGLNL D . D CUP(DDGLI,1) . S DDGLT=$E(DDGLITEM(DDGLI),1,DDGLNC) . S DDGLT=$S(DDGLT=DDGLSEL:$P(DDGLVID,DDGLDEL,6)_DDGLT_$P(DDGLVID,DDGLDEL,10),1:DDGLT)_$J("",DDGLNC-$L(DDGLT)) . W DDGLT Q ; CUP(Y,X) ;Position cursor relative to list coordinates S DY=DDGLROW+Y,DX=DDGLCOL+X+1 X IOXY Q ; GETKEY ;Get key sequences and defaults N AU,AD,AR,AL,F1,F2,F3,F4 N FIND,SELECT,INSERT,REMOVE,PREVSC,NEXTSC N I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S FIND=$P(DDGLKEY,U,10) S SELECT=$P(DDGLKEY,U,11) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) ; S DDGLKEY("KMAP","IN")="",DDGLKEY("KMAP","OUT")="" ; I $D(DDGLMAP)>9 S I=0 F S I=$O(DDGLMAP(I)) Q:'I D . I $P(DDGLMAP(I),";",2)="KEYDOWN" S DDGLKEY("KMAP","KD")=$P(DDGLMAP(I),";") Q . I $P(DDGLMAP(I),";",2)="TIMEOUT" S DDGLKEY("KMAP","TO")=$P(DDGLMAP(I),";") Q . ; . S @("K="_$P(DDGLMAP(I),";",2)) . I DDGLKEY("KMAP","IN")'[(U_K),K]"" D .. S DDGLKEY("KMAP","IN")=DDGLKEY("KMAP","IN")_U_K .. S DDGLKEY("KMAP","OUT")=DDGLKEY("KMAP","OUT")_$P(DDGLMAP(I),";")_";" ; F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T="" D . S @("K="_$P(T,";",2)) . I DDGLKEY("KMAP","IN")'[(U_K),K]"" D .. S DDGLKEY("KMAP","IN")=DDGLKEY("KMAP","IN")_U_K .. S DDGLKEY("KMAP","OUT")=DDGLKEY("KMAP","OUT")_$P(T,";")_";" S DDGLKEY("KMAP","IN")=DDGLKEY("KMAP","IN")_U S DDGLKEY("KMAP","OUT")=$E(DDGLKEY("KMAP","OUT"),1,$L(DDGLKEY("KMAP","OUT"))-1) Q ; MAP ;Keys for main screen ;;UP;AU ;;UP;AL ;;DN;AD ;;DN;AR ;;PUP;F1_AU ;;PUP;PREVSC ;;PDN;F1_AD ;;PDN;NEXTSC ;;TOP;F1_"T" ;;TOP;F1_F1_AU ;;TOP;FIND ;;BOT;F1_"B" ;;BOT;F1_F1_AD ;;BOT;SELECT ;;SEL;$C(13) ;;SEL;F1_"E" ;;QT;$C(27)_$C(27) ;;QT;F1_"Q" ;;QT;F1_"C" ;; DDGLBXA1 DDGLBXA1 ;SFISC/MKO-SINGLE SELECTION LIST BOX ;11:33 AM 26 Apr 1996 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N DDGLQT,Y D CUP(DDGLLINE,1) ; S DDGLQT=0 F S Y=$$READ D Q:DDGLQT . I Y'[U,$T(@Y)="" W $C(7) Q . D @Y . D:$G(DDGLKEY("KMAP","KD"))]"" @DDGLKEY("KMAP","KD") ; S:$P(DDGLQT,U,2,999)]"" DDGLOUT("C")=$P(DDGLQT,U,2,999) Q ; UP ;Move up I DDGLLINE>1 D . D CUP(DDGLLINE,1) . W $E(DDGLSEL,1,DDGLNC) . S DDGLLINE=DDGLLINE-1 . S DDGLSEL=DDGLITEM(DDGLLINE) . ; . D CUP(DDGLLINE,1) . W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10) ; E D . N DDGLE . D SHIFTDN(1,.DDGLE) Q:$G(DDGLE) . S DDGLSEL=DDGLITEM(1) . D DISP(DDGLSEL) Q ; DN ;Move down I DDGLLINE1 D . D CUP(DDGLLINE,1) . W $E(DDGLSEL,1,DDGLNC) . S DDGLLINE=1,DDGLSEL=DDGLITEM(1) . D CUP(1,1) . W $P(DDGLVID,DDGLDEL,6)_$E(DDGLSEL,1,DDGLNC)_$P(DDGLVID,DDGLDEL,10) ; E D . N DDGLE . D SHIFTDN(DDGLNL,.DDGLE) Q:$G(DDGLE) . S DDGLSEL=DDGLITEM(1) . D DISP(DDGLSEL) Q ; PDN ;Page down in list I DDGLLINE1 PUP Q ; ;Fill DDGLITEM array S DDGLT=DDGLFRST F DDGLI=1:1:DDGLNL D . S DDGLITEM(DDGLI)=DDGLT . S:DDGLT]"" DDGLT=$O(@DDGLGLO@(DDGLT)) ; S DDGLLINE=1,DDGLSEL=DDGLITEM(1) D DISP(DDGLSEL) Q ; BOT ;Move to bottom of list N DDGLAST,DDGLI,DDGLT,DDGLIND ; ;Set DDGLIND = index of last non-null DDGLITEM F DDGLIND=DDGLNL:-1:1 Q:DDGLITEM(DDGLIND)]"" ; S DDGLAST=$O(@DDGLGLO@(""),-1) I DDGLAST=DDGLITEM(DDGLIND) D:DDGLLINEIOSL S DDGLROW=IOSL-4 I $G(DDGLCOL,-1)<0 S DDGLCOL=5 E I DDGLCOL+6>IOM S DDGLCOL=IOM-6 ; ;Check DDGLHT and DDGLWD S DDGLHT=$S($D(DDGLHT)[0:7,DDGLHT<3:3,1:DDGLHT) S:DDGLROW+DDGLHT+2>IOSL DDGLHT=IOSL-DDGLROW ; S DDGLWD=$S($D(DDGLWD)[0:14,DDGLWD<5:5,1:DDGLWD) S:DDGLCOL+DDGLWD+2>IOM DDGLWD=IOM-DDGLCOL ; S DDGLMAP(1)="LTAB^DDGLCBOX;$C(9)" S DDGLMAP(2)="LKDN^DDGLCBOX;KEYDOWN" ; D CREATE^DDGLBXA(DDGLGLO,.DDGLCBOX,DDGLROW+1,DDGLCOL+1,DDGLHT,DDGLWD,$G(DDGLSEL),.DDGLMAP) Q ; DDGLIB0 DDGLIB0 ;SFISC/MKO-SETUP AND CLEANUP FOR WINDOWS ; 06 MAR 2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. INIT() ;Setup required variables ;Set margin to 0 ;Turn autowrap off ;Turn type-ahead on ;Variables set: ; DDGLDEL = delimiter for other DDGL variables ; DDGLVID = codes that turn on/off video attributes ; DDGLED = codes for editing ; DDGLCLR = codes to erase characters ; DDGLGRA = codes for graphics characters ; DDGLZOSF = array of code from %ZOSF (as of V22.2 - array comes from OS file) ; DDGLREF = global where window image is stored ; DDGLKEY = codes for non-alphanumeric keys ; DDGLSCR = array containing list of visible windows on screen ; N X I $D(DDGLDEL)[0 D SET Q:$G(DIERR) S X=0 X DDGLZOSF("RM"),DDGLZOSF("TYPE-AHEAD") W $P(DDGLVID,DDGLDEL,8) Q ; SET ;Setup screen handling variables K DIERR,DDGLSCR S U="^",DDGLDEL=$C(127) ; ; VEN/SMH - remove reliance on %ZOSF node -- next 3 lines changed v 22.2 D:'$D(DISYS) OS^DII ; garb OS from %ZOSF or Fileman in this sequence F X="EOFF","EON","TRMOFF","TRMON","TRMRD","RM","TYPE-AHEAD","NO-TYPE-AHEAD" D G:$G(DIERR) ABT . S DDGLZOSF(X)=$G(^DD("OS",DISYS,X)) ; ZIS N %ZIS,IOP S IOP="HOME" D ^%ZIS I POP D BLD^DIALOG(845) G ABT I $D(^%ZIS(2)),'$O(^%ZIS(2,+$G(IOST(0)),0)) D BLD^DIALOG(840,"#"_+$G(IOST(0))) G ABT ; D:$G(IOXY)="" TRMERR("Cursor positioning (XY CRT)") ; S X="IORVON;IORVOFF;IOELEOL;IOEDEOP;IOUON;IOUOFF;IOSGR0;IOINHI;IOINLOW;IOINORM;IOCUU;IOCUD;IOCUF;IOCUB;IODL;IOIL;IODCH;IOICH;IOEDALL;IOELALL;IORI;IOAWM1;IOAWM0;IOSTBM;IOPF1;IOPF2;IOPF3;IOPF4;IOFIND;IOSELECT;IOINSERT;IOREMOVE;IOPREVSC;IONEXTSC" N @$TR(X,";",",") N IOBLC,IOBRC,IOBT,IOG1,IOG0,IOHL,IOLT,IOMT,IORT,IOTLC,IOTRC,IOTT,IOVL D ENDR^%ZISS,GSET^%ZISS I $G(IOPREVSC)="" D ;"^C-VT220^C-VT320^"[(U_IOST_U) D IOST MIGHT BE VT-100 . S IOPREVSC=$C(27)_"[5~" . S IONEXTSC=$C(27)_"[6~" ; ATT ;tried: S IOINLOW=X_"32m" ;LOW = GREEN N A,B S A(1)=$C(27,91)_"40m",A(2)=$C(27,91)_"41m",A(3)=$C(27,91)_"45m" ;Defaults I $G(^XTV(8989.5,0))?1"PARAM".E F X=1,2,3 S A=$$GET^XPAR("ALL","DI SCREENMAN COLORS",X),B=$$GET^XPAR("ALL","DI SCREENMAN COLORS",X+3) S:B]"" A(X)=$C(27,91)_(10+B)_"m" S:A]"" A(X)=A(X)_$C(27,91)_+A_"m" S IOUON=IOINHI_A(1) ;REQ CAPTION BACKGROUND (BLACK) S IOINHI=IOINHI_A(2) ;DATA BACKGROUND (RED) S IORVON=IOINHI_A(3) ;CLICKABLE BACKGROUND (MAGENTA) S (IORVOFF,IOUOFF)=IOINORM S DDGLVID=IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINORM_DDGLDEL_IOUON_DDGLDEL_IOUOFF_DDGLDEL_IORVON_DDGLDEL_IORVOFF_DDGLDEL_IOAWM0_DDGLDEL_IOAWM1_DDGLDEL_$G(IOSGR0) S DDGLED=$G(IORI)_DDGLDEL_$G(IOSTBM)_DDGLDEL_$G(IOIL)_DDGLDEL_$G(IODL)_DDGLDEL_$G(IOICH)_DDGLDEL_$G(IODCH) S DDGLCLR=IOELEOL_DDGLDEL_IOEDALL_DDGLDEL_IOEDEOP_DDGLDEL_$G(IOELALL) S DDGLKEY=U_IOCUU_U_IOCUD_U_IOCUF_U_IOCUB_U_IOPF1_U_IOPF2_U_IOPF3_U_IOPF4_U_$G(IOFIND)_U_$G(IOSELECT)_U_$G(IOINSERT)_U_$G(IOREMOVE)_U_$G(IOPREVSC)_U_$G(IONEXTSC)_U S DDGLGRA=IOG1_DDGLDEL_IOG0_DDGLDEL_IOHL_DDGLDEL_IOVL_DDGLDEL_IOTLC_DDGLDEL_IOTRC_DDGLDEL_IOBLC_DDGLDEL_IOBRC S:DDGLDEL_$P(DDGLGRA,DDGLDEL,3,999)_DDGLDEL[(DDGLDEL_DDGLDEL) DDGLGRA=DDGLDEL_DDGLDEL_"-"_DDGLDEL_"|"_DDGLDEL_"+"_DDGLDEL_"+"_DDGLDEL_"+"_DDGLDEL_"+" ; D:$P(DDGLKEY,U,1,5)_U[(U_U) TRMERR("Cursor keys") D:U_$P(DDGLKEY,U,6,9)_U[(U_U) TRMERR("PF keys") D:IOELEOL="" TRMERR("Erase to End of Line") D:IOEDALL="" TRMERR("Erase Entire Page") D:IOEDEOP="" TRMERR("Erase to End of Page") G:$G(DIERR) ABT ; S DDGLREF="^TMP(""DDGL"",$J,""W"")" K @DDGLREF ; I "^C-QUME^C-QVT102^C-WYSE75^"[(U_$TR(IOST," ","")_U) D . S DDGLVAN=1 . S $P(DDGLVID,DDGLDEL,4,7)=$S($TR(IOST," ","")="C-WYSE75":IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINHI_DDGLDEL_IOINLOW,1:IOINLOW_DDGLDEL_IOINHI_DDGLDEL_IOINLOW_DDGLDEL_IOINHI) . S $P(DDGLVID,DDGLDEL,10)=IOINORM ; D:'$D(^%ZTSK)!($D(^%ZOSF("MGR"))[0) KILL^%ZISS MOUSEON ;I $G(DDS)>0 W *27,"[?1000h" NOW DONE IN DDS0 Q ; ; ASKIOSL ; not used ;N X ;X ^%ZOSF("EOFF") R X:0 S XX="" W $C(27)_7_$C(27)_"[r"_$C(27)_"[999;999H"_$C(27)_"[6n" R X ; R *X:1 R:$T XX S X=$C(X)_XX ;S X=+$E(X,3,5) I X S IOSL=X Q ; ; ; TRMERR(DDGLCH) ;Terminal type errors N P S P(1)=DDGLCH,P(2)=IOST D BLD^DIALOG(842,.P) Q ; ; ; KILL(DDGLPARM) ;Cleanup variables ;Set margin to IOM ;Turn off type-ahead if New Person file so indicates ;Turn autowrap on ;Reset character attributes ;Turn echo on ;Turn terminators off N X D:'$D(DISYS) OS^DII ; garb OS from %ZOSF or Fileman in this sequence I $G(DDGLPARM)'["W" D . S X=$S($D(IOM)#2:IOM,1:80) X $G(DDGLZOSF("RM")) . I $D(DUZ)#2,$D(^VA(200,DUZ,0))#2,$P($G(^(200)),U,9)'="Y" D .. I '$G(DUZ("BUF"),1) X $G(DDGLZOSF("NO-TYPE-AHEAD")) . W $P($G(DDGLVID),$G(DDGLDEL),9),$P($G(DDGLVID),$G(DDGLDEL),10) ; I $G(DDGLPARM)'["T" D . X $G(DDGLZOSF("EON")),$G(DDGLZOSF("TRMOFF")) E X $G(DDGLZOSF("EOFF")),$G(DDGLZOSF("TRMON")) ; MOUSEOFF ;W *27,"[?1000l" NOW DONE IN DDS0 ABT K DX,DY,POP I '$G(DIERR),$G(DDGLPARM)["K" Q K:$G(DDGLREF)]"" @DDGLREF D:'$D(^%ZTSK)!($D(^%ZOSF("MGR"))[0) KILL^%ZISS ; K DDGLDEL,DDGLVID,DDGLED,DDGLCLR,DDGLGRA,DDGLZOSF,DDGLREF K DDGLKEY,DDGLSCR,DDGLVAN,DDGLH ; K DIR0 DDGLIBH DDGLIBH ;SFISC/MKO-SCREEN EDITOR HELP ; 15NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; HLP(DDGLHN1,DDGLHN2,DDGLSUB,DDGLPLN) ; ;DDGLHN1 = Entry number in Dialog file of first help screen ;DDGLHN2 = Entry number of last help screen ;DDGLSUB = Subscript in ^TMP to copy help to ;DDGLPLN = $Y to print prompt ; N DX,DY,DDGLI,DDGLJ,DDGLSC,DDGLTX,DDGLX,DIHELP,DDGL0 S DDGL0=$C(31) D:'$D(DDGLH) GETKEY I $D(IOTM)[0 N IOTM S IOTM=1 I $D(IOBM)[0 N IOBM S IOBM=IOSL I '$G(DDGLPLN) S DDGLPLN=IOBM-1 S DDGLSC=DDGLHN1 ; D DISP(DDGLHN1) ; F S DDGLX=$$READ D @DDGLX Q:DDGLX=U Q ; UP I DDGLSC>DDGLHN1 S DDGLSC=DDGLSC-1 D DISP(DDGLSC) Q ; DN I DDGLSC1:$C(13,10),1:"")_DDGLTX_$P(DDGLCLR,DDGLDEL) ; F DDGLI=DDGLI:1:IOBM-IOTM+1 W $C(13,10)_$P(DDGLCLR,DDGLDEL) Q ; READ() ; S DY=DDGLPLN,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_"Press " W:DDGLSC>DDGLHN1 $P(DDGLVID,DDGLDEL)_""_$P(DDGLVID,DDGLDEL,10)_" for previous page, " W:DDGLSC"_$P(DDGLVID,DDGLDEL,10)_" for next page, " W $P(DDGLVID,DDGLDEL)_"P"_$P(DDGLVID,DDGLDEL,10)_" to print, " W $P(DDGLVID,DDGLDEL)_"^"_$P(DDGLVID,DDGLDEL,10)_" to exit: " D GETCH(DTIME,.DDGLX) S DY=DDGLPLN,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL) Q DDGLX ; GETCH(DTIME,Y) ;Out: Y = Mnemonic F D Q:Y'=-1 . R *Y:DTIME . I Y<0 S Y="TO" Q . D MNE(.Y) Q ; MNE(Y) ;Out: Y = Mnemonic, or -1 if invalid N S,F S S="",F=0 F D MNELOOP Q:F Q ; MNELOOP ;Read more S S=S_$C(Y) I DDGLH("IN")'[(DDGL0_S) D I Y=-1 D FLUSH Q . I $C(Y)'?1L S Y=-1 Q . S S=$E(S,1,$L(S)-1)_$C(Y-32) . S:DDGLH("IN")'[(DDGL0_S_DDGL0) Y=-1 ; I DDGLH("IN")[(DDGL0_S_DDGL0),S'=$C(27) D Q . S Y=$P(DDGLH("OUT"),DDGL0,$L($P(DDGLH("IN"),DDGL0_S_DDGL0),DDGL0)),F=1 ; R *Y:5 D:Y=-1 FLUSH Q ; FLUSH ; N DDGLZ S F=1 W $C(7) F R *DDGLZ:0 E Q Q ; GETKEY ;Get key sequences and defaults N AU,AD,F1,PREVSC,NEXTSC N I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S F1=$P(DDGLKEY,U,6) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) ; K DDGLH S DDGLH("IN")="",DDGLH("OUT")="" F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T="" D . S @("K="_$P(T,";",2)) . I DDGLH("IN")'[(DDGL0_K),K]"" D .. S DDGLH("IN")=DDGLH("IN")_DDGL0_K .. S DDGLH("OUT")=DDGLH("OUT")_$P(T,";")_DDGL0 S DDGLH("IN")=DDGLH("IN")_DDGL0 S DDGLH("OUT")=$E(DDGLH("OUT"),1,$L(DDGLH("OUT"))-1) Q ; MAP ;Keys ;;DN;$C(13) ;;DN;AD ;;DN;F1_AD ;;DN;NEXTSC ;;UP;AU ;;UP;F1_AU ;;UP;PREVSC ;;QT;F1_"E" ;;QT;F1_"Q" ;;QT;"^" ;;PT;"P" DDGLIBP DDGLIBP ;SFISC/MKO-PRINT FROM WITHIN SCREEN TOOLS ;2013-03-04 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 19 ;Per VHA Directive 2004-038, this routine should not be modified. ; PT(DDGLROOT,DDGLHDR) ;Prompt for device and print N POP,DDGLBAR,DDGLFLAG,DDGLHELP,DDGLI,DDGLPHDR,DDGLREF,DDGLWRAP,DX,DY,DIR0,DDS N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%K,%M,%N N %P,%S,%T,%W,%X,%Y N %A0,%D1,%D2,%DT,%J1,%W0 ; S DDGLFLAG="" ; ;Set terminal characterstics for scroll mode X DDGLZOSF("EON"),DDGLZOSF("TRMOFF") S X=$G(IOM,80) X DDGLZOSF("RM") W $P(DDGLVID,DDGLDEL,9) ; W:$G(DDGLHDR)]"" "Document: "_DDGLHDR,! ; ;Prompt whether to print a header S DDGLHELP(1)=" Answer 'Y' to print a document title, date/time, and page number" S DDGLHELP=" at the top of each page." S DDGLPHDR=$$YNREAD("Print a header on each page","N",.DDGLHELP) K DDGLHELP I DDGLPHDR=-1 D FINISH("Report canceled.") Q S:DDGLPHDR DDGLFLAG=DDGLFLAG_"H" ; ;Prompt whether to wrap text S DDGLHELP(1)=" Answer 'Y' to wrap the text at word boundaries to fit within the margins" S DDGLHELP(2)=" of the device." S DDGLHELP=" Answer 'N' to print the text as-is (no-wrap)." S DDGLWRAP=$$YNREAD("Wrap text","N",.DDGLHELP) K DDGLHELP I DDGLWRAP=-1 D FINISH("Report canceled.") Q ; ;Prompt whether to interpret word processing (|) windows" S DDGLHELP(1)=" Answer 'Y' to have text enclosed within vertical bars (|) interpreted as" S DDGLHELP(2)=" word processing windows." S DDGLHELP=" Answer 'N' to have vertical bars printed as-is." S DDGLBAR=$$YNREAD("Interpret word processing windows (|)","N",.DDGLHELP) K DDGLHELP I DDGLBAR=-1 D FINISH("Report canceled.") Q ; ;Set flag for wrap and wp windows S DDGLFLAG=DDGLFLAG_$S(DDGLWRAP&'DDGLBAR:"|",'DDGLWRAP&DDGLBAR:"N",'DDGLWRAP&'DDGLBAR:"X",1:"") ; DEVICE ;Device prompt N IOF,IOSL S IOF="#",IOSL=IOBM-IOTM+1 ;In case help frames are invoked S %ZIS=$S($D(^%ZTSK):"Q",1:""),%ZIS("B")="" S %ZIS("S")="I $TR($P(^(0),U),""browse"",""BROWSE"")'[""BROWSE""" D ^%ZIS K %ZIS ; I POP D FINISH("Report canceled!") Q ; ;Get the closed root of the array containing the text, resolve values like $J S DDGLREF=$NA(@$$CREF^DILF($G(DDGLROOT))) ; ;If CRT selected, reset scrolling region to entire screen I $E(IOST,1,2)="C-" D . I $D(IOSTBM)#2 N IOTM,IOBM S IOTM=0,IOBM=$G(IOSL,24) W @IOSTBM . W @IOF ; ;Queue report I $D(IO("Q")),$D(^%ZTSK) D Q . N I,ZTRTN,ZTDESC,ZTSAVE,ZTSK,DDGLMSG . S ZTRTN="PRINT^DDGLIBP" . S ZTDESC=DDGLHDR . F I="DDGLREF","DDGLHDR","DDGLFLAG" S ZTSAVE(I)="" . I DDGLREF]"" S ZTSAVE($$OREF^DILF(DDGLREF))="" . D ^%ZTLOAD . I $D(ZTSK)#2 D .. W !,"Report queued!",!,"Task number: "_ZTSK,! .. D EOPREAD . E S DDGLMSG="Report canceled!" . S IOP="HOME" D ^%ZIS . D FINISH($G(DDGLMSG)) ; ;Non-queued report D PRINT I $E(IOST,1,2)="C-" W @IOF W:$D(IOSTBM)#2 @IOSTBM ; Reset bottom margin X $G(^%ZIS("C")) D FINISH("Done.") Q ; PRINT ;Print the document in DDGLREF, Header text in DDGLHDR N DDGLDT,DDGLI,DDGLPAGE,DDGLZN I $G(DDGLREF)="" D PRINTQ Q I '$D(@DDGLREF) D PRINTQ Q ; S DDGLZN=$D(@DDGLREF@($O(@DDGLREF@(0)),0))#2 S DDGLFLAG=$G(DDGLFLAG) ; ;Format the text, if DDGLFLAG doesn't contain X I DDGLFLAG'["X" D . D FORMAT(DDGLREF,DDGLZN,DDGLFLAG) . S DDGLZN=1 . S DDGLREF=$NA(^UTILITY($J,"W",1)) ; ;Write the report from the original location or from ^UTILITY U IO I DDGLFLAG["H" D . ;Get current date/time and write first header . N %,%H,X,Y . S %H=$H D YX^%DTC . S DDGLDT=$E(Y,1,18) . D HDR ; ;Print each line S DDGLI=0 F S DDGLI=$O(@DDGLREF@(DDGLI)) Q:'DDGLI D . I DDGLFLAG["H",$Y+6>IOSL W @IOF D HDR . W !,$S(DDGLZN:$G(@DDGLREF@(DDGLI,0)),1:$G(@DDGLREF@(DDGLI))) ; K:$G(DDGLFLAG)'["N" ^UTILITY($J,"W") D PRINTQ Q ; PRINTQ ;Delete the queued task and quit S:$D(ZTQUEUED) ZTREQ="@" Q ; HDR ;Print the header DDGLHDR; increment DDGLPAGE N DDGLCOL,DDGLPSTR S DDGLPAGE=$G(DDGLPAGE)+1 S DDGLPSTR=DDGLDT_" Page: "_DDGLPAGE S DDGLCOL=IOM-$L(DDGLPSTR)-1 W DDGLHDR W:$X+2'1:L_$P(DDGLGRA,DDGLDEL,6),1:""),Y,X,"G",N) F R=Y+1:1:Y+H-2 D . D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X,"G",N) . I W>1 D .. I $G(C) D WRITE(I,S,R,X+1,"",N) .. D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X+W-1,"G",N) D:H>1 WRITE(I,$P(DDGLGRA,DDGLDEL,7)_$S(W>1:L_$P(DDGLGRA,DDGLDEL,8),1:""),Y+H-1,X,"G",N) Q ; ABSAREA(I,A) ; ;Given relative area A in window I, return absolute area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y+$P(A,U),X1=X+$P(A,U,2) S:Y1+H>IOSL H=IOSL-Y1 S:X1+W>IOM W=IOM-X1 Q Y1_U_X1_U_H_U_W ; RELAREA(I,A) ; ;Given absolute area A in window I, return relative area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y-$P(A,U),X1=X-$P(A,U,2) Q Y1_U_X1_U_H_U_W ; AREA(I) ;Return the coord and area of window I Q $S($D(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM) ; CODE(A,A1,A0) ; ;Return code char for selected attr N I,C,T S C=0,(A1,A0)="" S T=$TR(A,"burg","BURG") F I=1:1:$L(A) D . S T=$T(@$E(A,I)) . I T]"" D .. S C=C+$P(T,";",3) .. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5)) .. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6)) Q $C(C+32) ; DECODE(C,A1,A0) ; ;Given code char C, return codes to turn on/off attr N B,T S (A1,A0)="" Q:" "[$G(C) S C=$A(C)-32 S B=1 F D Q:B>8 . I C\B#2,$T(@B)]"" D .. S T=$T(@B+1) .. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5)) .. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6)) . S B=B*2 Q ; 1 ;; B ;;1;DDGLVID;1;2 2 ;; U ;;2;DDGLVID;4;5 4 ;; R ;;4;DDGLVID;6;7 8 ;; G ;;8;DDGLGRA;1;2 DDGLIBW1 DDGLIBW1 ;SFISC/MKO-WINDOWING PRIMITIVES ;02:23 PM 13 Jul 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CREATE(I,A,B,N) ; CREATE1 ;Create window I of area A and draw border (if B) ;N = nn; first n=1 means don't give the window focus ; second n=1 means don't write to screen ; S:$G(I)="" I=-1 S:$G(A)="" A="0^0^"_IOSL_U_IOM K @DDGLREF@(I) S @DDGLREF@(I)=A D:$G(B) BOX^DDGLIBW(I,"0^0^"_$P(A,U,3,4),1,$G(N)) D:$G(N)<9 FOCUS(I,$G(N)!$G(B)) Q ; OPEN(I,N) ; OPEN1 ;Open window I G FOCUS1 ; FOCUS(I,N) ; FOCUS1 ;Give focus to window I ;If N=1; don't paint window Q:$D(@DDGLREF@(I))[0 Q:$G(DDGLSCR(+$G(DDGLSCR)))=I ; I '$D(DDGLSCR("B",I)) D . S DDGLSCR=$G(DDGLSCR)+1,DDGLSCR(DDGLSCR)=I,DDGLSCR("B",I,DDGLSCR)="" E D . N M,N . S DDGLSCR(DDGLSCR+1)=I . S M=$O(DDGLSCR("B",I,"")) . F N=M:1:DDGLSCR D .. K DDGLSCR("B",DDGLSCR(N),N) .. S DDGLSCR(N)=DDGLSCR(N+1) .. S DDGLSCR("B",DDGLSCR(N),N)="" . K DDGLSCR(DDGLSCR+1) D:'$G(N) REPAINT^DDGLIBW(I) Q ; CLOSE(I,NC) ; CLOSE1 ;Close window I N A,M,N,W S M=$O(DDGLSCR("B",I,"")) Q:M="" ; I '$G(NC) D . S A=$$AREA(I) . D CLEAR(I,"0^0^"_$P(A,U,3,4)) . F N=1:1:DDGLSCR D:N'=M .. S W=DDGLSCR(N) .. D REPAINT^DDGLIBW(W,$$RELAREA(W,$$INTSECT($$AREA(W),A))) ; F N=M:1:DDGLSCR-1 D . K DDGLSCR("B",DDGLSCR(N),N) . S DDGLSCR(N)=DDGLSCR(N+1) . S DDGLSCR("B",DDGLSCR(N),N)="" K DDGLSCR("B",DDGLSCR(DDGLSCR),DDGLSCR),DDGLSCR(DDGLSCR) S DDGLSCR=DDGLSCR-1 Q ; CLEAR(I,A) ; CLEAR1 ;Clear area A in window I N Y,X,H,W,S,DY,DX S:$G(I)="" I=-1 S:$G(A)="" A=$$AREA(I) S A=$$ABSAREA(I,A) S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) I Y=0,X=0,H=IOSL,W=IOM W $P(DDGLCLR,DDGLDEL,2) Q S DX=X,S=$S(IOM-X=W:$P(DDGLCLR,DDGLDEL),1:$J("",W)) F DY=Y:1:Y+H-1 X IOXY W S Q ; ABSAREA(I,A) ; ;Given relative area A in window I, return absolute area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y+$P(A,U),X1=X+$P(A,U,2) S:Y1+H>IOSL H=IOSL-Y1 S:X1+W>IOM W=IOM-X1 Q Y1_U_X1_U_H_U_W ; RELAREA(I,A) ; ;Given absolute area A in window I, return relative area N X,Y,H,W,X1,Y1 S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4) S A=$$AREA(I) S Y1=Y-$P(A,U),X1=X-$P(A,U,2) Q Y1_U_X1_U_H_U_W ; AREA(I) ;Return the coord and area of window I Q $S($D(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM) ; INTSECT(A1,A2) ; ;Return the intersection of areas 1 and 2 N A,X1,Y1,H1,W1,X2,Y2,H2,W2 S Y1=$P(A1,U),X1=$P(A1,U,2),H1=$P(A1,U,3),W1=$P(A1,U,4) S Y2=$P(A2,U),X2=$P(A2,U,2),H2=$P(A2,U,3),W2=$P(A2,U,4) S A="" S $P(A,U)=$$MAX(Y1,Y2),$P(A,U,2)=$$MAX(X1,X2) S $P(A,U,3)=$$LEN(Y1,H1,Y2,H2) S $P(A,U,4)=$$LEN(X1,W1,X2,W2) Q:'$P(A,U,3)!'$P(A,U,4) "" Q A ; MAX(X,Y) ; ;Return the max of X and Y Q $S(X>Y:X,1:Y) ; LEN(C1,L1,C2,L2) ; ;Return intersection length of two lines ; C = position along X or Y axis ; L = length of line Q:C1'>C2 $S(C1+L1'<(C2+L2):L2,C1+L1>C2:L1-C2+C1,1:0) Q $S(C2+L2'<(C1+L1):L1,C2+L2>C1:L2-C1+C2,1:0) DDIOL DDIOL ;SFISC/MKO-THE LOADER ;14JUN2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; EN(A,G,FMT) ;Write the text contained in local array A or global array G ;If one string passed, use format FMT N %,Y,DINAKED S DINAKED=$NA(^(0)) ; S:'$D(A) A="" I $G(A)="",$D(A)<9,$G(FMT)="",$G(G)'?1"^"1A.7AN,$G(G)'?1"^"1A.7AN1"(".E1")" Q ; G:$D(DDS) SM G:$D(DIQUIET) LD ; N F,I,S I $D(A)=1,$G(G)="" D . S F=$S($G(FMT)]"":FMT,1:"!") . W @F,A ; E I $D(A)>9 S I=0 F S I=$O(A(I)) Q:I'=+$P(I,"E") D . S F=$G(A(I,"F"),"!") S:F="" F="?0" . W @F,$G(A(I)) ; E S I=0 F S I=$O(@G@(I)) Q:I'=+$P(I,"E") D . S S=$G(@G@(I,0),$G(@G@(I))) . S F=$G(@G@(I,"F"),"!") S:F="" F="?0" . W @F,S ; I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED)) Q ; LD ;Load text into ^TMP N I,N,T S T=$S($G(DDIOLFLG)["H":"DIHELP",1:"DIMSG") S N=$O(^TMP(T,$J," "),-1) ; I $D(A)=1,$G(G)="" D . D LD1(A,$S($G(FMT)]"":FMT,1:"!")) ; E I $D(A)>9 S I=0 F S I=$O(A(I)) Q:I'=+$P(I,"E") D . D LD1($G(A(I)),$G(A(I,"F"),"!")) ; E S I=0 F S I=$O(@G@(I)) Q:I'=+$P(I,"E") D . D LD1($G(@G@(I),$G(@G@(I,0))),$G(@G@(I,"F"),"!")) ; K:'N @T S:N @T=N I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED)) Q ; LD1(S,F) ;Load string S, with format F ;In: N and T N C,J,L S:S[$C(7) S=$TR(S,$C(7),"") F J=1:1:$L(F,"!")-1 S N=N+1,^TMP(T,$J,N)="" S:'N N=1 S:F["?" @("C="_+$P(F,"?",2)) S L=$G(^TMP(T,$J,N)) S ^TMP(T,$J,N)=L_$J("",$G(C)-$L(L))_S Q ; SM ;Print text in ScreenMan's Command Area I $D(DDSID),$D(DTOUT)!$D(DUOUT) G SMQ N DDIOL S DDIOL=1 ; I $D(A)=1&($G(G)="")!($D(A)>9) D . D MSG^DDSMSG(.A,"",$G(FMT)) E I $D(@G@(+$O(@G@(0)),0))#2 D . D WP^DDSMSG(G) E D HLP^DDSMSG(G) ; SMQ I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED)) Q DDMAP DDMAP ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN POINTER RELATIONS ;7/1/93 4:14 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;EXPLANATIONS: ; N = normal reference ; S = pointer file not included in the set ; C = cross reference in the pointer file ; L = laygo allowed ; * = reference internally truncated ; m = Multiple field ; v = Variable Pointer ; ST S DDPCK=1 I DUZ(0)'="@",$S($D(^VA(200,DUZ,"FOF",9.4,0)):1,1:$D(^DIC(3,DUZ,"FOF",9.4,0))) G INFO:$P(^(0),U,2),EN1 I DUZ(0)'="@",$D(^DIC(9.4,0,"DD")) S DDPCK=0 F I=1:1:$L(^("DD")) I DUZ(0)[$E(^("DD"),I) S DDPCK=1 Q I 'DDPCK G EN1 INFO W !!,"Prints a graph of pointer relations in a database of FileMan files",!,"named in the Kernel PACKAGE file (9.4) or given separately.",!,"Works best with 132 column output!" DDPCK D DT^DICRW K ^UTILITY($J),DDTO,DDPCK,DUOUT,DTOUT S DDPCKN="" G GET:'$D(^DD(9.4)) S DIC=9.4,DIC(0)="AEQML" D ^DIC G END:X[U!$D(DTOUT),GET:Y<0 S DDPCK=+Y,DDPCKN=$P(Y,U,2) S DDFLE="" F I=1:1 S DDFLE=$O(^DIC(9.4,DDPCK,4,"B",DDFLE)) Q:DDFLE="" S ^UTILITY($J,"F",DDFLE)="" G GET:DDPCKN="" D LIST REM S DIC=1,DIC(0)="AEMQ",DIC("S")="I $D(^UTILITY($J,""F"",+Y)) Q",DIC("A")="Remove FILE: " D ^DIC G:X[U!$D(DTOUT) END G:Y<0 ADD K ^UTILITY($J,"F",+Y) G REM GET I DDPCKN="" W !!,"Enter files to be included" ADD K DIC I DUZ(0)'="@" S DIC("S")="I 1 Q:'$D(^(0,""DD"")) F DC=1:1:$L(^(""DD"")) I DUZ(0)[$E(^(""DD""),DC) Q" D ADD0 S DIC=1,DIC(0)="QEAM",DIC("A")="Add FILE: " D ^DIC G END:X[U!$D(DTOUT),ADD1:Y<0 S ^UTILITY($J,"F",+Y)="" G ADD ADD0 I $D(^VA(200,"AFOF")) S DIC("S")="I $D(^VA(200,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q" I $D(^DIC(3,"AFOF")) S DIC("S")="I $D(^DIC(3,DUZ,""FOF"",+Y,0)),$P(^(0),U,2) Q" Q ADD1 G END:'$D(^UTILITY($J)) D:DDPCKN="" LIST GO G END:'$D(^UTILITY($J)) W !,"Enter name of file group for optional graph header: " W:DDPCKN]"" DDPCKN,"// " R X:DTIME G:X[U!'$T END I X'[U,X]"",($L(X)<3!($L(X)>20)) W:X'["?" $C(7) G HLP1:X["?",HLP S:X="" X=DDPCKN S DDPCKN=X W ! EXIT S %ZIS="Q" D ^%ZIS G:POP EXIT1 S DDFLE=0 I $D(IO("Q")) S ZTRTN="NXF^DDMAP2" F I="^UTILITY($J,","DDFLE","DDPCKN" S ZTSAVE(I)="" I $D(IO("Q")) D ^%ZTLOAD G EXIT1 U IO G ^DDMAP2 EN1 W !," Access NOT Permitted for this Routine.",!,"(Must have DD Access to the PACKAGE File)" END K DIC,DDFLE,DDPCKN,DDPCK,^UTILITY($J) Q EXIT2 I $D(ZTSK) K ^%ZTSK(ZTSK),ZTSK G KILL EXIT1 I $D(DD9),IO=IO(0) R !,"Enter '^' to exit or return to continue: ",X:$S($D(DTIME):DTIME,1:300) I $T,X'=U D KILL W @IOF G ST KILL W:$Y @IOF X $G(^%ZIS("C")) K ^UTILITY($J),DDA1,DDA2,DDCR,DIC,DDFL,DDFLD,DDFLE,DDFNMAX,DDFRN,DDFPT,I,DDINC,DDLGO,DDLN,DDMAX,DDOUT,DD5,DD7,DD9,DDP,DDPCK,DDPCKN,DDPP K %H,%ZISI,%,DISYS,DDPT,DDPTF,DDTB1,DDTB2,DDTO,DDW,X,Y,%T,%XX,%YY,ZTSK,DDMIOSL,DDMAPC Q LIST W !!,"Files included" S DDFLE=0 F I=1:1 S DDFLE=$O(^UTILITY($J,"F",DDFLE)) Q:DDFLE'>0 W ?27,$J(DDFLE,10)," ",$O(^DD(DDFLE,0,"NM","")),! Q HLP1 W !,"Type a header that can be used for the print out" HLP W !,"The Header must be between 3 and 20 characters" G GO DDMAP1 DDMAP1 ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN PTRS ;22MAY2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; NXF S DDFLE=$O(^UTILITY($J,"FD",DDFLE)) G EXIT2^DDMAP:DDFLE'>0 S DDLN=1,DDOUT=0,DD9=0 I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT) D VIIVA^DDMAP2,TO S DDPCK=$$FILENAME^DIALOGZ(DDFLE) D FSHORT W ?DDTB1,"| ",DDFLE," ",DDPCK W ?DDTB2,"|",! S DDFL="" ;write File name and number in box I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT) NXFL S DDFL=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL)),DDFLD=0 I DDFL="" G END NXFLD S DDFLD=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL,DDFLD)),DDFPT=0,DD5=DDFL G:DDFLD'>0 NXFL S DDFRN=$$LABEL^DIALOGZ(DDFL,DDFLD) NXUP I $D(^DD(DD5,0,"UP")) S DD5=^("UP"),DD7=$$FILENAME^DIALOGZ(DD5) S:(DD5'=$P(DDFRN,":",1)) DDFRN=DD7_":"_DDFRN G NXUP NXPT S DDFPT=$O(^UTILITY($J,"FD",DDFLE,"FR",DDFL,DDFLD,DDFPT)) G NXFLD:DDFPT'>0 S DDA2=^(DDFPT) D TO REV S DDA1=$S($P(DDA2,U,2)["M":"m",1:""),DDA2=$S($P(DDA2,U,2)["V":"v",1:""),DDMAX=DDFNMAX,DDP=DDFRN D SHORT W ?DDTB1,"| " W:DDP]"" DDA2,DDA1,?DDTB1+4,DDP W ?DDTB2,"|" D OUT S DDFRN="" I $Y>DDMIOSL D HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT) G NXPT FSHORT I DDFNMAX-$L(DDFLE)-$L(DDPCK)<0 S DDPCK=$E(DDPCK,1,DDFNMAX-$L(DDFLE)-1)_"*" Q SHORT Q:$L(DDP)'>DDMAX S DDPP=$L(DDP,":"),DD5=DDP I DDPP>1 S DD7=DDMAX-DDPP\DDPP,DD5=$E($P(DDP,":",1),1,DD7) F I=2:1:DDPP S DD5=DD5_":"_$E($P(DDP,":",I),1,DD7) S DDP=$E(DD5,1,DDMAX-1)_"*" Q OUT ; W "->",$P(DDFPT," ",2) W " " S DDP=$$FILENAME^DIALOGZ(DDFPT) S:DDP="" DDP="*** NONEXISTENT FILE "_DDFPT_"***" S DDMAX=IOM-$X D SHORT W DDP,! Q ; ; TO N DDLGO ;WRITE LEFT SIDE OF BOX S DDP="",(DDCR,DDINC)=0 Q:'$D(^UTILITY($J,"FD",DDFLE,"TO",DDLN)) S DDPT=$O(^(DDLN,"")),DDPTF=$O(^(DDPT,"")),DDA1=$$LABEL^DIALOGZ(DDPT,DDPTF)_U_$P(^DD(DDPT,DDPTF,0),U,2),DDLN=DDLN+1 I DDPT'>0 S DDP="*** NONEXISTENT FILE ***",DDTO="" G TOOK I '$D(^DD(DDPT)) S DDP="*** NONEXISTENT FILE "_DDPT_"***" G TOOK S DDPTF=+DDPTF,DDTO=DDPT,DDPP=$P(DDA1,U,1) TOUP S DD5=$$FILENAME^DIALOGZ(DDTO) I $D(^DD(DDTO,0,"UP")) S DDTO=^("UP") S:(DD5'=$P(DDPP,":",1)) DDPP=DD5_":"_DDPP G TOUP S DDINC=$D(^UTILITY($J,"F",DDTO)),DDLGO=$P(DDA1,U,2)'["'",DDA1=$P(DDA1,U,2)["V" S:(DD5'=$P(DDPP,":",1)) DDPP=DD5_":"_DDPP S DDCR=0,DD5="",DD7=DDPT,DDP=DDPP S:DD7?.E1"."2N DD7=+$P(DD7,".",1,$L(DD7,".")-1) F I=1:1 S DD5=$O(^DD(DD7,0,"IX",DD5)) Q:DD5="" I $D(^DD(DD7,0,"IX",DD5,DDPT,DDPTF)) S DDCR=1 TOOK Q:DDP="" S DDMAX=DDTB1-15,DD5=$P(DDP,":",1),DD7=DDP D D SHORT .I DD5=DD9 S DDP=" "_$P(DDP,":",2,999),DDPT="" Q .W " ",$S(IOST["C":$E(DD5,1,20),1:DD5)," (#",DDTO,")",?DDTB1,"|",?DDTB2,"|",! .S DDP=" "_$P(DD7,":",2,999),DD9=DD5,DDPT="" Q S DDW=$S('DDINC:"N S",1:"N") D .W " ",DDP," " W:DDA1 "v " D W ?DDTB1-12,"(",DDW," " S:'$D(DDLGO) DDLGO=0 W:DDCR "C " W:DDLGO "L" W ")->" ..F I=$L(DDP):1:DDTB1-18 W "." Q ; ; END I $D(^UTILITY($J,"FD",DDFLE,"TO",DDLN)) D TO W:$X'>DDTB1 ?DDTB1,"|" W ?DDTB2,"|",! S DDOUT=1 D:$Y>DDMIOSL HDR^DDMAP2 G KILL^DDMAP:$D(DTOUT),END I DDOUT S DDOUT=0 D VIIVA^DDMAP2 G NXF S DDPCK=+$O(^UTILITY($J,"FD",DDFLE)) I '$D(^DD(DDPCK,0,"UP")) D VIIVA^DDMAP2 G NXF Q DDMAP2 DDMAP2 ;SFISC/JKS(Helsinki)-GRAPH OF FILEMAN PTRS ;2/4/91 3:38 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. NXF ;Loop thru file selected and get to/from pointers F DDFLE=0:0 S DDFLE=$O(^UTILITY($J,"F",DDFLE)) G:DDFLE'>0 ST D GETTO,GETFR GETTO ;Look down "PT" X-ref to find files that point to me. F DDPT=0:0 S DDPT=$O(^DD(DDFLE,0,"PT",DDPT)) Q:DDPT'>0 F DDPTF=0:0 S DDPTF=$O(^DD(DDFLE,0,"PT",DDPT,DDPTF)) Q:DDPTF'>0 D NOT I DDW D NOT1 Q NOT1 S DDTO(DDFLE)=$S('$D(DDTO(DDFLE)):1,1:DDTO(DDFLE)+1) S ^UTILITY($J,"FD",DDFLE,"TO",DDTO(DDFLE),DDPT,DDPTF)=DDA1 Q NOT S DDW=0 I $D(^DD(DDPT,DDPTF,0)) S DDA1=$P(^(0),U,1,2),X=$P(DDA1,U,2) S:(X[("P"_DDFLE))!(X["V") DDW=1 Q Q GETFR S DDPTF=DDFLE ;Look at all fields (and subs) to find pointers to others. NXTF F DDPCK=0:0 S DDPCK=$O(^DD(DDPTF,DDPCK)) G:DDPCK'>0 SUB S DDA1=$P(^DD(DDPTF,DDPCK,0),U,1,2),DDA2=$P(DDA1,U,2) D SETF:DDA2?.E1"P"1N.E,SETV:DDA2["V" Q SUB F DDMAPC=0:0 S DDPTF=$O(^DD(DDPTF)) Q:'$D(^DD(DDPTF,0,"UP"))!(DDPTF'[DDFLE) D NXFLD Q NXFLD F DDPCK=0:0 S DDPCK=$O(^DD(DDPTF,DDPCK)) Q:DDPCK'>0 S DDA1=$P(^(DDPCK,0),U,1,2),DDA2=$P(DDA1,U,2) D SETF:DDA2?.E1"P"1N.E,SETV:DDA2["V" Q SETF S DDPT=+$P(DDA2,"P",2) S:DDPT ^UTILITY($J,"FD",DDFLE,"FR",DDPTF,DDPCK,DDPT)=DDA1 Q SETV F X=0:0 S X=$O(^DD(DDPTF,DDPCK,"V",X)) Q:X'>0 S DDPT=$P(^(X,0),U),^UTILITY($J,"FD",DDFLE,"FR",DDPTF,DDPCK,DDPT)=$P(DDA1,U,1)_U_"V"_DDPT Q ST S DD9=0,DDFLE="",DDTB1=IOM\2,DDTB2=$S(IOM/4>30:30,1:IOM\4)+DDTB1,DDFNMAX=DDTB2-DDTB1-5,DDMIOSL=IOSL-4 D HDR G KILL^DDMAP:$D(DTOUT),^DDMAP1 VIIVA S DD5=$S($X1 S DDMPSTAT("LIEN")=DDMPIENS(1) E S (DDMPSTAT("FIEN"),DDMPSTAT("LIEN"))=DDMPIENS(1) Q ; TOT(DDMPSTAT) ; S DDMPSTAT("TOT")=DDMPSTAT("TOT")+1 I '$D(ZTQUEUED) W "." E I DDMPSTAT("TOT")#10=0,$$S^%ZTLOAD D . S DDMPSTAT("ABORT")=2 . S ZTSTOP=1 Q ; RECERR ; N DDMPERLN,DDMPERR S DDMPSTAT("NG")=DDMPSTAT("NG")+1 D LDXTMP^DDMP2("Record #"_DDMPSTAT("TOT")_" Rejected:") D MSG^DIALOG("AEB",.DDMPERR,$S($D(IOM):IOM-5,1:75)) S DDMPERLN=0 F S DDMPERLN=$O(DDMPERR(DDMPERLN)) Q:'DDMPERLN D LDXTMP^DDMP2(" "_DDMPERR(DDMPERLN)) D CLEAN^DIEFU I DDMPSTAT("NG")'2:DDMPQ,1:"") . . . S DDMPIN=$E(DDMPIN,$L(DDMPTVAL)+1,$L(DDMPIN)) ; S DDMPIN=$P(DDMPIN,DDMPTVAL,2) . . . I DDMPIN=DDMPFMT("FDELIM") S DDMPIN="",DDMPVAL=DDMPTVAL Q . . . S DDMPIN=$P(DDMPIN,DDMPFMT("FDELIM"),2,99) . . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q . . . S DDMPVAL=DDMPTVAL . E I $G(DDMPFMT("FDELIM"))'="" D . . S DDMPTVAL=$P(DDMPIN,DDMPFMT("FDELIM")) . . I $L(DDMPIN,DDMPFMT("FDELIM"))=2,$P(DDMPIN,DDMPFMT("FDELIM"),2)="" S DDMPIN="",DDMPVAL=$G(DDMPHOLD)_DDMPTVAL,DDMPHOLD="" Q . . S DDMPIN=$P(DDMPIN,DDMPFMT("FDELIM"),2,99) . . I $G(DDMPHOLD)]"" S DDMPVAL=DDMPHOLD_DDMPTVAL,DDMPHOLD="" Q . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q . . S DDMPVAL=DDMPTVAL . E D . . N DDMPLEN,DDMPLAST . . I '$D(DDMPSQ(DDMPSQ+1)) D BLD^DIALOG(1862) Q . . S DDMPLEN=$P(DDMPSQ(DDMPSQ+1),"~",4) . . I $G(DDMPHOLD)]"" D . . . S DDMPVAL=DDMPHOLD_$E(DDMPIN,1,DDMPLEN-$L(DDMPHOLD)) . . . S DDMPIN=$E(DDMPIN,DDMPLEN-$L(DDMPHOLD)+1,255) . . . S DDMPHOLD="" . . E D . . . S DDMPTVAL=$E(DDMPIN,1,DDMPLEN) . . . S DDMPIN=$E(DDMPIN,DDMPLEN+1,255) . . . I DDMPIN="",DDMPI'=DDMPNDCT S DDMPHOLD=DDMPTVAL Q . . . S DDMPVAL=DDMPTVAL . . I $D(DDMPVAL) F S DDMPLAST=$L(DDMPVAL) Q:$E(DDMPVAL,DDMPLAST)'=" " S DDMPVAL=$E(DDMPVAL,1,DDMPLAST-1) . I $D(DDMPVAL) D K DDMPVAL . . S DDMPSQ=DDMPSQ+1 . . I '$D(DDMPSQ(DDMPSQ)) D BLD^DIALOG(1862) Q . . I $G(DDMPFMT("QUOTED"))="YES" S DDMPVAL=$TR(DDMPVAL,DDMPQ) . . D FDASET(DDMPVAL,DDMPSQ(DDMPSQ)) I $G(DDMPFMT("FIXED"))="YES" F DDMPSQ=DDMPSQ+1:1 Q:'$D(DDMPSQ(DDMPSQ)) S DDMPVAL="" D FDASET(DDMPVAL,DDMPSQ(DDMPSQ)) Q ; FDASET(DDMPVAL,DDMPSPEC) ; S ^TMP($J,"DDMPFDA",$P(DDMPSPEC,"~"),$P(DDMPSPEC,"~",2),$P(DDMPSPEC,"~",3))=DDMPVAL Q ; DDMP1 DDMP1 ;SFISC/DPC-ASCII IMPORT UTIILTIES ;9/19/96 14:58 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. GETFMT(DDMPFMT) ; ; Sets up format info. ;DDMPFMT passed by reference. N DDMPFRMT I '($D(DDMPFMT)\10) D Q:'($D(DDMPFMT)\10) . D FIND^DIC(.44,"","1;5;8","X",DDMPFMT,"","","","","DDMPFRMT") . I 'DDMPFRMT("DILIST",0) D BLD^DIALOG(1820,DDMPFMT,DDMPFMT) Q . S DDMPFMT("IEN")=DDMPFRMT("DILIST",2,1) . S DDMPFMT("FDELIM")=DDMPFRMT("DILIST","ID",1,1) . S DDMPFMT("FIXED")=DDMPFRMT("DILIST","ID",1,5) . S DDMPFMT("QUOTED")=DDMPFRMT("DILIST","ID",1,8) S DDMPFMT("FDELIM")=$G(DDMPFMT("FDELIM")) I DDMPFMT("FDELIM") D . N DDMPI,DDMPPC,DDMPASCI S DDMPASCI="" . F DDMPI=1:1 S DDMPPC=$P(DDMPFMT("FDELIM"),",",DDMPI) Q:'DDMPPC S DDMPASCI=DDMPASCI_$C(DDMPPC) . S DDMPFMT("FDELIM")=DDMPASCI S DDMPFMT("QUOTED")=$G(DDMPFMT("QUOTED"),"NO") S DDMPFMT("FIXED")=$G(DDMPFMT("FIXED"),"NO") I ((DDMPFMT("FIXED")="YES")&(DDMPFMT("FDELIM")'=""))!((DDMPFMT("FIXED")'="YES")&(DDMPFMT("FDELIM")="")) D BLD^DIALOG(1821) Q ; GETSRC(DDMPFSRC) ; ;Moves data from source file into global. N DDMPIMWK K ^TMP($J,"DDMP") S DDMPIMWK=$$FTG^%ZISH(DDMPFSRC("PATH"),DDMPFSRC("FILE"),$NA(^TMP($J,"DDMP",0)),3) I 'DDMPIMWK D BLD^DIALOG(1810,DDMPFSRC("FILE"),DDMPFSRC("FILE")) Q I '$D(^TMP($J,"DDMP")) D BLD^DIALOG(1812,DDMPFSRC("FILE"),DDMPFSRC("FILE")) Q ; RQIDOK(DDMPFLDS) ; ;Verifies that required identifiers present in fields being imported. N DDMPF,DDMPRIDS,DDMPRID,DDMPERCT S DDMPF=0,DDMPERCT=$G(DIERR) F S DDMPF=$O(DDMPFLDS(DDMPF)) Q:DDMPF="" D . D REQIDS^DICU(DDMPF,"DDMPRIDS") . S DDMPRID=0 . F S DDMPRID=$O(DDMPRIDS("REQUIRED IDENTIFIERS",DDMPRID)) Q:DDMPRID="" D . . I ";"_DDMPFLDS(DDMPF)_";"'[(";"_DDMPRID_";"),";"_DDMPFLDS(DDMPF)'[(";"_DDMPRID_"[") D . . . N DDMPP S DDMPP("FILE")=DDMPF . . . D BLD^DIALOG(312,.DDMPP,.DDMPP) Q DDMPERCT=$G(DIERR) ; INFILE(DDMPINAR,DDMPFMT,DDMPFBCK,DDMPDR,DDMPNCNT) ; N DDMPDELM,DDMPFLDS,DDMPF,DDMPFSTR,DDMPI,DDMPJ,DDMPVAL,DDMPDONE S DDMPNCNT="" I DDMPFMT("FIXED")="YES" S DDMPDELM="," E S DDMPDELM=DDMPFMT("FDELIM") F S DDMPNCNT=$O(@DDMPINAR@(DDMPNCNT)) Q:DDMPNCNT=""!$G(DDMPDONE) S DDMPVAL=^(DDMPNCNT) D Q:$G(DIERR) . I DDMPVAL="" Q . I '$D(DDMPF) D Q . . S DDMPF=$P(DDMPVAL,"FILE=",2) . . I DDMPF="" D BLD^DIALOG(1831) Q . . S DDMPF=$$FILENUM(DDMPF) . F DDMPI=1:1 S DDMPFSTR=$P(DDMPVAL,DDMPDELM,DDMPI) Q:DDMPFSTR="" D . . N DDMPFDF,DDMPDPTH,DDMPFLD . . S DDMPDPTH=$L(DDMPFSTR,":") . . S DDMPFDF=DDMPF . . F DDMPJ=1:1:DDMPDPTH S DDMPFLD=$P(DDMPFSTR,":",DDMPJ) D Q:$G(DIERR) . . . N DDMP0P2 . . . D FLDVAL Q:$G(DIERR) . . . S $P(DDMPFSTR,":",DDMPJ)=DDMPFLD_U_DDMPFDF . . . S DDMPFDF=+DDMP0P2 . . S DDMPFLDS(DDMPI)=DDMPFSTR . S DDMPDONE=1 I $O(@DDMPINAR@(DDMPNCNT))="" S DDMPNCNT="" I $G(DIERR)!(DDMPNCNT="") Q S DDMPFLDS=1 D TODR(DDMPF,.DDMPFLDS,.DDMPDR) S DDMPFBCK=DDMPF Q ; FILENUM(DDMPF) ; I DDMPF,$$VFILE^DILFD(DDMPF) Q DDMPF I $D(^DIC("B",DDMPF))=10 Q $O(^(DDMPF,"")) D BLD^DIALOG(409,DDMPF,DDMPF) Q 0 FLDVAL ; N DDMP0 I 'DDMPFLD S DDMPFLD=$$FLDNUM^DILFD(DDMPFDF,DDMPFLD) Q:$G(DIERR) S DDMP0=$G(^DD(DDMPFDF,DDMPFLD,0)) I DDMP0="" D Q . N DDMPP S DDMPP("FILE")=DDMPFDF,DDMPP(1)=DDMPFLD . D BLD^DIALOG(501,.DDMPP,.DDMPP) S DDMP0P2=$P(DDMP0,U,2) I 'DDMP0P2 D . I DDMPJ1,$P($P(DDMPFLDS(DDMPI-1),":",DDMPJ-1),U,2)'=$P($P(DDMPFSTR,":",DDMPJ-1),U,2) D . D BLD^DIALOG(1844) Q ; TMPL2DR(DDMPF,DDMPFLDS) ; N DDMPDR N DDMPERR S DDMPERR=$G(DIERR) D TMPL2SQ(DDMPF,.DDMPFLDS) I DDMPERR'=$G(DIERR) Q S DDMPFLDS=1 D TODR(DDMPF,.DDMPFLDS,.DDMPDR) K DDMPFLDS M DDMPFLDS=DDMPDR Q ; TMPL2SQ(DDMPF,DDMPFLSQ) ; N DDMPTPNM,DDMPTPNO,DDMPSQ,DDMPPATH S DDMPTPNM=$S($E(DDMPFLSQ)="[":$P($P(DDMPFLSQ,"[",2),"]"),1:DDMPFLSQ) S DDMPTPNO=$O(^DIST(.46,"F"_DDMPF,DDMPTPNM,"")) I 'DDMPTPNO D Q ;Template does not exist. . N DDMPARAM . S DDMPARAM(1)=DDMPTPNM,DDMPARAM("FILE")=DDMPF . D BLD^DIALOG(1870,.DDMPARAM,.DDMPARAM) D LIST^DIC(.463,","_DDMPTPNO_",","1;2;3;10","I") I '$D(^TMP("DILIST",$J,0)) Q F DDMPSQ=1:1:+^TMP("DILIST",$J,0) D . S DDMPPATH=^TMP("DILIST",$J,"ID",DDMPSQ,10) . S DDMPFLSQ(DDMPSQ)=$S(DDMPPATH]"":DDMPPATH_":",1:"")_^(2)_U_^(1) ;naked set on prior line. . I ^(3) S DDMPFLSQ("LN",DDMPSQ)=^(3) ;naked set 2 lines above. K ^TMP("DILIST",$J) Q ; TODR(DDMPF,DDMPFLDS,DDMPDR,DDMPDRTP) ; N DDMPPPTH,DDMPCPTH,DDMPDPTH,DDMPFDWN,DDMPDONE,DDMPODTH F D Q:$G(DDMPDONE)!$G(DIERR) . I '$D(DDMPFLDS(DDMPFLDS)) D TMP2DR Q . I '$D(DDMPDPTH) S DDMPODTH=$L(DDMPFLDS(DDMPFLDS),":") . S DDMPDPTH=$L(DDMPFLDS(DDMPFLDS),":") . I '$D(DDMPCPTH) S DDMPPPTH=$P(DDMPFLDS(DDMPFLDS),":",1,DDMPDPTH-1) . S DDMPCPTH=$P(DDMPFLDS(DDMPFLDS),":",1,DDMPDPTH-1) . I DDMPCPTH=DDMPPPTH D . . I $G(DDMPDRTP(DDMPF))[(";"_+$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH)_";") D Q . . . I +$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH)=$P(DDMPDRTP(DDMPF),";",2),DDMPDPTH>1 D . . . . D TMP2DR . . . E D BLD^DIALOG(1845) . . S DDMPDRTP(DDMPF)=$G(DDMPDRTP(DDMPF),";")_+$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH)_$S('$D(DDMPFLDS("LN")):"",1:"["_DDMPFLDS("LN",DDMPFLDS)_"]")_";" . . S DDMPFLDS=DDMPFLDS+1 . . S DDMPPPTH=DDMPCPTH . . S DDMPODTH=DDMPDPTH . E I DDMPDPTH'>DDMPODTH D . . D TMP2DR . E D . . S DDMPDRTP(DDMPF)=DDMPDRTP(DDMPF)_+$P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH-1)_";" . . S DDMPFDWN=$P($P(DDMPFLDS(DDMPFLDS),":",DDMPDPTH),U,2) . . D TODR(DDMPFDWN,.DDMPFLDS,.DDMPDR,.DDMPDRTP) Q ; TMP2DR ; S DDMPDONE=1 I '$D(DDMPDR(DDMPF)) S DDMPDR(DDMPF)=$E(DDMPDRTP(DDMPF),2,$L(DDMPDRTP(DDMPF))-1) E I DDMPDR(DDMPF)'=$E(DDMPDRTP(DDMPF),2,$L(DDMPDRTP(DDMPF))-1) D . D BLD^DIALOG(1846,DDMPF,DDMPF) K DDMPDRTP(DDMPF) Q ; DDMP2 DDMP2 ;SFISC/DPC-Import Device, Queuing, Reports ;11/5/97 08:10 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. DEV(DDMPIOIN,DDMPIOP) ; ;Device selection for printed report. ;DDMPIOIN might contain preselected info. ;DDMPIOP will contain device data for later use with ^%ZIS. I $D(DDMPIOIN("IOP")) D . I $P(DDMPIOIN("IOP"),";")'="Q" S DDMPIOP=DDMPIOIN("IOP") . E D . . S DDMPIOP=$P(DDMPIOIN("IOP"),";",2,99),DDMPIOP("Q")=1 . . I $D(DDMPIOIN("QTIME")) D SETQTIME E D . N %ZIS,POP . S %ZIS="QN" . S %ZIS("A")="Device for Import Results Report: " . D ^%ZIS . I POP S DDMPIOP("NG")=1 Q . I $E(IOST,1,2)="C-" S DDMPIOP("HOME")=1 Q . D SETIOP . I $G(IO("Q")) S DDMPIOP("Q")=1 Q . D HOME^%ZIS . I $P(DDMPIOP,";",2)="P-BROWSER" Q . N DIR,DIRUT,Y . S DIR(0)="Y" . S DIR("A")="Do you want to queue this data import" . D ^DIR . I $G(DIRUT) S DDMPIOP("NG")=1 Q . I Y S DDMPIOP("Q")=1 Q ; SETIOP ; ;Sets up IOP, etc., from variables returned by ^%ZIS. S DDMPIOP=ION I $G(IOST)]"" S DDMPIOP=DDMPIOP_";"_IOST I $G(IO("DOC"))]"" S DDMPIOP=DDMPIOP_";"_IO("DOC") Q I $G(IOM) S DDMPIOP=DDMPIOP_";"_IOM I $G(IOSL) S DDMPIOP=DDMPIOP_";"_IOSL I $G(IOT)="HFS" S DDMPIOP("HFSNAME")=IO,DDMPIOP("HFSMODE")="W" Q ; SETQTIME ; ;Sets time for queuing from value passed in ("QTIME") N X,Y,%DT S X=DDMPIOIN("QTIME") I X="NOW" S DDMPIOP("QTIME")=$H E D . I X'["@" S X="T@"_X . S %DT="XT",%DT(0)="NOW" . D ^%DT . I Y<0 S DDMPIOP("NG")=1 Q . S DDMPIOP("QTIME")=Y Q ; QUE(DDMPIOP) ; ;Queues the import. S ZTRTN="TASK^DDMP" S ZTIO="" S ZTDESC="Queued data import." I $D(DDMPIOP("QTIME")) S ZTDTH=DDMPIOP("QTIME") S ZTSAVE("^TMP($J,""DDMP"",")="" S ZTSAVE("DDMPIOP(")="" S ZTSAVE("DDMPIOP")="" S ZTSAVE("DDMPF")="" S ZTSAVE("DDMPSQ(")="" S ZTSAVE("DDMPFMT(")="" S ZTSAVE("DDMPFLG")="" S ZTSAVE("DDMPFLG(")="" S ZTSAVE("DDMPNCNT")="" S ZTSAVE("DDMPFSRC(")="" D ^%ZTLOAD I $G(ZTSK) D . W !,"Import queued. Task number: "_ZTSK E W !,"Queuing of import failed. Import aborted." Q ; REP1(DDMPRPSB,DDMPLN) ; N DDMPI,DDMPTXT,DDMPUSR,DDMPFNO,DDMPLEN S DDMPLN=0 I '$D(^XTMP("DDMP1000")) S DDMPRPSB="DDMP1000" E S DDMPRPSB="DDMP"_($P($O(^XTMP("DDMPz"),-1),"DDMP",2)+1) S ^XTMP(DDMPRPSB,0)=DT_U_DT_U S DDMPUSR=$$GET1^DIQ(200,DUZ_",",.01) S ^(0)=^XTMP(DDMPRPSB,0)_"Import report: "_DDMPUSR D LDXTMP($P($T(LN1+1),";;",2)_$P(DDMPUSR,",",2)_" "_$P(DDMPUSR,",")) D LDXTMP("") D LDXTMP($P($T(LN1+2),";;",2)_DDMPFSRC("PATH")_DDMPFSRC("FILE")) D LDXTMP($P($T(LN1+3),";;",2)_DDMPFMT("FIXED")) D LDXTMP($P($T(LN1+4),";;",2)_DDMPFMT("FDELIM")) D LDXTMP($P($T(LN1+5),";;",2)_DDMPFMT("QUOTED")) D LDXTMP($P($T(LN1+6),";;",2)_$S(DDMPFLG["E":"External",1:"Internal")) D LDXTMP("") D LDXTMP($P($T(LN1+7),";;",2)_$$GET1^DID(DDMPF,"","","NAME")) D LDXTMP("") D LDXTMP($P($T(LN1+8),";;",2)) D LDXTMP($P($T(LN1+9),";;",2)) F DDMPI=1:1 Q:'$D(DDMPSQ(DDMPI)) D . S DDMPFNO=$P(DDMPSQ(DDMPI),"~"),DDMPLEN=$P(DDMPSQ(DDMPI),"~",4) . S DDMPTXT=DDMPI_$J("",5-$L(DDMPI))_$S(DDMPLEN:DDMPLEN,1:"n/a") . S DDMPTXT=DDMPTXT_$J("",10-$L(DDMPTXT))_$$GET1^DID(DDMPFNO,$P(DDMPSQ(DDMPI),"~",3),"","LABEL") . I DDMPF'=DDMPFNO S DDMPTXT=DDMPTXT_$J("",43-$L(DDMPTXT))_$O(^DD(DDMPFNO,0,"NM","")) . D LDXTMP(DDMPTXT) D LDXTMP("") D LDXTMP("") D LDXTMP($P($T(LN1+10),";;",2)) D LDXTMP($P($T(LN1+11),";;",2)) D LDXTMP("") Q ; LDXTMP(DDMPTXT) ; S DDMPLN=DDMPLN+1 S ^XTMP(DDMPRPSB,DDMPLN)=DDMPTXT Q ; LN1 ; ;; Import Initiated By: ;; Source File: ;; Fixed Length: ;; Delimited By: ;; Text Values Quoted: ;; Values Are: ;; Primary FileMan Destination File: ;;Seq Len Field Name Subfile Name (if applicable) ;;--- --- ---------- ---------------------------- ;; Error Report ;; ------------ ; REP2(DDMPRPSB,DDMPLN,DDMPSTAT) ; N POP I '$G(DDMPSTAT("NG")) D LDXTMP($P($T(LN2+1),";;",2)) D LDXTMP("") D LDXTMP("") D LDXTMP($P($T(LN2+2),";;",2)) D LDXTMP($P($T(LN2+3),";;",2)) D LDXTMP("") I $G(DDMPSTAT("ABORT")) D . D LDXTMP($P($T(LN2+4),";;",2)) . D LDXTMP($P($T(LN2+(4+DDMPSTAT("ABORT"))),";;",2)) . D LDXTMP("") D LDXTMP($P($T(LN2+7),";;",2)_DDMPSTAT("TOT")) D LDXTMP($P($T(LN2+8),";;",2)_(DDMPSTAT("TOT")-DDMPSTAT("NG"))) D LDXTMP($P($T(LN2+9),";;",2)_DDMPSTAT("NG")) D LDXTMP("") D LDXTMP($P($T(LN2+10),";;",2)_$G(DDMPSTAT("FIEN"),"Nothing filed")) D LDXTMP($P($T(LN2+11),";;",2)_$G(DDMPSTAT("LIEN"),"Nothing filed")) D LDXTMP("") D LDXTMP($P($T(LN2+12),";;",2)_$$HTE^DILIBF(DDMPSTAT("BEG"))) S DDMPSTAT("END")=$H D LDXTMP($P($T(LN2+13),";;",2)_$$HTE^DILIBF(DDMPSTAT("END"))) D LDXTMP($P($T(LN2+14),";;",2)_$$HDIFF^DILIBF(DDMPSTAT("END"),DDMPSTAT("BEG"),3)) I $G(DDMPIOP("HOME")) W @IOF D PRNTHM Q I $P($G(DDMPIOP),";",2)="P-BROWSER" D BROWSET Q:POP D PRNTHM Q ;Set up queued job for report printing. N %ZIS S %ZIS="Q" S IOP="Q;"_DDMPIOP I $D(DDMPIOP("HFSNAME")) S %ZIS("HFSNAME")=DDMPIOP("HFSNAME") I $D(DDMPIOP("HFSNODE")) S %ZIS("HFSMODE")=DDMPIOP("HFSMODE") D ^%ZIS I POP Q ;ERROR THAT REPORT CANNOT PRINT K ZTIO S ZTRTN="PRNT^DDMP2" S ZTSAVE("DDMPRPSB")="" S ZTDTH=$H S ZTDESC="Printing of Import Log for User# "_DUZ D ^%ZTLOAD I '$D(ZTQUEUED) W !,"Task Number for printing: "_ZTSK Q PRNT ; ;Tasked print of report. S ZTREQ="@" U IO PRNTHM ;Print to home device. Tasked prints fall through. N DDMPCNT,DDMPPG,DDMPIOSL,DDMPOUT S DDMPIOSL=$G(IOSL,60) S DDMPPG=0,DDMPCNT=0 D HDR F S DDMPCNT=$O(^XTMP(DDMPRPSB,DDMPCNT)) Q:DDMPCNT="" D Q:$G(DDMPOUT) . W !,^XTMP(DDMPRPSB,DDMPCNT) . I $Y+3>DDMPIOSL D HDR I $E(IOST,1,2)'="C-" W @IOF D ^%ZISC Q ; BROWSET ; N %ZIS S IOP=DDMPIOP D ^%ZIS U IO Q ; HDR ; I DDMPPG,$E(IOST,1,2)="C-" N DIR,Y S DIR(0)="E" D ^DIR I 'Y S DDMPOUT=1 Q I DDMPPG W @IOF S DDMPPG=DDMPPG+1 W $P($T(HDR1+1),";;",2)_DDMPPG W !,$P($T(HDR1+2),";;",2) W ! Q ; HDR1 ; ;; Log for VA FileMan Data Import Page ;; ============================== LN2 ; ;; No errors occured during this data import. ;; Summary of Import ;; ----------------- ;; <<>> ;; USER ABORT OF TASKED IMPORT>>> ;; Total Records Read: ;; Total Records Filed: ;; Total Records Rejected: ;; IEN of First Record Filed: ;; IEN of Last Record Filed: ;; Import Filing Started: ;; Import Filing Completed: ;; Time of Import Filing: DDMPSM DDMPSM ;SFISC/DPC-IMPORT SCREENMAN CALLS ;9/20/96 10:07 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FILESEL ; ; Called form Post-actin on change of Primary File prompt D PUT^DDSVALF("TMP_NM",1,1,"") I DDSOLD'="",$D(DDMPFDSL) S DDMPOLDF=DDSOLD,DDSBR="3^1^3" E D . K DDMPCPNM,DDMPCPTH,DDMPFCAP,DDMPCF,DDMPFDNM . S DDMPF=X . S DDMPFLNM=DDSEXT . D UNED^DDSUTL("FLD_JUMP",1,1,$S(X:0,1:1)) . D UNED^DDSUTL("TMP_NM",1,1,$S(X:0,1:1)) . D REFRESH^DDSUTL Q ; TMPLSCR(DDMPSELF,DDSEXT,DUZ) ; ;called from TMP_NM field. ;DDMPSELF = currently selected primary file. ;DDMPEXT = External value of selected template. I $P(^(0),U,4)'=DDMPSELF Q 0 I DUZ(0)["@" Q 1 N DDMPRDAC,DDMPI,DDMPOK S DDMPRDAC=$P(^(0),U,3),DDMPOK=0 F DDMPI=1:1:$L(DDMPRDAC) I DUZ(0)[$E(DDMPRDAC,DDMPI) S DDMPOK=1 Q Q DDMPOK ; CHNGFILE ; ;Called for Post-action on pop-up file change verification page. I X D ;code for changing selected file. . K DDMPFDSL,DDMPCPNM,DDMPCPTH,DDMPFCAP,DDMPCF,DDMPFDNM . S (DDMPOSET,DDMPFDCT)=0 . S DDMPF=$$GET^DDSVALF("F_SEL",1,1) . S DDMPFLNM=$$GET^DDSVALF("F_SEL",1,1,"E") . I DDMPF="" D UNED^DDSUTL("FLD_JUMP",1,1,1),UNED^DDSUTL("TMP_NM",1,1,1) . S DDSBR="FLD_JUMP^1^1" . ;D REFRESH^DDSUTL E D . D PUT^DDSVALF("F_SEL",1,1,DDMPOLDF,"I") . S DDSBR="F_SEL^1^1" Q ; IXF ; ;Called from input transform of Field Selection field. N D0,DA,DIC,DP,Y S DIC="^DD("_DDMPCF_",",DIC(0)="ENZ" D ^DIC I Y'>0 K X E S (X,DDMPX)=+$P(Y,"E"),DDMPFDNM=Y(0,0) Q ; FDPROC ; ;Called from post-action on change of Field Selection prompt. N DDMP0P2 S DDMP0P2=$P(^DD(DDMPCF,DDMPX,0),U,2) I +DDMP0P2 D . S DDSBR="FLD" . I 'DDMPFDCT D HLP^DDSUTL($C(7)_"You must select a field in the top level file before entering multiple.") Q . N DDMPI,DDMPOK . F DDMPI=1:1:DDMPFDCT I $P(DDMPFDSL(DDMPI),U,$L(DDMPFDSL(DDMPI),U))=DDMPCF S DDMPOK=1 Q . I '$G(DDMPOK) D HLP^DDSUTL($C(7)_"You must select a field in a subfile before entering one of its multiples.") Q . S DDMPFCAP=$$PATHNM(+DDMP0P2,DDMPFLNM) . S DDMPCPTH=$S($L($G(DDMPCPTH)):DDMPCPTH_":",1:"")_DDMPX_U_DDMPCF . S DDMPCF=+DDMP0P2 . S DDMPCPNM=$S($L($G(DDMPCPNM)):DDMPCPNM_":",1:"")_DDMPFDNM E D . S DDMPFDCT=DDMPFDCT+1 . S DDMPFDSL(DDMPFDCT)=$S($L($G(DDMPCPTH)):DDMPCPTH_":",1:"")_DDMPX_U_DDMPCF . S DDMPFDSL("CAP",DDMPFDCT)=$S($L($G(DDMPCPNM)):DDMPCPNM_":",1:"")_DDMPFDNM . S DDMPOSET=$S(DDMPFDCT>9:DDMPFDCT-9,1:0) . S DDSBR=$S($G(DDMPSMFF("FIXED"))="YES":"LEN",1:"FLD") Q ; PATHNM(DDMPSFNO,DDMPFLNM) ; N DDMPPATH S DDMPPATH="" I $D(^DD(DDMPSFNO,0,"UP")) F D Q:'$D(^DD(DDMPSFNO,0,"UP")) . S DDMPPATH=" : "_$P($P(^DD(DDMPSFNO,0),U),"SUB-FIELD")_"Subfile"_DDMPPATH . S DDMPSFNO=^DD(DDMPSFNO,0,"UP") Q $G(DDMPFLNM,$P(^DIC(DDMPSFNO,0),U))_DDMPPATH ; UP1 ; ;Called from post-action on Field Selection prompt if null entered. S DDMPFCAP=$P($G(DDMPFCAP)," : ",1,$L($G(DDMPFCAP)," : ")-1) S DDMPCF=$P(DDMPCPTH,U,$L(DDMPCPTH,U)) S DDMPCPTH=$P(DDMPCPTH,":",1,$L(DDMPCPTH,":")-1) S DDMPCPNM=$P(DDMPCPNM,":",1,$L(DDMPCPNM,":")-1) Q ; DELFLD ; ;Called from post-action on change of the "Do you want to delete" prompt I DDMPFDCT=0 Q N DDMPL S DDMPL=$L($G(DDMPFDSL(DDMPFDCT-1)),":") I DDMPL=1 D . S DDMPCF=DDMPF . S DDMPFCAP=DDMPFLNM . S (DDMPCPNM,DDMPCPTH)="" E D . S DDMPCF=$P(DDMPFDSL(DDMPFDCT-1),U,$L(DDMPFDSL(DDMPFDCT-1),U)) . S DDMPFCAP=$$PATHNM(+DDMPCF,DDMPFLNM) . S DDMPCPTH=$P(DDMPFDSL(DDMPFDCT-1),":",1,DDMPL-1) . S DDMPCPNM=$P(DDMPFDSL("CAP",DDMPFDCT-1),":",1,DDMPL-1) K DDMPFDSL(DDMPFDCT),DDMPFDSL("CAP",DDMPFDCT),DDMPFDSL("LN",DDMPFDCT) S DDMPFDCT=DDMPFDCT-1 I DDMPOSET S DDMPOSET=DDMPOSET-1 Q ; ; VAL ; ;Called from form level validation. N DDMPMSG ;1)Validate format of import. I (($G(DDMPSMFF("FIXED"))="YES")&($G(DDMPSMFF("FDELIM"))'=""))!(($G(DDMPSMFF("FIXED"))'="YES")&($G(DDMPSMFF("FDELIM"))="")) D G VALERR . D BLD^DIALOG(1821) . S DDSERROR=2 . S DDSBR="FOR_FMT^1^1" . D MSG^DIALOG("AE",.DDMPMSG) ; ;2) If file specified, move fields selected into DR(). Look for DIERRs created during move. I $G(DDMPF)]"" D . I $$GET^DDSVALF("TMP_NM",1,1)]"" D . . S DDMPFDSL=$$GET^DDSVALF("TMP_NM",1,1,"E") . . D TMPL2SQ^DDMP1(DDMPF,.DDMPFDSL) . I '$D(DDMPFDSL(1)) D Q . . S DDSERROR=$G(DDSERROR)+1 . . S DDMPMSG(DDSERROR)="You must specify some fields into which to import data." . . S DDSBR="FLD_JUMP^1^1" . K DDMPDR . S DDMPFDSL=1 . N DDMPDIER S DDMPDIER=$G(DIERR) . D TODR^DDMP1(DDMPF,.DDMPFDSL,.DDMPDR) . I $G(DIERR)>DDMPDIER D . . S DDSERROR=$G(DDSERROR)+DIERR . . D MSG^DIALOG("AE",.DDMPMSG) . . S DDSBR="2.2^1^2" . . K DDMPDR ; VALERR I $G(DDSERROR) D MSG^DDSUTL(.DDMPMSG) Q Q ; FF ; ;Called from post-action on change of the Foreign Format field. N DDMPI I X'="" D . S DDMPSMFF=DDSEXT . S DDMPSMFF("IEN")=X . S DDMPSMFF("FDELIM")=$$GET1^DIQ(.44,X_",",1) . S DDMPSMFF("FIXED")=$$GET1^DIQ(.44,X_",",5) . S DDMPSMFF("QUOTED")=$$GET1^DIQ(.44,X_",",8) . F DDMPI="FIX","FLD_DLM","QUOTE" D . . D PUT^DDSVALF(DDMPI,1,1,"") . . D UNED^DDSUTL(DDMPI,1,1,1) E D . K DDMPSMFF . F DDMPI="FIX","FLD_DLM","QUOTE" D UNED^DDSUTL(DDMPI,1,1,0) Q DDMPSM1 DDMPSM1 ;SFISC/DPC-IMPORT SCREENMAN CALLS (CONT) ;9/20/96 11:28 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. HOSTHELP ;Called from HELP on the Host File prompt. N DDMPPATH S DDMPPATH=$$GET^DDSVALF("PTH",1,1) K ^TMP($J,"DDMPHOST") D GETHOSTS(DDMPPATH,$NA(^TMP($J,"DDMPHF"))) S ^TMP($J,"DDMPHOST",1)="Enter the name of the host file that contains the data to be imported." I $D(^TMP($J,"DDMPHF")) D . S ^TMP($J,"DDMPHOST",2)="" . S ^TMP($J,"DDMPHOST",3)="These are the files in the "_DDMPPATH_" directory:" . N DDMPHFNM,I S DDMPHFNM="" . F I=4:1 S DDMPHFNM=$O(^TMP($J,"DDMPHF",DDMPHFNM)) Q:DDMPHFNM="" S ^TMP($J,"DDMPHOST",I)=DDMPHFNM S:I#2 ^(I,"F")="?40" . D EN^DDIOL("","^TMP($J,""DDMPHOST"")") K ^TMP($J,"DDMPHF"),^TMP($J,"DDMPHOST") Q ; GETHOSTS(DDMPPATH,DDMPHFAR) ; ;Obtains list of all host files in a specified directory. ;Input: ;DDMPPATH - Directory name w/ full path. ;DDMPHFAR - Target array for output from $$LIST^%ZISH call. N DDMPHF I DDMPPATH="" Q S DDMPHF("*.*")="" K @DDMPHFAR I $$LIST^%ZISH(DDMPPATH,"DDMPHF",DDMPHFAR) Q PAGE2 ; ;Call from page 2 pre-action. I $D(DDMPFRP4) K DDMPFRP4 Q I $G(DDMPF)="" D Q . S DDSBR="F_SEL^1^1" . D HLP^DDSUTL($C(7)_"You must choose a file before you can go to the Field Selection page.") S DDMPCF=$G(DDMPCF,DDMPF) D UNED^DDSUTL("LEN",1,2,$S($G(DDMPSMFF("FIXED"))="YES":0,1:1)) I $G(DDMPSMFF("FIXED"))="YES",DDMPFDCT,'$D(DDMPFDSL("LN")) D . N DDMPHLP . S DDSBR="FLD_DEL" . S DDMPHLP(1)=$C(7) . S DDMPHLP(2)="You have specified a fixed length format for imported data." . S DDMPHLP(3)="However, you have not entered field lengths for fields you have chosen." . S DDMPHLP(4)="So, you must either delete all the fields entered so far" . S DDMPHLP(5)="or change the format to one that is not fixed length." . D HLP^DDSUTL(.DDMPHLP) Q ; LENCHK ; ;Called from the post action on change field of the Length: prompt pop-up page. I X="L" D . S DDSBR="LEN^1^2" E D . D DELFLD^DDMPSM . S DDSBR="FLD^1^2" . D PUT^DDSVALF("FLD",1,2,"") D PUT^DDSVALF(2,1,4,"") Q DDMPU DDMPU ;SFISC/DPC-IMPORT USER INTERFACE, TEMPLATE CREATE ;9/12/96 17:07 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ;Entry point for Import Data option. D CLEAN^DIEFU N DIQUIET,DIFM S (DIQUIET,DIFM)=1 N DA N DDMPHOST,DDMPSELF,DDMPFLAG,DDMPDR,DDSSAVE,DDMPSMFF,DDMPHOST,DDMPIORE,DDMPFDSL,DDMPTMPL D Q:'$G(DDSSAVE) . N DDSPARM,DDSFILE,DR . N DDMPF,DDMPCF,DDMPCPNM,DDMPCPTH,DDMPFCAP,DDMPFDCT,DDMPFDNM,DDMPFLNM,DDMPOSET,DDMPX,DDMPFRP4,DDMPOLDF . S DDSFILE=.46,DR="[DDMP SPECIFY IMPORT]",DDSPARM="S" D ^DDS W @IOF I '$D(DDMPSELF) S DDMPFLAG="F" I $G(DDMPIORE)="E" S DDMPFLAG=$G(DDMPFLAG)_"E" I '($G(DDMPTMPL)]""),$D(DDMPSELF) D . N DIR,DIRUT,Y . S DIR(0)="Y" . S DIR("A")="Do you want to store the selected fields in an Import Template" . D ^DIR . I Y D MKTMPL(DDMPSELF,.DDMPFDSL,.DDMPDR) N DIR,DIRUT,Y S DIR(0)="Y" S DIR("A")="Do you want to proceed with the import" S DIR("?",1)="If you answer 'YES', the import will occur now." S DIR("?")="If you answer 'NO', you will need to respecify the import criteria." W ! D ^DIR I 'Y!$G(DIRUT) W !!,"Okay, you can do the import later." Q D FILE^DDMP($G(DDMPSELF),.DDMPDR,$G(DDMPFLAG),.DDMPHOST,.DDMPSMFF) W !! I $G(DIERR) D . W "Following error messages were generated when import failed." . D MSG^DIALOG("","","",3) E I '$G(ZTSK) W "Done." Q ; MKTMPL(DDMPF,DDMPFLDS,DDMPDR) ; Create Import Template. N DDMPTPNM,DDMPTPNO,DDMPRCNO,DDMPOUT,DDMPSQ,DIR,DIRUT,Y F D Q:$G(DDMPOUT)!($G(DDMPTPNM)]"") . S DIR(0)="FA^3:30^K:(X?1P.E) X" . S DIR("?")="Enter name for your import template. It should be 3-30 characters and it should not start with a punctuation character" . S DIR("A")="Name of Import Template: " . W ! D ^DIR . I Y']""!$G(DIRUT) S DDMPOUT=1 Q . S DDMPTPNM=Y . S DDMPTPNO=$O(^DIST(.46,"F"_DDMPF,DDMPTPNM,"")) . I DDMPTPNO D DUPNAME(DDMPF,.DDMPTPNM,DDMPTPNO) Q:DDMPTPNM="" . S DIR("A")=" Are you adding '"_DDMPTPNM_"' as a new Import Template" . S DIR(0)="Y" . D ^DIR . I 'Y S DDMPTPNM="" Q . K ^TMP($J,"DDMPFDA") . S ^TMP($J,"DDMPFDA",.46,"+1,",.01)=DDMPTPNM . S ^TMP($J,"DDMPFDA",.46,"+1,",4)=DDMPF . S ^TMP($J,"DDMPFDA",.46,"+1,",5)=DUZ . S ^TMP($J,"DDMPFDA",.46,"+1,",2)=DT . S:DUZ(0)'="@" (^TMP($J,"DDMPFDA",.46,"+1,",3),^TMP($J,"DDMPFDA",.46,"+1,",6))=DUZ(0) . F DDMPSQ=1:1 Q:'$D(DDMPFLDS(DDMPSQ)) D . . N DDMPIENS,DDMPLVLS . . S DDMPIENS="+"_(DDMPSQ+1)_",+1," . . S DDMPLVLS=$L(DDMPFLDS(DDMPSQ),":") . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,.01)=DDMPSQ . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,1)=$P($P(DDMPFLDS(DDMPSQ),":",DDMPLVLS),U,2) . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,2)=+$P(DDMPFLDS(DDMPSQ),":",DDMPLVLS) . . S:$D(DDMPFLDS("LN",DDMPSQ)) ^TMP($J,"DDMPFDA",.463,DDMPIENS,3)=DDMPFLDS("LN",DDMPSQ) . . S:DDMPLVLS>1 ^TMP($J,"DDMPFDA",.463,DDMPIENS,10)=$P(DDMPFLDS(DDMPSQ),":",1,DDMPLVLS-1) . . S ^TMP($J,"DDMPFDA",.463,DDMPIENS,20)=DDMPFLDS("CAP",DDMPSQ) . N DDMPERR S DDMPERR=$G(DIERR) . D UPDATE^DIE("","^TMP($J,""DDMPFDA"")","DDMPRCNO") . I DDMPERR'=$G(DIERR) W !,"An error occurred during the filing of the import template." S DDMPOUT=1 Q . D RECALL^DILFD(.46,DDMPRCNO(1)_",",DUZ) . I DUZ(0)="@" S $P(^DIST(.46,DDMPRCNO(1),0),U,3)="@",$P(^(0),U,6)="@" I $G(DDMPOUT) W !,"No import template will be created." Q ; DUPNAME(DDMPF,DDMPTPNM,DDMPTPNO) ;selected template exists. ;If Import template name remains in DDMPTPNM after subroutine, ;user has chosen to delete existing template. W !!,"Import Template "_DDMPTPNM_" already exists." N DDMPDLOK S DDMPDLOK=0 I DUZ(0)="@" D . S DDMPDLOK=$$CKDLT E D . N DDMPWRAC,I . S DDMPWRAC=$$GET1^DIQ(.46,DDMPTPNO_",",6) . F I=1:1:$L(DDMPWRAC) I DUZ(0)[$E(DDMPWRAC,I) S DDMPDLOK=$$CKDLT Q I DDMPDLOK D . N DIK,DA S DIK="^DIST(.46,",DA=DDMPTPNO D ^DIK . W !,"Existing Import Template "_DDMPTPNM_" has been deleted." E S DDMPTPNM="" W !!,"Choose another template name." Q ; CKDLT() ; ;user has write access to the template. Do they want to delete it? N DIR,DIRUT S DIR(0)="Y" S DIR("A")="Do you want to replace the existing template with a new one" S DIR("?",1)="If you answer 'YES', the existing template will be deleted." S DIR("?")="Answer YES or NO." D ^DIR I 'Y!$G(DIRUT) Q 0 Q 1 DDPA1 DDPA1 ;SFISC/TKW RESET IX NODES ON HAND-EDITED TEMPLATES ;5/12/95 11:23 V ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ; N A,B,I,J,X,DIR S DIR("?",1)="This will repair known hand-edited templates in national packages.",DIR("?",2)="If none show on the report, it means that none of the templates on your system" S DIR("?")="needed to be repaired." S DIR(0)="Y",DIR("A")="Repair ""IX"" nodes on hand-edited templates",DIR("B")="Yes" D ^DIR Q:Y'=1 W !!,"Searching Sort Template file...please wait",!!,"Report of templates repaired",!! K ^TMP($J) S U="^" S ^TMP($J,"DG FEMALE INPATIENTS")="^DPT(""CN"",^DPT(^2" S ^TMP($J,"RT WARD LIST")="^DPT(""AA"",^DPT(^2" S J="RT CHARGED BY HOME BY BOR^RT CHARGED BY HOME BY NAME^RT OVER BY HOME BY BOR^RT OVER BY HOME BY NAME^RT OVER BY DIV BY BOR^RT OVER BY DIV BY NAME^RT OVER BY DIV BY TD^RT OVER BY HOME BY TD^RT CHARGED BY HOME BY TD" F I=1:1 S X=$P(J,U,I) Q:X="" S ^TMP($J,X)="^RT(""AC"",^RT(^2" S J="RT HOME LIST BY BOR^RT HOME LIST BY NAME^RT HOME LIST BY TD" F I=1:1 S X=$P(J,U,I) Q:X="" S ^TMP($J,X)="^RT(""AH"",^RT(^2" S ^TMP($J,"RT LOOSE FILING")="^RT(""AL"",^RT(^2" S ^TMP($J,"DGPT WORKFILE")="^DG(45.85,""ACENSUS"",^DG(45.85,^2" S ^TMP($J,"A1B2 OUTPUT1")="^A1B2(11500.2,""AREM"",^A1B2(11500.2,^2" S ^TMP($J,"DG PTF NO ADMISSION")="^DGPM(""ATT3"",^DGPM(^2" S (^TMP($J,"XTLK KEYWORD ALPHA"),^TMP($J,"XTLK KEYWORD CODES"))="^XT(8984.1,""AD"",^XT(8984.1,^2" F I=0:0 S I=$O(^DIBT(I)) Q:'I S X=$P($G(^(I,0)),U) I $D(^TMP($J,X)) D . S B=$G(^DIBT(I,2,1,"IX")),A=^TMP($J,X) Q:A=B . W X,!," Before: ",B,! . S ^DIBT(I,2,1,"IX")=A . W " After: ",^DIBT(I,2,1,"IX"),! . Q K ^TMP($J) W !!!,"DONE!!",! Q DDPA2 DDPA2 ;SFISC/TKW FIND NON-CANONIC SORT RANGES WITH NO ASK NODE ;8/8/95 10:46 V ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ; This routine will find any sort templates that have a sort field ; with a range that is FROM or TO a non-canonic number, has no ; ASK node, and that has ; had an extra space inserted by FM21 prior to patch DI*21*9. N I,J,X,Y,DIR,DIERR,DTOUT,DIRUT,DIROUT,DUOUT W !!,"This routine will report any sort templates that have been corrupted due to",!,"a bug in FM21 that has been repaired by patch DI*21*9.",!! W "If any templates are reported here, you can repair them by editing the template,",!,"without changing any of the sort fields.",! S DIR("?",1)="This routine will report any sort templates that may have been corrupted.",DIR("?",2)="If none show on the report, it means that none of the templates on your system" S DIR("?")="needed to be edited." S DIR(0)="Y",DIR("A")="Report corrupted sort templates",DIR("B")="Yes" D ^DIR K DIR Q:Y'=1 W !!,"Searching Sort Template file...please wait",!!,"Report of templates that need to be repaired",!! F I=0:0 S I=$O(^DIBT(I)) Q:'I S X=$P($G(^(I,0)),U) D . S DIERR=0 F J=0:0 Q:DIERR=1 S J=$O(^DIBT(I,2,J)) Q:'J I $P($G(^(J,0)),U,10)=4,'$G(^("ASK")),$G(^("SRTTXT"))]"" D .. S Y=$P($G(^DIBT(I,2,J,"F")),U,2) I Y?1." "1.E S DIERR=1 Q .. S Y=$P($G(^DIBT(I,2,J,"T")),U,2) I Y?1." "1.E S DIERR=1 Q .. Q . I DIERR=1 W "No. "_I_" Name: "_X,! . Q Q DDR DDR ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:38 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q LISTC(DDRDATA,DDR) ; -- broker callback to get list data N DDRFILE,DDRIENS,DDRFLDS,DDRMAX,DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDRVAL,DDRERR,DDRRSLT,DDRFLD,DDRFLAGS,DDROPT,DDROUT ; -- parse array to parameters D PARSE(.DDR) S DDRPART=$TR(DDRPART,$C(13)_$C(10),"") ; -- get specific field criteria IF $G(DDR("DDFILE")),$G(DDR("DDFIELD")),$D(^DD(DDR("DDFILE"),DDR("DDFIELD"),12.1)) D . N DIC X ^(12.1) S:$D(DIC("S")) DDRSCRN=DIC("S") I 'XWBAPVER D V0 Q I XWBAPVER>0 D V1 Q Q ; DIC D LIST^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRMAX,.DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR") Q ; V0 S DDROUT="DDRRSLT",DDRFLAGS=$G(DDRFLAGS)_"P",DDRFLDS=$G(DDRFLDS)_";@" D DIC N Y,I,N S N=0 I $G(DDRFROM)]"" D SET("[Misc]"),SET("MORE"_U_DDRFROM_U_DDRFROM("IEN")) I $D(DDRRSLT("DILIST")) D . D SET("[Data]") . S I=0 F S I=$O(DDRRSLT("DILIST",I)) Q:'I D SET(DDRRSLT("DILIST",I,0)) IF $D(DDRERR) D SET("[Errors]") S X=$$STYPE^XWBTCPC("ARRAY") Q ; V1 S DDROUT="" I XWBAPVER=1,DDRFLAGS["P" S DDRFLAGS=DDRFLAGS_"S" ;only P flag is sent from client for V1 of FMCD D DIC I $G(DDRFLAGS)["P" D Q . I $D(^TMP("DILIST",$J)) D . . N END S END=+^TMP("DILIST",$J,0) . . I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP") . . K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(END+1)="[END_diDATA]" . D 11,31 . S DDRDATA=$NA(^TMP("DILIST",$J)) . Q I $G(DDRFLAGS)'["P" D 11,UNPACKED,31 S DDRDATA=$NA(^TMP("DILIST",$J)) Q Q 11 I $G(DDRFROM)]"" S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE"_U_DDRFROM_U_DDRFROM("IEN")_$S(XWBAPVER>1:U_$P($G(^TMP("DILIST",$J,0)),U,4),1:"") Q 31 I $D(DIERR) D ERROR Q SET(X) ; S N=N+1 S DDRDATA(N)=X Q PARSE(DDR) ; -- array parsing S DDRFILE=$G(DDR("FILE")) S DDRIENS=$G(DDR("IENS")) S DDRFLDS=$G(DDR("FIELDS")) S DDRFLAGS=$G(DDR("FLAGS")) S DDRMAX=$G(DDR("MAX"),"*") M DDRFROM=DDR("FROM") S DDRPART=$G(DDR("PART")) S DDRXREF=$G(DDR("XREF")) S DDRSCRN=$G(DDR("SCREEN")) S DDRID=$G(DDR("ID")) S DDROPT=$G(DDR("OPTIONS")) Q ERROR ; N I S I=1 D Z("[BEGIN_diERRORS]") N A S A=0 F S A=$O(DDRERR("DIERR",A)) Q:'A D . N HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS . S HD=DDRERR("DIERR",A) . I $D(DDRERR("DIERR",A,"PARAM",0)) D . . S (B,D)=0 F C=1:1 S B=$O(DDRERR("DIERR",A,"PARAM",B)) Q:B="" D . . . I B="FILE" S FILE=DDRERR("DIERR",A,"PARAM","FILE") . . . I B="FIELD" S FIELD=DDRERR("DIERR",A,"PARAM","FIELD") . . . I B="IENS" S IENS=DDRERR("DIERR",A,"PARAM","IENS") . . . S D=D+1,PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B) . S C=0 F S C=$O(DDRERR("DIERR",A,"TEXT",C)) Q:'C S TEXT(C)=DDRERR("DIERR",A,"TEXT",C),TXTCNT=C . S HD=HD_U_TXTCNT_U_$G(FILE)_U_$G(IENS)_U_$G(FIELD)_U_$G(D) D Z(HD) . S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D Z(%) . S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D Z(%) . Q D Z("[END_diERRORS]") Q Z(%) ; S ^TMP("DILIST",$J,"ZERR",I)=%,I=I+1 Q ; UNPACKED ; Q:'$D(^TMP("DILIST",$J)) N COUNT,IXCNT S COUNT=+^TMP("DILIST",$J,0) Q:'COUNT I XWBAPVER>1 S ^TMP("DILIST",$J,.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP") K ^TMP("DILIST",$J,0) S ^TMP("DILIST",$J,.5)="[BEGIN_diDATA]" I XWBAPVER=1 D IX1 D IENS,FLDS,WID,END Q IX1 I DDROPT["IX",$D(^TMP("DILIST",$J,1)) D . S ^TMP("DILIST",$J,1,COUNT+1)="END_IXVALUES" D S ^(.1)="BEGIN_IXVALUES",^(.2)=IXCNT . . N Z S Z=0,IXCNT=0 I $G(^TMP("DILIST",$J,1,1))]"" S IXCNT=1 Q . . F S Z=$O(^TMP("DILIST",$J,1,1,Z)) Q:'Z S IXCNT=IXCNT+1 I DDROPT'["IX" K ^TMP("DILIST",$J,1) Q IENS I $D(^TMP("DILIST",$J,2)) D . S ^TMP("DILIST",$J,2,.1)="BEGIN_IENs",^(COUNT+1)="END_IENs" Q FLDS I DDRFLDS]"",$D(^TMP("DILIST",$J,"ID")) D . N Z,FLD,FLDCNT S FLD="",(Z,FLDCNT,I)=0 . ;I XWBAPVER>1,DDRFLDS["IX" D . ;. F S I=$O(^TMP("DILIST",$J,"ID",1,0,I)) Q:'I S IXCNT=IXCNT+1 . ;. S ^TMP("DILIST",$J,"ID",0,0)="IXCNT="_IXCNT Q . F S Z=$O(^TMP("DILIST",$J,"ID",1,Z)) Q:'Z S FLD=FLD_Z_";",FLDCNT=FLDCNT+1 . Q:'FLDCNT . S ^TMP("DILIST",$J,"ID",0)="BEGIN_IDVALUES" . I XWBAPVER=1 S ^TMP("DILIST",$J,"ID",.1)=FLD_U_FLDCNT . S ^TMP("DILIST",$J,"ID",COUNT+1)="END_IDVALUES" E D . N Z S Z=0 F S Z=$O(^TMP("DILIST",$J,"ID",Z)) Q:'Z K ^TMP("DILIST",$J,"ID",Z) Q WID I (DDROPT["WID")!(DDRFLDS["WID"),$D(^TMP("DILIST",$J,"ID","WRITE")) D . N Z,N,I,IEN,WIDCNT S (N,I)=0 . M Z=^TMP("DILIST",$J,"ID","WRITE") K ^TMP("DILIST",$J,"ID","WRITE") . S ^TMP("DILIST",$J,"ID","WID",0)="BEGIN_WIDVALUES",N=N+1 . F S I=$O(Z(I)) Q:'I S IEN=$G(^TMP("DILIST",$J,2,I)) D . . N J S (J,WIDCNT)=0 F S J=$O(Z(I,J)) Q:'J S WIDCNT=WIDCNT+1 . . S ^TMP("DILIST",$J,"ID","WID",N)="WID"_U_IEN_U_WIDCNT,N=N+1 . . N J S J=0 F J=1:1:WIDCNT S ^TMP("DILIST",$J,"ID","WID",N)=Z(I,J),N=N+1 . S ^TMP("DILIST",$J,"ID","WID",N)="END_WIDVALUES" I (DDROPT'["WID")&(DDRFLDS'["WID") K ^TMP("DILIST",$J,"ID","WRITE") Q END S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]" Q DDR0 DDR0 ;SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:52 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q FINDC(DDRDATA,DDR) ; -- broker callback to get list data N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDRROOT,DDRERR,DDRRSLT,DDROPT,DDROUT ; -- parse array to parameters D PARSE(.DDR) S DDROUT="" D FIND^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR") I $G(DDRFLAGS)["P" D . Q:'$D(^TMP("DILIST",$J)) . N COUNT S COUNT=^TMP("DILIST",$J,0) Q:'COUNT D 1 . I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP") . K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(COUNT+1)="[END_diDATA]" . Q I $G(DDRFLAGS)'["P" D . Q:'$D(^TMP("DILIST",$J)) . N COUNT S COUNT=^TMP("DILIST",$J,0) Q:'COUNT . D 1,UNPACKED . Q D 3,4 Q 1 Q:'$P(COUNT,U,3) S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE" Q 3 I $D(DIERR) D ERROR Q 4 S DDRDATA=$NA(^TMP("DILIST",$J)) Q PARSE(DDR) ; -- array parsing S DDRFILE=$G(DDR("FILE")) S DDRIENS=$G(DDR("IENS")) S DDRFLDS=$G(DDR("FIELDS")) S DDRFLAGS=$G(DDR("FLAGS")) S DDRMAX=$G(DDR("MAX"),"*") S DDRVAL=$G(DDR("VALUE")) S DDRXREF=$G(DDR("XREF")) S DDRSCRN=$G(DDR("SCREEN")) S DDRID=$G(DDR("ID")) S DDRROOT=$G(DDR("ROOT")) S DDROPT=$G(DDR("OPTIONS")) Q ERROR ; N I S I=1 D Z("[BEGIN_diERRORS]") N A S A=0 F S A=$O(DDRERR("DIERR",A)) Q:'A D . N HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS . S HD=DDRERR("DIERR",A) . I $D(DDRERR("DIERR",A,"PARAM",0)) D . . S (B,D)=0 F C=1:1 S B=$O(DDRERR("DIERR",A,"PARAM",B)) Q:B="" D . . . I B="FILE" S FILE=DDRERR("DIERR",A,"PARAM","FILE") . . . I B="FIELD" S FIELD=DDRERR("DIERR",A,"PARAM","FIELD") . . . I B="IENS" S IENS=DDRERR("DIERR",A,"PARAM","IENS") . . . S D=D+1,PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B) . S C=0 F S C=$O(DDRERR("DIERR",A,"TEXT",C)) Q:'C S TEXT(C)=DDRERR("DIERR",A,"TEXT",C),TXTCNT=C . S HD=HD_U_TXTCNT_U_$G(FILE)_U_$G(IENS)_U_$G(FIELD)_U_$G(D) D Z(HD) . S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D Z(%) . S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D Z(%) . Q D Z("[END_diERRORS]") Q Z(%) ; S ^TMP("DILIST",$J,"ZERR",I)=%,I=I+1 Q UNPACKED ; K ^TMP("DILIST",$J,0) S ^TMP("DILIST",$J,.5)="[BEGIN_diDATA]" K ^TMP("DILIST",$J,1) S ^TMP("DILIST",$J,2,.1)="BEGIN_IENs",^(COUNT+1)="END_IENs" I DDRFLDS]"",$D(^TMP("DILIST",$J,"ID")) D . N Z,FLD,FLDCNT S Z=0,FLD="",FLDCNT=0 . F S Z=$O(^TMP("DILIST",$J,"ID",1,Z)) Q:'Z S FLD=FLD_Z_";",FLDCNT=FLDCNT+1 . Q:'FLDCNT . S ^TMP("DILIST",$J,"ID",0)="BEGIN_IDVALUES",^(.1)=FLD_U_FLDCNT,^(COUNT+1)="END_IDVALUES" E D . N Z S Z=0 F S Z=$O(^TMP("DILIST",$J,"ID",Z)) Q:'Z K ^TMP("DILIST",$J,"ID",Z) I $G(DDROPT)["WID",$D(^TMP("DILIST",$J,"ID","WRITE")) D . N Z,N,I,IEN,WIDCNT S (N,I)=0 . M Z=^TMP("DILIST",$J,"ID","WRITE") K ^TMP("DILIST",$J,"ID","WRITE") . S ^TMP("DILIST",$J,"ID","WID",0)="BEGIN_WIDVALUES",N=N+1 . F S I=$O(Z(I)) Q:'I S IEN=$G(^TMP("DILIST",$J,2,I)) D . . N J S (J,WIDCNT)=0 F S J=$O(Z(I,J)) Q:'J S WIDCNT=WIDCNT+1 . . S ^TMP("DILIST",$J,"ID","WID",N)="WID"_U_IEN_U_WIDCNT,N=N+1 . . N J S J=0 F J=1:1:WIDCNT S ^TMP("DILIST",$J,"ID","WID",N)=Z(I,J),N=N+1 . S ^TMP("DILIST",$J,"ID","WID",N)="END_WIDVALUES" I $G(DDROPT)'["WID" K ^TMP("DILIST",$J,"ID","WRITE") S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]" Q DDR1 DDR1 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/18/97 16:15 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q ; DIKC(DDROK,DDR) ; -- broker callback to kill a file entry via ^DIK N DIK,DA,FILE,IENS,FDA S FILE=$G(DDR("FILE")) S IENS=$G(DDR("IENS")) I $$FNO^DILIBF(FILE)=FILE,$L(IENS,",")=2 D Q . S DIK=$G(^DIC(FILE,0,"GL")),DA=+IENS D ^DIK S DDROK=1 S FDA(FILE,IENS,.01)="@" D FILE^DIE("","FDA") S DDROK='$G(DIERR) Q ; LOCKC(DDROK,DDR) ; -- broker callback to lock/unlock a node N DDRNODE S DDRNODE=$G(DDR("NODE")) IF DDRNODE]"" D . IF $G(DDR("LOCKMODE")) D . . L @("+"_DDRNODE_":"_$G(DDR("TIMEOUT"),5)) . . S DDROK=$T . ELSE D . . L @("-"_DDRNODE) . . S DDROK=1 ELSE D . S DDROK=0 Q ; FILENOC(DDRFLNO,DDRNAME) ; -- broker callback to get File # ; S DDRFLNO=+$O(^DIC("B",DDRNAME,"")) Q ; NODEC(DDRNODE,DDRROOT) ; -- broker callback to get global node value ; ;S DDRNODE=$G(@DDRROOT) IF $D(@DDRROOT)=0!($D(@DDRROOT)=10) D . S DDRNODE="{{"_$D(@DDRROOT)_"}}" IF $D(@DDRROOT)=1!($D(@DDRROOT)=11) D . S DDRNODE=$G(@DDRROOT) Q ; GLCNT(DDROK,DDR) ; -- extrinsic call to invoke broker to return number of ; global nodes found at cross reference N DDRNODE,DDRTEAM,DDRXREF ; S DDRNODE=$G(DDR("ROOT")) S DDRXREF=$G(DDR("XREF")) S DDRVAL=$G(DDR("VALUE")) ; S:DDRXREF="" DDRXREF="B" S I="",X=0 F S I=$O(@DDRNODE@(DDRXREF,DDRVAL,I)) Q:I="" D . S X=X+1 S DDROK=$G(X) Q ; IFNODE(DDRNODE,DDRROOT) ; -- extrinsic call to check if node exists. ; passes in full node reference N X ; IF $D(@DDRROOT)=0!($D(@DDRROOT)=10) D . S DDRNODE="{{"_$D(@DDRROOT)_"}}" IF $D(@DDRROOT)=1!($D(@DDRROOT)=11) D . S DDRNODE=$G(@DDRROOT) Q DDR2 DDR2 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/20/98 11:38 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q ; FIND1C(DDRDATA,DDR) ; DDR FIND1 rpc callback N DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,DDRERR,A,IEN,N D PARSE(.DDR) S DDRVAL=$G(DDR("VALUE")) S A=$$FIND1^DIC(DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,"DDRERR") S A=$S($G(DIERR):"",1:A) S N=0 D SET(A) I $G(DIERR) D ERROR Q I $G(DDROPT)["R" S IEN=$S($G(DDRIENS)]"":A_DDRIENS,1:A_",") D RECALL^DILFD(DDRFILE,IEN,DUZ) Q ; GETSC(DDRDATA,DDR) ; DDR GETS ENTRY DATA rpc callback N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDROPT,DDRRSLT,DDRERR N DDRXREF,DDRSCRN,N D PARSE(.DDR) D GETS^DIQ(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,"DDRRSLT","DDRERR") S N=0 I '$D(DDROPT) D 1,2 Q I $G(DDROPT)["U" D 11,21 I $G(DDROPT)["?" D HLP Q 1 I $D(DDRRSLT) D . N DDRFIELD,X,J . D SET("[Data]") . S DDRFIELD=0 F S DDRFIELD=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD)) Q:'DDRFIELD D . . ;Do not remove stripping of ',' from IENS in line below if this code should work with T11 (21.1T1) of FM components. . . S X=DDRFILE_"^"_$E(DDRIENS,1,$L(DDRIENS)-1)_"^"_DDRFIELD_"^" . . ; -- below call to $$GET1 is too slow...working w/FM team for speed . . ;IF $$GET1^DID(DDRFILE,DDRFIELD,"","TYPE")="WORD-PROCESSING" D . . ;IF $P($G(^DD(DDRFILE,DDRFIELD,0)),U,4)[";0" D <0 HLP^DDSMSG() G END^DDS0 ; PROC ;Main loop F D PG Q:DDACT="Q" Q ; PG ;Load page N DDSMX,DDSMY,DDSMOUSE,FND S DDACT="N" D ^DDS1(DDSPG) I $G(DIERR) D Q . N P S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U) . S:P(2)="" P(2)="unnamed" . D BLD^DIALOG(3041,.P),ERR^DDSMSG H 2 . S DDACT="Q" ; ;Pre-action, save old and get next page S DDSOPB=DDSPG I $G(^DIST(.403,+DDS,40,DDSPG,11))'?."^" D PA(^(11)) Q:DDACT="NP" S DDSNP=$$NP^DDS5(.Y) S:'Y DDSNP="" ; ;Get DDO and DDSBK I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D . S DDO=+$G(@DDSREFS@(DDSPG,"FIRST")),DDSBK=$P($G(^("FIRST")),",",2) I 'DDSBK D Q . D BLD^DIALOG(3055,"number "_$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U)_$S($G(^(1))]"":" ("_$P($G(^(1)),U)_")",1:"")) . D ERR^DDSMSG H 2 . S DDACT="Q" ; ;Get DDSPOP and update DDSSC array ;If we're going to another page I '$D(DDSPGUP) D . S DDSLN=^DIST(.403,+DDS,40,DDSPG,0),DDSPOP=$P(DDSLN,U,6) . K:'DDSPOP DDSSC SEL . I $D(DDSSEL),+$G(^DIST(.403,+DDS,21))=DDSPG D ;IF IT'S (REALLY) A RECORD SELECTION PAGE FORGET DA .. S DDSDASV=DDSDA,DDSDLSV=DDSDL .. M DDSORGSV=DDSDAORG .. K DA,@$$D0(DDSDL),DDSDAORG .. S (DA,D0,DDSDAORG)="",DDSDA="0,",DDSDL=0 . I '$D(DDSSC("B",DDSPG)) D .. S DDSSC=$G(DDSSC)+1,DDSSC(DDSSC)=DDSPG,DDSSC("B",DDSPG,DDSSC)="" .. S:DDSPOP $P(DDSSC(DDSSC),U,2,3)=$P(DDSLN,U,3)_U_$P(DDSLN,U,7) .. I $G(DDSSTK) S $P(DDSSC(DDSSC),U,4)=1 K DDSSTK .. K DDSPOP . E D .. Q:$P($G(DDSSC(+$G(DDSSC))),U)=DDSPG .. N I,J,S .. S I=$O(DDSSC("B",DDSPG,"")),S=DDSSC(I) K DDSSC("B",DDSPG,I) .. F J=I:1:DDSSC-1 D ... K DDSSC("B",$P(DDSSC(J+1),U),J) ... S DDSSC(J)=DDSSC(J+1),DDSSC("B",$P(DDSSC(J),U),J)="" .. S DDSSC(DDSSC)=S,DDSSC("B",DDSPG,DDSSC)="" ; ;If we've moving up from a pop-up page E K DDSPGUP ; ;Paint the page D RP^DDSR(DDSSC(DDSSC),DDSSC=1) ; P1 F D BLK Q:"^Q^NP^"[(U_DDACT_U) ; ;PAGE Post action, print any help D:$G(^DIST(.403,+DDS,40,+DDSOPB,12))'?."^" PA(^(12)) D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG() G:"^NB^N^"[(U_DDACT_U) P1 ; I DDACT="Q" D . I '$P(DDSSC(DDSSC),U,4) D .. I $G(DDSSEL) D GDA^DDSRSEL Q:'DA ;Do the RECORD SELECTION Page, if there is one .. D:$G(DDSSC)>1 CLEAR^DDSBOX($P(DDSSC(DDSSC),U,2),$P(DDSSC(DDSSC),U,3)) .. S:DDSSC>1 DDSPG=$P(DDSSC(DDSSC-1),U),DDACT="N",DDSPGUP=1 . K DDSSC("B",$P(DDSSC(DDSSC),U),DDSSC),DDSSC(DDSSC) S DDSSC=DDSSC-1 Q ; BLK S DDACT="N",DDSOSV=0 ; I $D(@DDSREFS@(DDSPG,DDSBK))[0 S DDACT="Q" Q S DDSLN=@DDSREFS@(DDSPG,DDSBK) ; S DDSDN=$P(DDSLN,U,4),DDSTP=$P(DDSLN,U,5) S DDSREP=$P(DDSLN,U,7),DDSPTB=$P(DDSLN,U,8) K:'DDSDN DDSDN K:DDSTP="e" DDSTP K:'DDSPTB DDSPTB K:DDSREP'>1 DDSREP ; I $D(DDSPTB)!$D(DDSREP) N DDP,DDSDA,DIE D ;NEW WHEN WE GO INTO MULTIPLE!! . S DDP=$P(DDSLN,U,3) DIE . S DDSDA=$P(@DDSREFT@(DDSPG,DDSBK),U) I DDSDA'>0,$G(^(DDSBK,"COMP MUL"))="" S DIE=$G(DIE) Q ;Get Entry Number . S DIE=@DDSREFT@(DDSPG,DDSBK,DDSDA,"GL") ; I $D(DDSPTB) N DA,@$$D0(DDSDL),DDSDL D . S DDSPTB=@DDSREFS@(DDSPG,DDSBK,"PTB") . S DDSDL=$L(DDSDA,",")-2 . S (D0,DA)=+DDSDA ; I $D(DDSREP) N DDSDL,DA D . S DDSREP=$P(@DDSREFT@(DDSPG,DDSBK,DDSDA),U,2,999) . S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,$P(DDSREP,U),$P(DDSREP,U,4)),"0,"_DDSDA) ;2-arg $G -- go to empty line if none other specified . S:'$P(DDSREP,U,7) DDSDA=$P(DDSDA,",")_"," . S DDSDL=$L(DDSDA,",")-2 I N @$$D0(DDSDL) D . D BLDDA(DDSDA) . S:'DA DDO=+$P(DDSREP,U,8) ;If this is a new subEntry, start at 1st editable field ; PTB I $D(DDSPTB),'$D(DDSREP),'DDSDA,DDSDAORG D Q . N DDSBK0 . S DDSBK0=DDSBK . F S DDSBK=$$NB^DDS5(.Y) Q:DDSBK=DDSBK0!'Y!$G(@DDSREFT@(DDSPG,DDSBK)) . Q:Y . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" Q . S DDSPG=$$PP^DDS5(.Y) I Y S DDACT="NP" Q . S DDACT="Q" ; S $P(DDSOPB,U,2)=DDSBK I $G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP" I $G(^DIST(.404,DDSBK,11))'?."^" D PA(^(11)) Q:DDACT="NP" 1 I $S($D(DDSBR)[0:1,1:$D(@DDSREFS@(DDSPG,$S(DDO:+DDSBK,1:0),DDO,"N"))[0) D . S DDO=$P(@DDSREFS@(DDSPG,DDSBK),U,9) ;First field K DDSLN ; B1 D ^DDS01 ; I $G(^DIST(.403,+DDS,40,DDSPG,40,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1 I $G(^DIST(.404,$P(DDSOPB,U,2),12))'?."^" D PA(^(12)) G:DDACT="N" B1 Q ; BLDDA(DDSDA) ; N I S (DA,@("D"_DDSDL))=$P(DDSDA,",") F I=1:1:DDSDL S (DA(I),@("D"_(DDSDL-I)))=$P(DDSDA,",",I+1) Q ; D0(DL) ;Given DL, return string D0,D1,...,Dn N I,S S S="" F I=0:1:DL S S=S_"D"_I_"," S:S?.E1"," S=$E(S,1,$L(S)-1) Q S ; CLRMSG ; I $G(DDSKM) H 2 K DDSKM ;GFT ** IF WE WERE KEEPING SOMETHING IN HELP AREA, HOLD UP 2 SECONDS ISB-0603-31054 K DDQ S DDSH=1,(DDM,DX)=0,DY=DDSHBX+1 X DDXY W $P(DDGLCLR,DDGLDEL,3) ;CLEAR WHOLE COMMAND AREA N I F S I=$O(DDSMOUSE(DDSHBX)) Q:I+1=IOSL!'I K DDSMOUSE(I) Q ; PA(DDSPA) ; N DDSBRORG S:$D(DDSBR)#2 DDSBRORG=DDSBR K DDSBR X DDSPA ;PRE-ACTION OR POST-ACTION I $D(DDSBR)[0 S:$D(DDSBRORG)#2 DDSBR=DDSBRORG Q D BR^DDS2 Q ; ; ; ; ; ; RESET ;Programmer entry point to reset terminal and cleanup D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW") W $P($G(DDGLVID),DDGLDEL,10) K DDSPARM S DDSREFT="^TMP(""DDS"",$J)" D END^DDS0 G RESET^DDGF ; RUN ;Run a form G ^DDSRUN CLONE ;Clone a form G ^DDSCLONE PRINT ;Print a form G ^DDSPRNT DFRM ;Delete a form G ^DDSDFRM DBLK ;Delete unused blocks G ^DDSDBLK DDS0 DDS0 ;SFISC/MLH-SETUP, CLEANUP ;24FEB2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; EN(DDSFILE,DR,DA) ;Initial setup S U="^" D INIT^DDGLIB0() Q:$G(DIERR) D FORM(.DDSFILE,DR) Q:$G(DIERR) ; ;Compile the form if not already compiled S DDSREFS=$$REF(DDS) I '$$COMPILED(DDS) D EN^DDSZ(DDS) Q:$G(DIERR) N:$P(^DIST(.403,+DDS,0),U,10) DA ; D FRSTPG(DDS,.DA,$G(DDSPAGE)) Q:$G(DIERR) D REC(DDP,.DA) Q:$G(DIERR) D INIT Q ; FORM(DDSFILE,DR) ;Form lookup ;Output: ; DDS = Form number^Form name ; DDP = File number (or 0) ; DDSPG = First page to go to on form ; DIERR ; I $D(DDSFILE)[0 D BLD^DIALOG(201,"DDSFILE") Q ; N DIC,X,Y ; S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2)) S X=$S(DR:DR,1:$P($P(DR,"[",2),"]")) S DIC="^DIST(.403,",DIC(0)="FNX",D="F"_DDP D IX^DIC K DIC ; I Y<0 D BLD^DIALOG(3021,X) Q I '$O(^DIST(.403,+Y,40,"B","")) D BLD^DIALOG(3022,X) Q S DDS=Y ; I $D(DDSFILE(1))#2 S DDP=$S(DDSFILE(1)=+DDSFILE(1):DDSFILE(1),1:+$P($G(@(DDSFILE(1)_"0)")),U,2)) Q ; FRSTPG(DDS,DA,DDSPAGE) ;Get first page of form ;Output: ; DDSPG ; DDSSEL = 1, if DA is null and there is a record selection page ; DIERR ; N P I $G(DA)!$P(^DIST(.403,+DDS,0),U,10) D . S P=$S($G(DDSPAGE):DDSPAGE,1:1) . S DDSPG=$O(^DIST(.403,+DDS,40,"B",P,"")) . I $D(^DIST(.403,+DDS,40,+DDSPG,0))[0 D BLD^DIALOG(3023,"number "_P) E D PG^DDSRSEL D:'$G(DDSSEL) BLD^DIALOG(202,"record") Q ; REC(DDP,DA) ;Check record and lock ;Output: ; DIE = Global root ; DDSDA = DA,DA(1),..., ; DDSDAORG = Original DA array ; DDSDL = Level number (top=0) ; DDSDLORG = Original level number ; DDSFLORG = Orig DDP^Orig DIE ; D0,D1,etc. ; DIERR ; I '$G(DA) D Q . S DIE="",(DDSDL,DDSDLORG)=0,DDSDA="0," . S DA="",DDSDAORG=DA ; D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,'$P(^DIST(.403,+DDS,0),U,9)) Q:$G(DIERR) ;Don't LOCK record if screen is DISPLAY-ONLY ; I $D(DIOVRD)[0 D Q:$G(DIERR) . N DDSTOP S DDSTOP=$$FNO^DILIBF(DDP) . Q:$P($G(^DD(DDSTOP,0,"DI")),U,2)'["Y" EGP . N P S P("FILE")=$$FILENAME^DIALOGZ(DDSTOP) ;**CCO/NI RESTRICTED FILE NAME . D BLD^DIALOG(405,DDSTOP,.P) ; S DDSDLORG=DDSDL K DDSDAORG S (DDSDAORG,@("D"_DDSDL))=DA F DDSI=1:1:DDSDL S (DDSDAORG(DDSI),@("D"_(DDSDL-DDSI)))=DA(DDSI) S DDSFLORG=$G(DDP)_$G(DIE) K DDSI Q ; INIT ;Initialize some variables ; DDSHBX = $Y of first line of help area ; DDSREFT = Global reference of temporary global location ; DDSFDO = 1 if entire form is display-only ; DDSCHG = Change flag ; DDSKM = Flag to keep whatever's in help area ; DDSH = Flag to indicate help area is empty ; DDSSC = Array to indicate what pages are on the screen ; DDSHBX S DDSHBX=17 I $G(DDS),$G(DDSPG),$D(DDSREFS) D .N % S %=$O(@DDSREFS@("X",DDSPG,""),-1)+1 I %>DDSHBX S DDSHBX=% ;LAST FIELD CAPTION .F DDH=0:0 S DDH=$O(@DDSREFS@(DDSPG,DDH)) Q:'DDH I $G(^(DDH)) S %=$P(^(DDH),U,7)+^(DDH) I %>DDSHBX S DDSHBX=% S DDXY=IOXY_" S $X=DX,$Y=DY" ; K DDH,DDSSC,DDSCHANG,DDSSAVE S DDSH=1,(DDH,DDM,DDSCHG,DDSSC)=0,DDACT="N" DDSREFT S DDSREFT=$NA(^TMP("DDS",$J,+DDS)) ;GFT K @DDSREFT MOUSEON I $G(DDS)>0 W *27,"[?1000h" N %,%H,%I,X D NOW^%DTC S $P(^DIST(.403,+DDS,0),U,6)=$E(%,1,12) Q ; END I $D(DDSHBX) S DX=0,DY=IOSL-1 X IOXY D KILL^DDGLIB0($G(DDSPARM)) ; D:$D(^TMP("DDS",$J,"LOCK")) UNLOCK ; K:'$G(DA) DA I $D(DA),$D(DDSDAORG)#2,$D(DDSDLORG)#2 D . K DA,D0 . S DA=DDSDAORG . F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI) K @("D"_DDSI) MOUSEOFF W *27,"[?1000l" K:$G(DDSPARM)'["E" DIERR,^TMP("DIERR",$J) K:$D(DDSREFT)#2 @DDSREFT,DDSREFT K ^TMP("DDSH",$J),^TMP("DDSWP",$J) K DDACT,DDH,DDM,DDO,DDP,DDQ,DDS,DDSDDP K DDSBK,DDSBR,DDSCHG,DDSDA,DDSDAORG,DDSDL K DDSDLORG,DDSDN,DDSEXT,DDSFDO,DDSFLD,DDSFLORG,DDSGL,DDSH,DDSI K DDSKM,DDSLN,DDSNP,DDSO,DDSOLD,DDSORD,DDSOPB,DDSOSV,DDSPTB,DDSPG K DDSPX,DDSPY,DDSQ,DDSREP,DDSSC,DDSSP,DDSSTACK,DDSTP,DDSU,DDSX K DDSHBX,DDSREFS,DDXY K DIC,DIR,DIR0N,DIROUT,DIRUT,DUOUT,DY,DX K A1,D,DDC,DDD,DI,DIEQ,DIK,DIW,DIY,DIZ,DS Q ; UNLOCK ;Unlock any lock records N I S I="" F S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I="" L -@I K ^TMP("DDS",$J,"LOCK") Q ; COMPILED(DDS) ;Return 1 if form is compiled Q $D(@$$REF(DDS))>0 ; REF(DDS) ;Return global reference for compiled global Q $NA(^DIST(.403,+DDS,"AY")) ; OLDREF(DDS) ;Return global reference for compiled global used prior ;to version 22.0 Q $NA(^DIST(.403,+DDS,"AZ")) ; IXF ; N D0,DA,DIC,DP,Y S DIC="^DD("_DDGFDD_",",DIC(0)="EN" D ^DIC I Y'>0 K X E S X=+$P(Y,"E") Q DDS01 DDS01 ;SFISC/MLH,MKO-PROCESS BLOCK ;24JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;***BE CAREFUL PUTTING TAGS INTO THIS IMPORTANT ROUTINE! $T LOOKS FOR A NON-EXISTENCE OF A TAG!**** ; F D IN,CHK Q:"^Q^NB^NP^"[(U_DDACT_U) Q ; IN K DDSBR,DDSFLD,DDSO,DDSU,DIR,DDSREPNT S:$D(@DDSREFS@(DDSPG,$S(DDO:DDSBK,1:0),DDO,"N"))#2 DDSU("N")=^("N") I DDM,'$G(DDSKM) D CLRMSG^DDS G:'DDO COM^DDSCOM ; S DDSOSV=0 F DDSI=0,1,2,4,7,10:1:14,20 D ;MOVE FIELD DEFINITION INTO DDSO ARRAY . S:$D(^DIST(.404,DDSBK,40,DDO,DDSI))#2 DDSO(DDSI)=^(DDSI) K DDSI ; S DDSFLD=$G(DDSO(1)) K DDSO(1) I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,DDSFLD=DDO_","_DDSBK ; I DDSFLD]"",DDSDA]"" M DDSU=@DDSREFT@("F"_DDP,DDSDA,DDSFLD) ;Restore field's specs & value from ^TMP ; I '$D(DDSREP)!DDSDA,$$UNED($G(DDSU("A")),$G(DDSO(4)),$G(DDSU("N"))) D Q . I $D(DDSACT)#2 S DDACT=DDSACT K DDSACT . S:DDACT="U" DDACT="L" . S:DDACT="D" DDACT="R" . D CURSOR Q:$D(DDSBR)#2 . S DDSCHKQ=1 K DDSACT ; S (X,DDSOLD)=$G(DDSU("D")),DDSEXT=$G(DDSU("X"),X) ; X:$G(DDSO(11))'?."^" DDSO(11) ;PRE-ACTION I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2 I DDACT]"",$T(@DDACT)]"" D @DDACT S DDSCHKQ=1 Q ; S DIR0N=1 Q:DDSFLD="" ; S:$G(^DD(DDP,DDSFLD,0))'?."^" DDSU("DD")=^(0) I $D(DDSU("N"))[0 S DDACT="N" Q Q:$D(DDSO(2))[0 ; D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG() K DDSKM,DDQ ; S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3) S:$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,10) $P(DIR0,U,6)=1 HITE S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+($P(DDSREP,U,3)-1*$$HITE^DDSR(DDSBK)) ;DJW/GFT ; I $D(DDSREP),'DDSDA,$P(DDSO(0),U,3)'=2 K DDSU("DD") G SEL^DDSM I $D(DDSU("M"))#2 S DDSGL=U_$P(DDSU("M"),U,2) G:'DDSU("M") WP^DDSWP S DIR("B")=$G(DDSU("X"),DDSOLD) ; I $D(DDSU("M"))#2 D SEL^DDS5 G:X'=DDSOLD&(DDACT="N") EXT I $P($G(DDSO(0)),U,3)'=2 S DIR(0)=DDP_","_DDSFLD_"O" ;IT'S A FIELD-TYPE READ E D DIR^DDSFO D ^DIR K DIR,DUOUT,DIRUT,DIROUT ;DO THE READ! I DIR0N S (X,Y)=DDSOLD Q ; EXT I $E(X)=U!$D(DTOUT) S DIR0N=1 Q G EXT^DDS02 ; CHK Q:$D(DDSBR)#2 I $G(DDSCHKQ)=1 K DDSCHKQ Q G:$D(DTOUT) TO^DDS3 G:$E(X)=U UPA^DDS2 I $G(DDSFLD)=.01,X="",$G(DA),DDSOLD]"" G ^DDS6 ;DELETE ENTRY ; I $P($G(DDSU("DD")),U,2)["I",$G(DDSOLD)]"" D I %]"",X'=% S DDSNOED=1 ;UNEDITABLE FIELD ALREADY HAS A VALUE .N DIERR S %=$$GET1^DIQ(DDSFILE,DDSDA,DDSFLD) E I $P($G(DDSU("DD")),U,5,99)["DINUM" S DDSNOED=1 E S DDSNOED=$S($P($G(DDSU("A")),U,4)="":$P($G(DDSO(4)),U,4),1:$P($G(DDSU("A")),U,4)) ;FIELD 6.4 ('DISABLE EDITING') IN THE FIELD MULTIPLE I $G(DDSFLD)]"",$G(DDSOLD)]"",X'=DDSOLD,DDSNOED S %=1 D I %["," S DDSDA=% D POSDA^DDSM(DDSDA,DDSOLD) K DDSCHKQ Q .N F,L .I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0,F="" F S F=$O(@DDSREFT@("F0",F)) Q:F="" D Q:%["," ..S L="" F S L=$O(@DDSREFT@("F0",F,L)) Q:L="" I +L=DDO,$P(L,",",2)=DDSBK,$P($G(@DDSREFT@("F0",F,L,"O")),X)="" S %=F Q ;FIND A MATCHING FORM-ONLY VALUE .I %'["," S F="" F S F=$O(@DDSREFT@("F"_DDP,F)) Q:F="" D Q:%["," ..I F'=DDSDA S L=$G(@DDSREFT@("F"_DDP,F,DDSFLD,"D")) I L]"",$P(L,X)="" S %=F ;FIND A MATCHING FIELD VALUE .S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X") . I 'DIR0N,$G(DDSFLD),$D(DDSU("M"))[0,$G(DDSCHKQ)'=2,DDSNOED D K DDSNOED Q ;User tried to change uneditable field (was UNED^DDS02) .S %=$P($G(DDSO(0)),U,2) I %="" S %=$P($G(DDSO(0)),U,5) ;GET CAPTION or UNIQUE NAME .D MSG^DDSMSG($$EZBLD^DIALOG(3090,%),1) ;'UNEDITABLE' .I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0 .S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X") ; K DDSCHKQ,DDSNOED ; I $G(DDSFLD)=.01,$G(DDSPTB)]"",$G(DDSREP)<2,'DIR0N D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA) I $G(DDSO(12))'?."^" X DDSO(12) ;POST ACTION ; I 'DIR0N,DDO,$G(DDSFLD)]"" D . I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0 . S DDSCHG=1 . I DDSDA!'$D(DDSREP),+$G(DDSU("F"))'=1 S $P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"F"),U)=1 . I $G(DDSO(13))'?."^" X DDSO(13) ;POST ACTION ON CHANGE . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG) . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG) ; I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2 Q:DDACT="" I $T(@DDACT)]"" G @DDACT I 'DDO G:X]"" ^DDS3 S DDSO(0)=0 I DDACT="D",$D(DDSREP),'DA S DDACT="N" ;GFT DON'T DOWN-ARROW THRU A MULTIPLE THAT HAS NO .01 FIELD DEFINED G:"^U^D^R^L^"[(U_DDACT_U) CURSOR G:$D(DDSU("M"))[0 NF G:DDSU("M") ^DDS5 D EDIT^DDSWP I '$D(DDGLCLR) S DDACT="Q" Q D R^DDSR ; NF I 'DDO,DDSOSV S DDO=DDSOSV Q ; I DDO,$S($D(DDSREP):DDSDA,1:1) D . D:'$D(DDSU("M")) .. I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDSSTACK="`"_^(DDO) ;ANOTHER PAGE HAS THIS FIELD AS ITS PARENT FIELD! .. E I $P($G(DDSO(7)),U,2)]"" S DDSSTACK=$P(DDSO(7),U,2) ;OR THERE IS A SUBPAGE LINK FROM THIS FIELD . X:$G(DDSO(10))'?."^" DDSO(10) ;BRANCHING LOGIC ; I $D(DDSSTACK) D:$G(^DIST(.403,+DDS,21400)) REFRESH^DDS02(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSU ;WE DO A WHOLE RECURSION TO THE SUBPAGE, AND THEN REPAINT THIS PAGE I $D(DDSBR)#2 D BR^DDS2 Q:$D(DDSBR)#2 S DDACT="N" ; CURSOR N ACT,B,BLK,BLK0,FND,N,REP K DDSACT S:$D(DDSU("N"))[0 DDSU("N")=$G(@DDSREFS@(DDSPG,DDSBK,DDO,"N")) S FND=0 I $D(DDSREP),DDO D MNAV^DDSM(.FND) Q:FND ; S B=U,(BLK,BLK0)=DDSBK,N=DDSU("N"),ACT=$S(DDO&$G(DDSDN):"N",1:DDACT) F D Q:FND!$D(REP) . S DDO=$P(N,U,$L($P("U^D^R^L^N",ACT),U)) . I 'DDO S (DDO,DDSBK)=0,FND=1 Q . ; . S DDSBK=$P(DDO,",",2),DDO=+DDO . I DDSBK D Q:$D(REP) .. I $P($G(@DDSREFS@(DDSPG,DDSBK)),U,4) D ... S DDO=$P($G(@DDSREFS@(DDSPG,DDSBK)),U,9),ACT="N" .. E S ACT=DDACT .. I '$P($G(@DDSREFT@(DDSPG,DDSBK)),U),DDSDAORG S B=B_DDSBK_U .. E I $P(@DDSREFS@(DDSPG,DDSBK),U,7)>1 S REP=1,DDACT="NB",DDSBR="" . E S DDSBK=BLK . ; . I B'[(U_DDSBK_U) S FND=1 S:DDSBK'=BLK0 DDACT="NB",DDSBR="",DDSACT=ACT . ; . S:'FND N=$G(@DDSREFS@(DDSPG,DDSBK,+DDO,"N")),BLK=DDSBK Q ; NP ;; G:$D(DDSREP)&DDO PGDN^DDSM ;If in REPEATING BLOCK S:DDSNP]"" DDSPG=DDSNP S:DDSNP="" DDACT="N" Q PP ;; G:$D(DDSREP)&DDO PGUP^DDSM ;If in REPEATING BLOCK S DDSPG=$$PP^DDS5(.Y) S DDACT=$S(Y=1:"NP",1:"N") Q NB ;; S DDSBK=$$NB^DDS5(.Y),DDACT=$S(Y=1:"NB",1:"N") Q SEL ;; ;I $G(DDSSEL) W $C(7) Q S DDACT="N" G PG^DDSRSEL SV ;; G SV^DDS02 QT ;; G QT^DDS3 EX ;; G EX^DDS3 CL ;; G CL^DDS3 MOUSE ;; G MOUSE^DDS2 PRNT ;; D EN^DDSRP(+DDS,DDSPG) RF ;; S DDACT="N" I $G(^DIST(.403,+DDS,21400)) D REFRESH^DDS02(DDSPG) ;RE-DO THE DATA BEFORE REFRESHING PAGE G R^DDSR ; ; UNED(ATT,DEF,N) ; Q $S(N="":1,$P(ATT,U,4)="":$P(DEF,U,4)=1,1:$P(ATT,U,4)=1)&'$P(N,U,11) DDS02 DDS02 ;SFISC/MKO-OVERFLOW FROM ^DDS01 ;29MAR2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. REFRESH(DDSPG) ;Refreshes the setup for page N B,D,I,DIE,DDSDA,DDP F B=0:0 S B=$O(@DDSREFT@(DDSPG,B)) Q:'B D .I '$D(DDSDA) S DDSDA=^(B),DIE=^(B,DDSDA,"GL"),DDP=$P(@DDSREFS@(DDSPG,B),U,3) ;GET THE ORIGINAL PAGE DATA .S D="" F S D=$O(@DDSREFT@(DDSPG,B,D)) Q:D="" I +$G(^(D))=1 S $P(^(D),U)=0 ;REMEMBER TO RELOAD BLOCKS ON THIS PAGE! .S I="" F S I=$O(@DDSREFT@("F0",I)) Q:I="" F S D=$O(@DDSREFT@("F0",I,D)) Q:D="" I $P(D,",",2)=B,$G(^(D,"F"))=3 K @DDSREFT@("F0",I,D) ;KILL OLD FORM-ONLY VALUE I $D(D) D ^DDS1(DDSPG) Q ; ; ; SV ;Save S DDACT="N" I $G(DDSDN)=1,DDO D ERR3^DDS3 Q I DDSSC'>1,'$P(DDSSC(DDSSC),U,4) D S^DDS3 Q ;INCLUDED '$G(DDSSEL) D MSG^DDSMSG($$EZBLD^DIALOG(3093),1) ;**CANNOT SAVE Q ; EXT ;Process external form I '$P($G(DDSU("DD")),U,2),$P($G(DDSU("DD")),U,2)["P" D PT I $P($G(DDSO(0)),U,3)=2,$E($P($G(DDSO(20)),U))="P" D PTFO ; S:DDSOLD=Y DIR0N=1 S DDSX=X,DDSY=Y I Y]"",$P($G(DDSU("DD")),U,2)["O",$G(^DD(DDP,DDSFLD,2))'?."^" K Y(0) X ^(2) S Y(0)=Y ; S DDSEXT=$G(Y(0,0),$G(Y(0),Y)),X=DDSY ; I $D(DDSO(14)) K DDSERROR X DDSO(14) I $D(DDSERROR)#2 D Q . K DDSERROR,DDSY S DIR0("L")=DDSEXT,DDSCHKQ=1 ; I DDSY="",DDSFLD'=.01 D Q:'$D(DDSY) . N DDSREQ,DDSKEY . S DDSREQ=$P($G(DDSU("A")),U) . S:DDSREQ="" DDSREQ=$P($G(DDSO(4)),U) . S:DDSREQ="" DDSREQ=$P($G(DDSU("DD")),U,2)["R" . S DDSKEY=$D(^DD("KEY","F",DDP,DDSFLD))>0 . I 'DDSREQ,'DDSKEY Q . K DDSY . S DDSCHKQ=1,DIR0("L")=DDSEXT . D MSG^DDSMSG($$EZBLD^DIALOG($S(DDSKEY:3092.2,1:3092.1)),1) ;'REQUIRED KEY FIELD' ; S DY=$P(DIR0,U),DX=$P(DIR0,U,2) REPNT I DDSEXT'=DDSX!$G(DDSREPNT) D K DDSREPNT ;WRITE OUT NEW VALUE, IF IT DIFFERS FROM WHAT WAS INPUT . X IOXY . S DDSX=$E(DDSEXT,1,$P(DIR0,U,3)) . I '$P(DIR0,U,6) S DDSX=DDSX_$J("",$P(DIR0,U,3)-$L(DDSEXT)) . E S DDSX=$J("",$P(DIR0,U,3)-$L(DDSEXT))_DDSX . W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10) ; CHECKEY I $G(DDSU("K")),DDSY]""!(DDSFLD'=.01) D Q:'$D(DDSY) ;CHECK KEY . N DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS . D LOADXREF^DIKC1(DDP,"","",DDSU("K"),$NA(@DDSREFT@("F"))_"_","DDSFXR") . S:$D(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2 DDSVSV=^("D") S ^("D")=DDSY . S DDSUNIQ=1,DDSUI=0 . F S DDSUI=$O(DDSFXR(DDP,DDSUI)) Q:'DDSUI D Q:'DDSUNIQ .. S DIIENS=DDSDA .. D SETXARR^DIKC(DDP,DDSUI,"DDSFXR","","D") .. S DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR") . I 'DDSUNIQ D .. K DDSY .. S DDSCHKQ=1,DIR0("L")=DDSEXT .. D MSG^DDSMSG($$EZBLD^DIALOG(3094),1) ;"Another Entry already exists with this KEY value." .. K @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D") S:$D(DDSVSV)#2 ^("D")=DDSVSV ; D:$G(DDSDA)!'$D(DDSREP) . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY I DDSY="",$D(DDSU("X")) S ^("X")="" ;CHANGE THE DATA! K DDSY Q ; DEC(FILE,FIELD,DEC) ;NOT USED (??) S DEC="S X=$G(@DDSREFT@(""F"_FILE_""",DIIENS,"_FIELD_",""D""),"_$E(DEC,5,999)_")" Q ; PT ;Modify Y for pointer type fields I $P(Y,U,3)=1 D . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_U_$P(DDSU("DD"),U,3) S Y=$P(Y,U) Q ; PTFO ;Modify Y for pointer type form only fields I $P(Y,U,3)=1 D . N R,I S R="" . F I=1:1 Q:$D(DA(I))[0 S R=R_DA(I)_"," . S ^("ADD")=$G(@DDSREFT@("ADD"))+1,@DDSREFT@("ADD",@DDSREFT@("ADD"))=+Y_","_R_$S($P(DDSO(20),U,3):^DIC(+$P(DDSO(20),U,3),0,"GL"),1:U_$P($P(DDSO(20),U,3),":")) S Y=$S(Y=-1:"",1:$P(Y,U)) Q DDS1 DDS1(DDSPG) ;SFISC/MKO-LOAD PAGE ;31MAY2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;Input: ; DDS = Form number^Form name ; DDSPG = Internal page number ; DA = Record array ; DDSREFT = Global location where data (temporarily) is stored ; DDP = Primary file number of form ; DIE = Global root of form ; DDSDA = DA,DA(1),... of form ; DDSDL = Level number ;Also needed for pointed-to blocks: ; DDSDAORG ; DDSDLORG ;Returns: ; DIERR ; N DDS1B,DDS1BO K DDSMOUSE S U="^" ; ;Get header block S DDS1B=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,2) I DDS1B]"" D BLK(DDSPG,DDS1B,"",1) G:$G(DIERR) END ; ;Get all other blocks on page S DDS1BO="" F S DDS1BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",DDS1BO)) Q:DDS1BO="" S DDS1B=$O(^(DDS1BO,0)) Q:'DDS1B D BLK(DDSPG,DDS1B,DDS1BO) G:$G(DIERR) END ; END K DDSMOUSE Q ; BLK(DDSPG,DDS1B,DDS1BO,DDS1H,DDS1E) ;Load block ;In: DDS1H = 1 if a header block ; DDS1E = 1 if we're loading up a pointed-to block and ; we want interactive dialog (DIC(0)["E") in the lookup ; I $D(^DIST(.404,DDS1B,0))[0 D BLD^DIALOG(3051,"#"_DDS1B) Q ; N DDS1PTB,DDS1REP S DDS1PTB="" I '$G(DDS1H) D . S DDS1PTB=$G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,1)),DDS1REP=$G(^(2)) . K:DDS1REP<2 DDS1REP ; I DDS1PTB]"" N @$$D0(DDSDL),DA,DDP,DIE,DDSDL,DDSDA D Q:$G(DIERR) . I $G(DDS1REP)>1 D .. D BK^DDS10(.DDS1B,.DDP) Q:$G(DIERR) .. D GDA^DDS10(DDS1B,$G(DDS1E),.DA) Q:$G(DIERR) .. S DDP=$G(^DD(DDP,0,"UP"),DDP) ;GFT .. D GL^DDS10(DDP,.DA,.DIE,.DDSDL,.DDSDA,1) .. D GETD0(.DA,DDSDL) . E D .. D SET^DDS10(DDS1B,$G(DDS1E),.DA,.DDP,.DIE,.DDSDL,.DDSDA) ;GO GET THE NEW 'DA' VALUE .. I +$G(DIERR)=1,$G(^TMP("DIERR",$J,1))=601 D Q ... L -@(DIE_DA_")") ... K ^TMP("DDS",$J,"LOCK",DIE_DA_")") ... D CLEAN^DILF ... S (DA,D0,DDSDA)="" .. Q:$G(DIERR) .. I DA="",'$G(DDS1E),$P($G(@DDSREFT@(DDSPG,DDS1B)),U)]"" S DDSDA=$P(^(DDS1B),U),DA=+DDSDA .. S D0=DA ; I $G(DA)!'$G(DDSDAORG),$G(@DDSREFT@(DDSPG,DDS1B,DDSDA))<1 D . S $P(@DDSREFT@(DDSPG,DDS1B,DDSDA),U)=1 . I $G(DDS1REP)>1 D REP Q . ; . S @DDSREFT@(DDSPG,DDS1B,DDSDA,"GL")=DIE . D ^DDS11(DDS1B) ; S $P(@DDSREFT@(DDSPG,DDS1B),U)=$G(DDSDA) Q ; REP ;Load data for repeating block N DDS1DDP,DDS1IND,DDS1INI,DDS1MUL,DDS1PDA,DDS1REF,DDS1RT,DDS1SEL N DDS1SN,DDS1VAL,DDS1FSCR,DDS1SCNT,DDS1STRT,DDS1Q,DDS1ACT S DDS1REF=$NA(@DDSREFT@(DDSPG,DDS1B)) S DDS1DDP=$P(@DDSREFS@(DDSPG,DDS1B),U,3) S DDS1IND=$P(DDS1REP,U,2) S:DDS1IND="" DDS1IND="B" S DDS1INI=$P(DDS1REP,U,3) S DDS1SEL=$P(@DDSREFS@(DDSPG,DDS1B),U,10) S DDS1PDA=DDSDA ; S DDS1MUL=$O(^DD(+DDP,"SB",DDS1DDP,"")) S:$G(^DD(DDS1DDP,0,"SCR"))]"" DDS1FSCR=^("SCR") ACT S:$G(^("ACT"))]"" DDS1ACT=^("ACT") ; S $P(@DDS1REF@(DDS1PDA),U,7,10)=DDP_U_DDS1MUL_U_DDS1SEL_U_DDS1IND S @DDS1REF@(DDSDA,"GL")=$S(DDS1MUL:DIE_+DA_","""_$P($P(^DD(DDP,DDS1MUL,0),U,4),";")_""",",1:^DIC(DDS1DDP,0,"GL")) ; N DIE,DDP S DIE=@DDS1REF@(DDSDA,"GL"),DDS1RT=$$CREF^DILF(DIE),DDP=DDS1DDP S DDS1SN=0 ; I DDS1MUL D ;IT'S A MULTIPLE FIELD WITHIN TOP-LEVEL FILE . D DDA^DDS5(0,.DA,.DDSDL) . S DDSDA=","_DDSDA . S:'$D(@DDS1RT@(DDS1IND)) DDS1IND="!IEN" . I DDS1IND="!IEN" D .. S DA=0 F S DA=$O(@DDS1RT@(DA)) Q:'DA D REPLD . E D .. S (DDS1Q,DDS1STRT)=$NA(@DDS1RT@(DDS1IND)),DDS1SCNT=$QL(DDS1Q) .. F S DDS1Q=$Q(@DDS1Q) Q:DDS1Q="" Q:$NA(@DDS1Q,DDS1SCNT)'=DDS1STRT D ... S DA=$QS(DDS1Q,$QL(DDS1Q)) D REPLD ; GFT E I $G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,"COMP MUL"))]"" D S DDSDA=DDS1PDA,DA=+DDSDA,@DDS1REF@("COMP MUL")=$G(^DIST(.403,+DDS,40,DDSPG,40,DDS1B,"COMP MUL PTR")) ;COMPUTED MULTIPLE BUILDS A REPEATING BLOCK .N DICMX,D .I $G(^("COMP MUL PTR"))="" S DICMX="S DA=$G(D0,$G(D)) N D D NOFILE^DDS1" .E S DICMX="S DA=$G(D0,$G(D)) N D D REPLD^DDS1" .X ^("COMP MUL") ; E I $G(DA) S DDS1VAL=DA N D0,DA,DDSDA D ;IT'S A RELATIONAL JUMP (DA COULD BE UNDEFINED FOR AN UNRELATED FILE!) . S DDSDA="," . S (DDS1Q,DDS1STRT)=$NA(@DDS1RT@(DDS1IND,DDS1VAL)),DDS1SCNT=$QL(DDS1Q) . F S DDS1Q=$Q(@DDS1Q) Q:DDS1Q="" Q:$NA(@DDS1Q,DDS1SCNT)'=DDS1STRT D .. S DA=$QS(DDS1Q,$QL(DDS1Q)) D REPLD ; E S DIERR=1 Q ;Now set INITIAL POSITION DISV I DDS1INI="u" S DDS1INI="l" I $G(DUZ)]"",$G(DIE)]"" D I DDS1INI .N T .S T=$G(^DISV(DUZ,DIE)) Q:'T S T=$G(@DDS1REF@(DDS1PDA,"B",T_",")) Q:'T ;Get entry that SPACE-BAR would return .S DDS1SN=T,T=T-DDS1REP+1 .I T>0 S DDS1INI=T_U_(DDS1SN-T+1)_U_DDS1SN Q .S DDS1INI=1_U_DDS1SN_U_DDS1SN E I DDS1INI="l"!(DDS1INI="n") D . N N,T . S N=DDS1INI="n" F . S DDS1SN=$O(@DDS1REF@(DDS1PDA," "),-1)+N S:'DDS1SN DDS1SN=1 ;Don't want 1^0^0 . S T=DDS1SN-DDS1REP+2-N . S DDS1INI=$S(T<1:1_U_DDS1SN,1:T_U_(DDS1REP-'N))_U_DDS1SN E S DDS1INI="1^1^1" ; S $P(@DDS1REF@(DDS1PDA),U,2,6)=DDS1PDA_U_DDS1INI_U_+DDS1REP ; I DDS1MUL D . D UDA^DDS5(.DA,.DDSDL) . S DDSDA=$P(DDSDA,",",2,999) Q ; REPLD ;Load data Q:'$D(@DDS1RT@(DA,0)) I $D(DDS1FSCR) N Y S Y=DA X DDS1FSCR Q:'$T I $D(DDS1ACT) D .N DIC,Y .S DIC(0)="E",Y=DA_U_$P(@DDS1RT@(DA,0),U) .X DDS1ACT ;HERE IS WHERE ACCESS AUDITING WOULD TAKE PLACE IF IT IS SET UP IN POST-ACTION! NOFILE S DDS1SN=DDS1SN+1,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA S @DDS1REF@(DDS1PDA,DDS1SN)=DDSDA S @DDS1REF@(DDS1PDA,"B",DDSDA)=DDS1SN D ^DDS11(DDS1B) Q ; D0(DL) ;Given DL, return string D0,D1,...,Dn N I,S S S="" F I=0:1:DL S S=S_"D"_I_"," S:S?.E1"," S=$E(S,1,$L(S)-1) Q S ; GETD0(DA,DL) ;Given DA array, set D0,D1... N I S @("D"_DL)=DA F I=1:1:DL-1 S @("D"_(DL-I))=DA(I) Q DDS10 DDS10 ;SFISC/MKO-BLOCK SETUP ;21SEP2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; SET(DDS1B,DDS1E,DA,DDP,DIE,DL,DDSDA) ;Get values for pointed-to block ;In: ; DDS1B = Block number or [Block name] (by ref) ; DDS1E = 1, if we're loading a pointed-to block and we want ; interactive dialog (DIC(0)["E") in the lookup ; DA = Record array ;Returns: ; DDS1B = Block number ; DDP = File number of block ; DIE = Global root based on DDP and DA ; DL = Level number (top=0) ; DDSDA = DA,DA(1),..., ; D BK(.DDS1B,.DDP) Q:$G(DIERR) D GDA(DDS1B,DDS1E,.DA) Q:$G(DIERR) D GL(DDP,.DA,.DIE,.DL,.DDSDA,$P($G(^DIST(.403,+DDS,40,+$G(DDSPG),40,DDS1B,0)),U,4)'="d") Q:$G(DIERR) ;Don't LOCK record if block is display-only Q ; BK(DDSBK,DDP) ;Lookup block, get file number ;Input: ; DDSBK = Block number or [Block name] (by ref) ;Returns: ; DDSBK = Block number ; DDP = File number ; DIERR ; I DDSBK=+$P(DDSBK,"E") D Q . I $D(^DIST(.404,DDSBK,0))[0 D BLD^DIALOG(3051,"#"_DDSBK) Q . S DDP=+$P(^DIST(.404,DDSBK,0),U,2) I DDSBK?1"["1.E1"]" D Q . N X,Y,DIC . S X=$E(DDSBK,2,$L(DDSBK)-1),DIC="^DIST(.404,",DIC(0)="FZ" . D ^DIC I Y<0 D BLD^DIALOG(3051,"named "_X) Q . S DDSBK=+Y,DDP=+$P(Y(0),U,2) D BLD^DIALOG(3051,"#"_DDSBK) Q ; GDA(DDS1B,DDS1E,DA) ;Find new DA ;Input: ; DDS1B = Block number ; DDS1E = 1:Interactive lookup ; DDSDAORG = Original DA array ; DDSDLORG = Original DL ; DDSPG ;Returns: ; DA = Record number ; DIERR ; N DDSDA,DDSI,X ; ;Set DA array to its original value S DA=DDSDAORG F DDSI=1:1:DDSDLORG S DA(DDSI)=DDSDAORG(DDSI) D DDSDA(.DA,DDSDLORG,.DDSDA) ; ;Xecute each PTB node F DDSI=1:1 Q:DA=""!'$D(@DDSREFS@(DDSPG,DDS1B,"PTB",DDSI)) X ^(DDSI) S:$G(X)'>0 DA="" ; ;Kill descendants of DA I '$G(DIERR) S DDSI=DA K DA S DA=DDSI S:DA'>0!$G(DIERR) DA="" Q ; GL(F,DA,DIE,DL,DDSDA,DDSL) ;Get global root, level, and IEN ;Input variables: ; F = file # ; DA = array ; DDSL = flag to lock record ;Returns: ; DIE = global root of file (null if error) ; DL = level (top=0) (null if error) ; DDSDA = IEN ; DIERR = Error flag ; I '$D(^DD(F)) D BLD^DIALOG(401,F) S (DIE,DL)="" Q I $D(^DIC(F,0,"GL"))#2 S DIE=^("GL"),DL=0 E D SUBGL Q:$G(DIERR) ; I '$G(DA) S DDSDA="0," Q D DDSDA(.DA,DL,.DDSDA) ; N DDSP S DDSP("FILE")=F,DDSP("IEN")=DDSDA ; I $D(@(DIE_DA_",0)"))[0 D BLD^DIALOG(601,"",.DDSP) I $D(@(DIE_DA_",-9)")) D BLD^DIALOG(602,"",.DDSP) ; I $G(DDSL),$D(^TMP("DDS",$J,"LOCK",DIE_DA_")"))[0 D Q:$G(DIERR) . D LOCK^DILF(DIE_DA_")") E D BLD^DIALOG(110,"",.DDSP) Q ;**147 . S ^TMP("DDS",$J,"LOCK",DIE_DA_")")="" Q ; SUBGL ;Get root and level for subfile N D,I,S,U1 S D=F F DL=0:1 Q:$D(^DD(D,0,"UP"))[0 S U1=^("UP") G:'$D(^DD(U1,"SB",D)) SUBER G:$D(^DD(U1,$O(^(D,"")),0))[0 SUBER S S(DL+1)=""""_$P($P(^(0),U,4),";")_"""",D=U1 G:$D(^DIC(D,0,"GL"))[0 SUBER S DIE=^("GL") F I=DL:-1:1 G:$D(DA(I))[0 SUBER S DIE=DIE_DA(I)_","_S(I)_"," Q ; SUBER ;Come here if an error is encountered in GL S (DIE,DL)="" D BLD^DIALOG(309) Q ; DDSDA(DA,DL,DDSDA) ;Determine DDSDA ;Input: ; DA = Record array ; DL = Level number (top=0) ;Output: ; DDSDA = DA,DA(1),..., ; N I I DA="" S DDSDA="" Q S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_"," Q DDS11 DDS11(DDSBK,DDSNFO) ;SFISC/MLH,MKO-LOAD DATA ;4JUNE2007; LOAD DATA TO BE SHOWN ON SCREEN ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;Input variables: ; DDSBK = Block # ; DDSPG = Page # (needed for form-only fields) ; DDSREFT = Temporary global location ; DDP = File number of block ; DIE = Global root of block ; DDSDA = DA,DA(1),... ; DDSNFO = Flag means don't reload form only fields ; N X,Y S DDS1REFD=$NA(@DDSREFT@("F"_DDP,DDSDA)) ; S DDS1FO=0 F S DDS1FO=$O(^DIST(.404,DDSBK,40,DDS1FO)) Q:'DDS1FO D LD ; I DDP,DDSDA S @DDS1REFD@("GL")=DIE ; K DDS1REFD,DDS1FLD,DDS1FO,DDS1KEY,DDS1LN,DDS1ND,DDS1PC,DDS1UI,DDS1DV K DDS1D1,DDS1D2,DDS1D3 Q ; LD ;Load data for a field ; ;Get form only fields I $P($G(^DIST(.404,DDSBK,40,DDS1FO,0)),U,3)=2,$P($G(^(20)),U)]"" D Q . Q:$G(DDSNFO) . N DDP . S DDP=0,DDS1FLD=DDS1FO_","_DDSBK . Q:"^1^3^"[(U_$G(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))_U) . S Y="" . I $D(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))[0,$G(^DIST(.404,DDSBK,40,DDS1FO,3))]"" D DEF(^(3),$G(^(3.1))) . S (@DDSREFT@("F0",DDSDA,DDS1FLD,"D"),^("O"))=Y ; ;Get DD fields S DDS1FLD=$G(^DIST(.404,DDSBK,40,DDS1FO,1)) Q:DDS1FLD?."^" Q:"^1^3^"[(U_$G(@DDS1REFD@(DDS1FLD,"F"))_U) ; S DDS1LN=$G(^DD(DDP,DDS1FLD,0)) Q:DDS1LN?."^" S DDS1PC=$P(DDS1LN,U,4),DDS1ND=$P(DDS1PC,";"),DDS1PC=$P(DDS1PC,";",2) S DDS1DV=$P(DDS1LN,U,2),X=$P(DDS1LN,U,3) ; D @($S(DDS1FLD=.001:"L3",DDS1PC=0:"L2",1:"L1")) ; I DDS1DV["O"!(DDS1DV["P")!(DDS1DV["V")!(DDS1DV["D")!(DDS1DV["S") D . Q:$D(@DDS1REFD@(DDS1FLD,"X")) . D:Y]"" XFORM . S @DDS1REFD@(DDS1FLD,"X")=Y ; I DDS1PC=0,DDS1DV,DDS1DV'["W",$D(@DDS1REFD@(DDS1FLD,"X"))[0 S ^("X")=Y Q ; L1 ;Get non-multiple field S DDS1LN=$G(@(DIE_"DA,DDS1ND)")) I $E(DDS1PC)'="E" S Y=$P(DDS1LN,U,DDS1PC) E S Y=$E(DDS1LN,+$E(DDS1PC,2,999),$P(DDS1PC,",",2)) S:Y?." " Y="" ; K @DDS1REFD@(DDS1FLD,"X") I Y="",$D(@DDS1REFD@(DDS1FLD,"F"))[0,$D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D DEF(^(3),$G(^(3.1))) MUMPS I $G(DUZ(0))'="@",DDS1DV["K" S $P(@DDS1REFD@(DDS1FLD,"A"),U,4)=1,Y=$TR($J("",$L(Y))," ","*") ;**151 S @DDS1REFD@(DDS1FLD,"D")=Y ; ;Get key info I '$D(@DDS1REFD@(DDS1FLD,"K")) D . S DDS1KEY=0 . F S DDS1KEY=$O(^DD("KEY","F",DDP,DDS1FLD,DDS1KEY)) Q:'DDS1KEY D .. S DDS1UI=$P(^DD("KEY",DDS1KEY,0),U,4) Q:'DDS1UI .. Q:$P($G(^DD("IX",DDS1UI,0)),U,6)'="F" .. S ^("K")=$G(@DDS1REFD@(DDS1FLD,"K"))_DDS1UI_U Q ; L2 ;Get multiple field S DDS1SUB=+$P(DDS1LN,U,2) Q:$D(^DD(DDS1SUB,.01,0))[0 S DDS1DV=DDS1SUB_$P(^DD(DDS1SUB,.01,0),U,2),X=$P(^(0),U,3) S DDS1DIC=DIE_DA_","""_DDS1ND_"""," ; D:DDS1DV'["W" . I $D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D D L22 .. D DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$G(^(3.1)),1) .. S DDS1RN=$S($G(Y)="FIRST":$O(@(DDS1DIC_"0)")),$G(Y)="LAST":$O(@(DDS1DIC_""" "")"),-1),1:+$G(Y)) . E I $D(DUZ)#2,$L(DDS1DIC)<29,$D(^DISV(DUZ,DDS1DIC))#2 S DDS1RN=^(DDS1DIC) D L22 . E S DDS1RN=$S($D(@(DDS1DIC_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) D L22 . E S (Y,@DDS1REFD@(DDS1FLD,"D"))="" ; S @DDS1REFD@(DDS1FLD,"M")=$S(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB K DDS1DIC,DDS1RN,DDS1SUB Q L22 ; I DDS1RN>0,$D(@(DDS1DIC_+DDS1RN_",0)"))#2 S Y=$P(^(0),U),@DDS1REFD@(DDS1FLD,"D")=+DDS1RN Q ; DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default N DDS1PTR,DDS1OT Q:DDS1LN3="" I DDS1LN3'="!M" S Y=DDS1LN3 E I DDS1LN31'?."^" X DDS1LN31 S:$D(Y)[0 Y="" Q:Y=""!$G(DDS1MULT) ; K DIR I DDS1FLD["," D . S DIR(0)=$P(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$P(^(20),U,2,3) . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) . I $E($P(DIR(0),U))="P" S DDS1PTR=1 E D . S DIR(0)=DDP_","_DDS1FLD . S DDS1PTR=$P($G(^DD(DDP,DDS1FLD,0)),U,2) . S DDS1OT=DDS1PTR["O",DDS1PTR=DDS1PTR["P" S DIR("V")="",(X,DIR("B"))=Y D ^DIR ; I DDER S Y="" I Y]"" D . I $G(DDS1PTR) S Y=$P(Y,U) . S $P(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3 . I $G(DDS1PTR),$G(DDS1OT),$D(^DD(DDP,DDS1FLD,2))#2 K Y(0),Y(0,0) . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$S($D(Y(0,0))#2:Y(0,0),1:Y(0)) . S DDSCHG=1 K DDER,DIR Q ; L3 ;Get number field S (@DDS1REFD@(.001,"D"),Y)=DA Q ; EXT(DDP,DDS1FLD,Y) ;Return external form of Y N DDS1DV,X S DDS1DV=$P(^DD(DDP,DDS1FLD,0),U,2),X=$P(^(0),U,3) I DDS1DV'["O",DDS1DV'["P",DDS1DV'["V",DDS1DV'["D",DDS1DV'["S" Q Y I DDS1DV'["O",Y="" Q "" D XFORM Q Y ; XFORM ; N DDS1N I DDS1DV["O",+DDS1FLD,$D(^DD(DDP,+DDS1FLD,2))#2 X ^(2) Q I DDS1DV["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) Q:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DDS1DV=$P(^(0),U,2) G XFORM I DDS1DV["V",+$P(Y,"E"),$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)"))#2 S X=+$P($P(^(0),U,2),"E") Q:$D(^(+$P(Y,"E"),0))[0 S Y=$P(^(0),U) I $D(^DD(+$P(X,"E"),.01,0))#2 S DDS1DV=$P(^(0),U,2),X=$P(^(0),U,3) G XFORM I DDS1DV["D" X ^DD("DD") I DDS1DV["S" D .I +DDS1FLD,$G(^DD(DDP,+DDS1FLD,0))[X S Y=$$SET^DIQ(DDP,+DDS1FLD,Y) ;FOREIGN-LANGUAGE SET VALUE .E D PARSET^DIQ(X,.Y) Q DDS2 DDS2 ;SFISC/MLH-UP ARROW JUMP, BRANCH ;20JUNE2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; MOUSE ;Mouse has clicked: DDSMX=$X,DDSMY=$Y N DDSBO,P,DDS2O,% S DDACT="N",DDSMOUSY=1,DDS2O=DDO,DDSBO=DDSBK S X="" F S X=$O(DDSMOUSE(DDSMY,X)) Q:X=""!(X>DDSMX) S P=$O(DDSMOUSE(DDSMY,X,"")) I P'DX ;Click is to the left of Caption ..S S=^(2)+TOP-2 ;$Y OF THE FIRST MULTIPLE for this Field ..S S=DY-S+HITE/HITE Q:S<1!(S[".")!(S>REP) ;Can't click above or below the window ..I $D(@DDSREFT@(DDSPG,B,D,S+ABOVE)) S Z=S Q ;Z IS THE LINE MUST BE OFFSET BY NUMBER OF ONES ABOVE! ..I $P(@DDSREFS@(DDSPG,B),U,9)'=F Q ;Must go to 1st field of new multiple ..I S=1!$D(@DDSREFT@(DDSPG,B,D,S-1+ABOVE)) S Z=S Q $G(Z) ;Returns FIELD,BLOCK,PAGE,DDSCL ; DX(DY) F F=0:0 S F=$O(@DDSREFS@(DDSPG,B,F)) Q:'F I $D(^(F,"N")),+$G(^("D"))=DY D Q:$G(Z) .I $P(@DDSREFS@(DDSPG,B,F,"D"),U,2)+$P(^("D"),U,3)'>DX Q ;Click is to the right of data .I DX<$P(^("D"),U,2) Q:'$G(^DIST(.404,B,40,F,2)) S CAP=$P($P(^(2),U,3),",",2) Q:'CAP Q:CAP-1>DX ;Click is to the left of Caption .S Z=F_","_B_","_DDSPG Q ; NP ;from indirect GO in MOUSE+3, above S DDACT="NP" G NP^DDS01 ; ; UPA ;Up-arrow jump Q:$E(X)'=U I X?1"^"1.E,X'="^^",$G(DDSDN) D MSG^DDSMSG($$EZBLD^DIALOG(3096),1) Q ;** I X?1"^"1.E,X'="^^" D JMP Q ; ;Up-arrow only OUT I 'DDO D E^DDS3 Q I $D(DDSREP),DA D POSTACT D:$D(DDSBR)[0 END^DDSM Q I $G(DDSDN)=1 D MSG^DDSMSG($$EZBLD^DIALOG(3095),1) Q ;** D POSTACT S:$D(DDSBR)[0 DDSOSV=DDO,DDO=0 Q Q ; POSTACT ;Execute post action Q:$G(DDSO(12))?." " N X S X=$G(DDSOLD) X DDSO(12) D:$D(DDSBR)#2 BR Q ; JMP ;Up-arrow jump S DDS2X=X,X=$P(X,U,2) I X="" W $C(7) G KILL K DDH,DDQ S DDH=0 S (X,DDSX)=$$UPCASE($E(X,1,63)) ; ;Find exact matches D:$D(@DDSREFS@("CAP",X)) CAP D:$D(@DDSREFT@("XCAP",DDSPG,X)) XCAP ; ;Find partial matches S:X="?" (X,DDSX)="" F S DDSX=$O(@DDSREFS@("CAP",DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D CAP S DDSX=X F S DDSX=$O(@DDSREFT@("XCAP",DDSPG,DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D XCAP ; NO I 'DDH D MSG^DDSMSG($$EZBLD^DIALOG(3098,$P(DDS2X,U,2)),1) G KILL ;** S DDS2O=DDO I DDH=1 S DDO=$O(DDH(DDH,"")) E S DDD="J" D SC^DDSU DDO ;DDO=FIELD,BLOCK,PAGE S DDS2B=$P(DDO,",",2),DDS2P=$P(DDO,",",3),DDO=+DDO G:'DDS2B KILL ; S DDS2DA=DDSDA I DDS2P'=DDSPG D ;Different Page . D:'$D(@DDSREFT@(DDS2P,DDS2B)) ^DDS1(DDS2P) . S DDS2DA=@DDSREFT@(DDS2P,DDS2B) . I DDS2DA="" D .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2)) .. S DDO=DDS2O . E D CKUNED D:'$G(DDS2UNED) .. D POSTACT .. S:$D(DDSBR)[0 DDACT="NP",DDSPG=DDS2P,DDSBK=DDS2B,DDSBR="" ;Set the new page ; E I DDS2B'=DDSBK D ;Different Block . S DDS2DA=@DDSREFT@(DDS2P,DDS2B) . I DDS2DA="" D .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2)) .. S DDO=DDS2O . E I $P($G(@DDSREFS@(DDS2P,DDS2B)),U,4) D .. D MSG^DDSMSG($C(7)_$P($T(ERR1),";;",2)) .. S DDO=DDS2O . E D CKUNED D:'$G(DDS2UNED) .. D POSTACT .. S:$D(DDSBR)[0 DDACT="NB",DDSBK=DDS2B,DDSBR="" ;Set the new Block ; E D CKUNED D:'$G(DDS2UNED) . D POSTACT . S:$D(DDSBR)[0 DDACT="N" ; KILL S X=DDS2X K DDH,DDSI,DDSPGRP,DDSX K DDS2ATT,DDS2B,DDS2DA,DDS2F,DDS2O,DDS2P,DDS2UNED,DDS2X Q ; CKUNED ;Check uneditable status N DDP,DDSFLD ; I $P($G(^DIST(.404,DDS2B,40,+DDO,0)),U,3)=2 D . S DDP=0 . S DDSFLD=+DDO_","_DDS2B E D . S DDP=$P($G(@DDSREFS@(DDS2P,DDS2B)),U,3) . S DDSFLD=$P($G(^DIST(.404,DDS2B,40,+DDO,1)),U) I 'DDSFLD S DDS2UNED=1,DDO=DDS2O Q S DDS2ATT=$P($G(@DDSREFT@("F"_DDP,DDS2DA,DDSFLD,"A")),U,4) ; I DDO,$S(DDS2ATT="":$P($G(^DIST(.404,DDS2B,40,+DDO,4)),U,4)=1,1:DDS2ATT=1),'$P(@DDSREFS@(DDS2P,DDS2B,+DDO,"N"),U,11) D UNED .S DDS2UNED=$P(^DIST(.404,DDS2B,40,+DDO,0),U,2) I DDS2UNED="" S DDS2UNED=$P(^(0),U,5) I DDS2UNED="",$G(^(1)),$D(^DD(DDP,^(1),0)) S DDS2UNED=$P(^(0),U) .D MSG^DDSMSG($$EZBLD^DIALOG(3090,DDS2UNED),1) ;**FIELD is UNEDITABLE! .S DDS2UNED=1,DDO=DDS2O Q ; CAP ;Find all captions that match DDSX S DDSPGRP="" F S DDSPGRP=$O(@DDSREFS@("CAP",DDSX,DDSPGRP)) Q:DDSPGRP="" D . Q:U_DDSPGRP_U'[(U_DDSPG_U) . S DDS2P="" F S DDS2P=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P)) Q:'DDS2P D .. S DDS2B="" F S DDS2B=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B)) Q:'DDS2B D ... S DDS2F="" F S DDS2F=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B,DDS2F)) Q:'DDS2F D FILL Q ; XCAP ;Find all xecutable captions that match DDSX S DDS2P=DDSPG S DDS2B=0 F S DDS2B=$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B)) Q:'DDS2B D . S DDS2F=0 F S DDS2F=+$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B,DDS2F)) Q:'DDS2F D .. I $D(^DIST(.404,DDS2B,40,DDS2F,0))#2,$P(^(0),U,3)'=1 D FILL Q ; FILL ;Fill DDH array with possible choices S DDS2V=DDSX_$S($P(^DIST(.404,DDS2B,40,DDS2F,0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"") S:DDS2P'=DDSPG DDS2V=DDS2V_" ("_$S($P($G(^DIST(.403,+DDS,40,DDS2P,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))_")" S DDH=DDH+1,DDH(DDH,DDS2F_","_DDS2B_","_DDS2P)=DDS2V K DDS2V Q ; BR ;Evaluate DDSBR N B,B1,F,F1,P,P1,E,X Q:$D(DDSBR)[0 I DDSBR="QUIT" S DDACT="Q" Q ;** S P=$P($G(DDSOPB),U),B=$P($G(DDSOPB),U,2),F=$G(DDO),E=1 S:'B B=+$P(@DDSREFS@(+P,"FIRST"),",",2) S P1=$P(DDSBR,U,3),B1=$P(DDSBR,U,2),F1=$P(DDSBR,U) ; D @$S(P1]"":"PG",B1]"":"BK",1:"FD") S:'E DDACT=$S(P'=+DDSOPB:"NP",B'=$P(DDSOPB,U,2):"NB",1:"N"),DDSPG=P,DDSBK=B,DDO=F K:E DDSBR Q ; PG ; I P1=+$P(P1,"E") S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) E S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(P1),"")) Q:'P S:B1="" B1=$O(^DIST(.403,+DDS,40,P,40,"AC","")) Q:B1="" BK ; I B1=+$P(B1,"E") D . S B=$O(^DIST(.403,+DDS,40,P,40,"AC",B1,"")) E D . S B=$O(^DIST(.404,"B",B1,"")) Q:B="" . S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,"")) Q:'B S:F1="" F1=$O(^DIST(.404,B,40,"B","")) FD ; Q:F1="" I F1="COM" S (E,F)=0 Q I F1=+$P(F1,"E") S X="B" E S F1=$$UPCASE(F1),X=$S($D(^DIST(.404,B,40,"D",F1)):"D",1:"C") S F=$O(^DIST(.404,B,40,X,F1,"")) S:F E=0 Q ; UPCASE(X) ; ;Return X in uppercase Q $$UP^DILIBF(X) ;** ; ERR ;;Unable to jump to that field. The block on which that field is located has no record associated with it. ; ERR1 ;;Unable to jump to that field. The block on which that field is located has navigation disabled. DDS3 DDS3 ;SFISC/MLH-COMMAND UTILS ;16FEB2005 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. I $G(Y(0))]"","ECNRSPQ"[$E(Y(0)) D @$E(Y(0)) ;'Y' is carried over from the ^DIR read in DDSCOM Q ; S ;Save the form D ^DDS4,R^DDSR D:$D(DDSBR)#2 BR^DDS2 Q ; R ;Repaint all pages on current screen ;Called after wp, mults, and deletions G R^DDSR ; E ;Exit I DDSSC>1!'DDSCHG!$P(DDSSC(DDSSC),U,4) S DDACT="Q" Q S DDM=1 S Y=1 G EX ;S Y=0 I $G(^XTV(8989.5,0))?1"PARAM".E S Y=$$GET^XPAR("ALL","DI SCREENMAN DON'T ASK SAVE") I Y=1 G EX ;**AVOID THE Y/N QUESTION K DIR S DIR(0)="YO" S DIR("A")=$$EZBLD^DIALOG(8075) D BLD^DIALOG(9037,"","","DIR(""?"")") S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^3^"_(IOSL-1)_"^0" D ^DIR K DIR,DIROUT,DIRUT I Y=0!$D(DTOUT)!$D(DUOUT) D QT Q I Y="" S DDACT="N" Q I Y=1 D EX Q ; C ;Close S DDACT="Q" Q ; N ;Next page S:DDSNP]"" DDSPG=DDSNP,DDACT="NP" Q ; P ;Previous D PP^DDS01 Q ; Q ; QT ;Exit, don't save I $G(DDSDN)=1,DDO G ERR3 S DDACT="Q" I DDSSC>1!$P(DDSSC(DDSSC),U,4) D MSG1 Q ;IT ALSO QUIT HERE IF $G(DDSSEL) Q:'DDSCHG D DEL^DDS6 S DX=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL),$S($D(DTOUT):$$EZBLD^DIALOG(8076),1:"")_$$EZBLD^DIALOG(8077) H 1 Q ; EX ;Exit, save I $G(DDSDN)=1,DDO G ERR3 S DDACT="Q" I DDSSC>1!$P(DDSSC(DDSSC),U,4) D MSG1 Q ;IT ALSO QUIT HERE IF $G(DDSSEL) D ^DDS4 I 'Y S DDACT="N" D R D:$D(DDSBR)#2 BR^DDS2 Q ; CL ;Close I $G(DDSDN)=1,DDO G ERR3 G E ; TO ;Time-out I DDO,$G(DDSDN) S DDACT="N" G CURSOR^DDS01 I DDO S DDSOSV=DDO,DDO=0 E D E Q ; MSG1 ;Print closing page message S DX=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL)_"..." H 1 Q ; ERR3 ; D MSG^DDSMSG("Since navigation for the block is disabled, that key sequence is disabled.",1) S DDACT="N" Q ; ;#8075 Save changes before leaving form (Y/N)? ;#8076 Time out. ;#8077 Changes not saved! ;#9037 Enter 'Y' to save before exiting...(3 lines) DDS4 DDS4 ;SFISC/MKO-FILE AND RELOAD ;9DEC2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D ^DDS41 Q:Y'=1 N DA,DDO,DIE,DDP,DDSDA ; S DX=0,DY=IOSL-1 X IOXY W "Filing form"_$P(DDGLCLR,DDGLDEL) ; ;File data S DDS4FI="F" F S DDS4FI=$O(@DDSREFT@(DDS4FI)) Q:DDS4FI'?1"F".E D . S DDP=$E(DDS4FI,2,999),DDS4DA=" " . F S DDS4DA=$O(@DDSREFT@(DDS4FI,DDS4DA)) Q:DDS4DA="" D REC ; ;Reload all pages on form S DDS4P=0 F S DDS4P=$O(@DDSREFT@(DDS4P)) Q:'DDS4P D . S DDS4B=0 . F S DDS4B=$O(@DDSREFT@(DDS4P,DDS4B)) Q:'DDS4B D .. S DDP=$P(@DDSREFS@(DDS4P,DDS4B),U,3),DDSDA=" " .. F S DDSDA=$O(@DDSREFT@(DDS4P,DDS4B,DDSDA)) Q:'DDSDA D ... S $P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U)=1,DIE=^(DDSDA,"GL") ... Q:$P(@DDSREFT@(DDS4P,DDS4B,DDSDA),U,6)>1 ... D GDA(DDSDA) ... D ^DDS11(DDS4B,1) ; I $G(^DIST(.403,+DDS,14))'?."^" D . I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D .. S DA=DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_"," .. F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_"," .. S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE="" . X ^DIST(.403,+DDS,14) I '$G(DDSSAVE),$G(DDSPARM)["S" S DDSSAVE=1 S (Y,DDSH)=1,(DDSCHG,DX)=0,DY=IOSL-1 X IOXY W $P(DDGLCLR,DDGLDEL) K @DDSREFT@("ADD"),@DDSREFT@("RXR") K DIC,DDS1B,DDS1DA,DDS4B,DDS4DA,DDS4FI,DDS4FLD,DDS4FO,DDS4P K DDSEXT,DDSI,DDSINT,DDSLC,DDSLN,DDSND,DDSOND,DDSOLD,DDSP,DDSPC K DDSW,DDSX,DV Q ; ; REC ; G:DDS4FI="F0" FORMONLY ; S DIE=$G(@DDSREFT@(DDS4FI,DDS4DA,"GL")) I DIE="" Q ;JUST TO BE SAFE! D GDA(DDS4DA) S DDSOND=-1 K DDSLN S DDS4FLD="" F S DDS4FLD=$O(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD)) Q:DDS4FLD="" D FLD S:$D(DDSLN)#2 @(DIE_"DA,DDSND)")=DDSLN ; I $D(@DDSREFT@("RXR")) D . D FIRE^DIKC(DDP,.DA,"KS",$NA(@DDSREFT@("RXR")),"O^") . K @DDSREFT@("RXR") Q FLD ; Q:'$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F")) S ^("F")="" I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1 S DDSINT=$G(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D")) ; ;Word processing fields (quit if multiple) I $D(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"M"))#2 D:'$P(^("M"),U) Q WP .N FR,TO,DDS4M .S DDS4M=^("M") . S FR=$NA(@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"D")) . S TO=U_$$CREF^DILF($P(DDS4M,U,2)) .I $P($G(^DD(+$P(DDS4M,U,3),.01,0)),U,2)["a" D WP^DIET($E(DDS4FI,2,99),DDS4FLD,DDS4DA,TO) ;AUDIT Word -Processing . K @TO . M @TO=@FR . K @FR,@DDSREFT@(DDS4FI,DDS4DA,DDS4FLD,"F") ; Q:$G(^DD(DDP,DDS4FLD,0))?."^" S DDSND=$P(^(0),U,4) S DDSPC=$P(DDSND,";",2) Q:"0 "[DDSPC S DDSND=$P(DDSND,";") ; I DDSOND'=DDSND D . S:$D(DDSLN)#2 @(DIE_"DA,DDSOND)")=DDSLN . S DDSLN=$G(@(DIE_"DA,DDSND)")) . S DDSOND=DDSND ; I DDSPC D . S DDSOLD=$P(DDSLN,U,DDSPC) . S $P(DDSLN,U,DDSPC)=DDSINT E D . S DDSW=$E(DDSPC,2,999),DDSP=$P(DDSW,",",2)+1 . S DDSOLD=$E(DDSLN,+DDSW,DDSP-1) . S DDSX=$E(DDSLN,DDSP,999) . S DDSLN=$E(DDSLN,1,DDSW-1)_$J("",DDSW-1-$L(DDSLN))_DDSINT . S:DDSX'?." " DDSLN=DDSLN_$J("",DDSP-DDSW-$L(DDSINT))_DDSX ; I $D(^DD(DDP,DDS4FLD,1))!($P(^(0),U,2)["a")!$D(^DD("IX","F",DDP,DDS4FLD)) D XR Q XR ; N DICRREC,DG,DP,DDS4AUD1,DDS4AUD2,DIANUM,DIIX,C,Y S DP=DDP,DDSOND=-1 I $D(DDSLN)#2 S @(DIE_"DA,DDSND)")=DDSLN K DDSLN S DICRREC="TRIG^DDS4" ; I $P(^DD(DDP,DDS4FLD,0),U,2)["a" D . S (DDS4AUD1,DDS4AUD2)=1 . I $G(^DD(DDP,DDS4FLD,"AUDIT"))["e",DDSOLD="" S DDS4AUD1=0 ; I DDSOLD]"" D . S DG=0 F S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1 D ;YIKES! GOES THRU ALL CROSS-REFERENCES, EVEN IF NO CHANGE IN THE DATA! .. S DIC=DIE,X=DDSOLD .. X:$D(^DD(DDP,DDS4FLD,1,DG,2))#2 ^(2) . I $G(DDS4AUD2) S DG=1,X=DDSOLD,DIIX="2^"_DDS4FLD D AUDIT^DIET ; I DDSINT]"" D . S DG=0 F S DG=$O(^DD(DDP,DDS4FLD,1,DG)) Q:DG<1 D .. S DIC=DIE,X=DDSINT .. X:$D(^DD(DDP,DDS4FLD,1,DG,1))#2 ^(1) . I $G(DDS4AUD1) S DG=1,X=DDSINT,DIIX="3^"_DDS4FLD D AUDIT^DIET Q:'$D(^DD("IX","F",DDP,DDS4FLD)) ; ;Process index file xrefs N DDSFXR,DDSFXREF,DDSRXREF D LOADFLD^DIKC1(DDP,DDS4FLD,"KS","",$NA(@DDSREFT@("F"))_"_","DDSFXR",$NA(@DDSREFT@("RXR")),.DDSFXREF,.DDSRXREF) I $G(DDSRXREF)]""!($G(DDSFXREF)]"") D . S @DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"O")=DDSOLD ;BRX-0404-11337 D:$G(DDSFXREF)]"" FIRE^DIKC(DDP,.DA,"KS","DDSFXR","O^") Q GDA(DDSDA) ; N I K DA S DA=$P(DDSDA,",") F I=2:1:$L(DDSDA,",")-1 S DA(I-1)=$P(DDSDA,",",I) Q ; FORMONLY ; N X D GDA(DDS4DA) S DDS4FLD="" F S DDS4FLD=$O(@DDSREFT@("F0",DDS4DA,DDS4FLD)) Q:DDS4FLD="" D . Q:'$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"F")) . S DDS4FO=$P(DDS4FLD,","),DDS4B=$P(DDS4FLD,",",2) . S DDSOLD=$G(@DDSREFT@("F0",DDS4DA,DDS4FLD,"O")),X=$G(^("D")),DDSEXT=$G(^("X"),X) . X:$G(^DIST(.404,DDS4B,40,DDS4FO,23))'?."^" ^(23) . S ^("O")=@DDSREFT@("F0",DDS4DA,DDS4FLD,"D"),^("F")="" Q ; TRIG ;Called from trigger logic (from DICR via DICRREC) N DDSRXREF D LOADFLD^DIKC1(DIH,DIG,"KS","",$NA(@DDSREFT@("F"))_"_","",$NA(@DDSREFT@("RXR")),"",.DDSRXREF) I $G(DDSRXREF)]"",'$D(@DDSREFT@("F"_DIH,DICRIENS,DIG,"O")) S ^("O")=DIU Q DDS41 DDS41 ;SFISC/MKO-VERIFY DATA ;30JAN2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DDO,DIERR N DDS4B,DDS4DA,DDS4DONE,DDS4ERR,DDS4FLD,DDS4OUT,DDS4PG,DDS4PG1,DDS4TP N DDSCAP,DDSERROR,DDSFDA,DDSI,DDSKEY,DDSPID,DDSREQ ; S DDS4OUT=$NA(@DDSREFT@("VALMSG")) S DDS4PG=DDSPG ; K @DDS4OUT,@DDSREFT@("MSG"),@DDSREFT@("KMSG") ; I $G(DDSPTB)_$G(DDSREP)]"" N DIE,DDP,DDSDA,DA,DDSDL D . S DA=+DDSDAORG,DDSDL=DDSDLORG,DDSDA=DA_"," ;GFT . F DDSI=1:1:DDSDL S DA(DDSI)=DDSDAORG(DDSI),DDSDA=DDSDA_DA(DDSI)_"," . S DDP=$P($G(DDSFLORG),U),DIE=U_$P($G(DDSFLORG),U,2) S:DIE=U DIE="" ; D LDALL I $G(DIERR) D G END . N P . S P(1)=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U),P(2)=$P($G(^(1)),U) . S:P(2)="" P(2)="unnamed" . D BLD^DIALOG(3041,.P),ERR^DDSMSG . S DDS4ERR=1 ; D LP ; ;Validate keys S DDSKEY=1 I $D(DDSFDA) D . S DDSKEY=$$KEYVAL^DIE("","DDSFDA",$NA(@DDSREFT@("KMSG"))) . I 'DDSKEY,$D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091,"","",DDS4OUT,"S") ; S DDSPG=DDS4PG I '$G(DDS4ERR),$G(^DIST(.403,+DDS,20))'?."^" X ^(20) ;DATA VALIDATION I $G(@DDSREFT@("MSG"))>0!$G(DDS4ERR)!'DDSKEY D PRNT ; END S Y='$D(DDSERROR)&'$G(DDS4ERR)&$G(DDSKEY) ;BRX-0903-10662 K @DDS4OUT,@DDSREFT@("MSG"),@DDSREFT@("KMSG") Q ; LDALL ;Load all pages S DX=0,DY=IOSL-1 X IOXY W "..."_$P(DDGLCLR,DDGLDEL) ;**'PLEASE WAIT' S (DDSPG,DDS4PG1)=$O(^DIST(.403,+DDS,40,"B",$S($G(DDSPAGE)]"":DDSPAGE,1:1),"")) S Y=1 F D ^DDS1(DDSPG) Q:$G(DIERR) S DDSPG=$$NP^DDS5(.Y) Q:DDSPG=DDS4PG1!'Y Q ; LP ;Loop through all pages/blocks N DDP S DX=0,DY=IOSL-1 X IOXY W "..."_$P(DDGLCLR,DDGLDEL) ;**'VERIFYING' ; S DDSPG=0 F S DDSPG=$O(@DDSREFT@(DDSPG)) Q:'DDSPG D . S DDS4B=0 F S DDS4B=$O(@DDSREFT@(DDSPG,DDS4B)) Q:'DDS4B D .. Q:$D(DDS4DONE(DDS4B)) Q:$P(@DDSREFS@(DDSPG,DDS4B),U,5)'="e" .. S DDSPID=$S($P($G(^DIST(.403,+DDS,40,DDSPG,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U)) .. S DDS4DONE(DDS4B)="",DDP=$P(^DIST(.404,DDS4B,0),U,2) .. S DDO=0 F S DDO=$O(^DIST(.404,DDS4B,40,DDO)) Q:'DDO D VF Q ; VF ;Check required and key fields Q:$D(^DIST(.404,DDS4B,40,DDO,0))[0 S DDS4TP=$P(^(0),U,3) Q:DDS4TP=1 Q:DDS4TP=4 S DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,2)_$S($P(^(0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"") S DDSREQ=$P($G(^DIST(.404,DDS4B,40,DDO,4)),U) S DDSKEY=0 ; I DDS4TP=2 N DDP D . S DDP=0,DDS4FLD=DDO_","_DDS4B . S:DDSCAP="" DDSCAP=$P(^DIST(.404,DDS4B,40,DDO,0),U,5) ; E D Q:DDS4FLD'=+$P(DDS4FLD,"E") . S DDS4FLD=$G(^DIST(.404,DDS4B,40,DDO,1)) . I $G(^DD(DDP,DDS4FLD,0))?."^" S DDS4FLD="" Q . S:DDSCAP="" DDSCAP=$$LABEL^DIALOGZ(DDP,DDS4FLD) ;FOR SOME REASON, HE USED TO GRAB TITLE, IF PRESENT! . S:DDSREQ="" DDSREQ=$P(^DD(DDP,DDS4FLD,0),U,2)["R" . S DDSKEY=$D(^DD("KEY","F",DDP,DDS4FLD))>0 ; S DDS4DA=" " DAS F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4DA)) Q:DDS4DA'["," D ;IGNORE "COMP MUL" NODE . I $P(@DDSREFT@(DDSPG,DDS4B,DDS4DA),U,6)<2 D VR Q . ; . N DDS4PDA S DDS4PDA=DDS4DA N DDS4DA . S DDS4DA="" . F S DDS4DA=$O(@DDSREFT@(DDSPG,DDS4B,DDS4PDA,"B",DDS4DA)) Q:'DDS4DA D VR Q ; VR ;Check individual records I $P($G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"A")),U)]"" N DDSREQ S DDSREQ=$P(^("A"),U) I 'DDSREQ,'DDSKEY Q ; ;Required WP fields (quit if mult) I DDP,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M")) D:'^("M") Q . N DDS4I,DDS4REF,DDS4VAL . I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDS4REF=$NA(^("D")) . E S DDS4REF=$P(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"M"),U,2),DDS4REF=U_$E(DDS4REF,1,$L(DDS4REF)-1)_")" . S (DDS4VAL,DDS4I)=0 . F S DDS4I=$O(@DDS4REF@(DDS4I)) Q:'DDS4I I $G(@DDS4REF@(DDS4I,0))'?." " S DDS4VAL=1 Q . D:'DDS4VAL LDERR ; I $G(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"D"))="" D LDERR Q ; I DDSKEY,$D(@DDSREFT@("F"_DDP,DDS4DA,DDS4FLD,"F")) S DDSFDA(DDP,DDS4DA,DDS4FLD)=$G(^("D")) Q ; LDERR ;Call ^DIALOG to load error N P,E I $D(DDS4ERR)[0 S DDS4ERR=1 D BLD^DIALOG(3091,"","",DDS4OUT,"S") ;'THE DATA COULD NOT BE FILED.' S P(1)=DDSPID,P(2)=DDSCAP I $L(DDS4DA,",")>2 E S E=$O(@DDSREFT@("F"_DDP,"")) I E]"" S E=$O(^(E)) I E]"" ;ARE THERE MORE THAN ONE OF THESE ENTRIES? I S P(3)=$$GET1^DIQ(DDP,DDS4DA,.01,,,"E") I P(3)]"" S P(3)="("_$$EZBLD^DIALOG(8079)_": "_P(3)_")" ;'SUBRECORD' D BLD^DIALOG(3092,.P,"",DDS4OUT,"S") ; '|1|, |2| is a required field |3|' Q ; PRNT ;Print messages N DDSABT S (DDSABT,DX,DY)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S $X=0,$Y=0 ; ;Print required field messages I $G(DDS4ERR) S DDSI=0 F S DDSI=$O(@DDS4OUT@(DDSI)) Q:'DDSI D Q:DDSABT . D:$G(@DDS4OUT@(DDSI))]"" WLIN(^(DDSI)) ; ;Print duplicate key messages S DDSI=0 F S DDSI=$O(@DDSREFT@("KMSG","DIERR",DDSI)) Q:'DDSI D Q:DDSABT . D WLIN(" "),WLIN(@DDSREFT@("KMSG","DIERR",DDSI,"TEXT",1)) . Q:@DDSREFT@("KMSG","DIERR",DDSI)'=740 . ; . N DA,FIL,FILE,FLD,FLDS,FNAME,IENS,J,KEY,LEV,RNAME . S FILE=@DDSREFT@("KMSG","DIERR",DDSI,"PARAM","FILE"),IENS=$G(^("IENS")),KEY=$G(^("KEY")) . D FRNAME^DIKCU1(FILE,IENS,.FNAME,.RNAME,.LEV) . ; . I LEV D .. S FNAME=$J("",7)_"Subfile: "_FNAME D WLIN(.FNAME,16) .. S RNAME=$J("",8)_"Record: "_RNAME D WLIN(.RNAME,16) . ; . S FLDS="",J=0 F S J=$O(^DD("KEY",KEY,2,J)) Q:'J D .. Q:'$D(^DD("KEY",KEY,2,J,0)) S FLD=$P(^(0),U),FIL=$P(^(0),U,2) .. Q:'$D(^DD(FIL,FLD,0)) S FLDS=FLDS_$P(^(0),U)_" (#"_FLD_"), " . D:FLDS]"" WLIN(" Key Field(s): "_$E(FLDS,1,$L(FLDS)-2),16) ; ;Print developer messages S DDSI=0 F S DDSI=$O(@DDSREFT@("MSG",DDSI)) Q:'DDSI D Q:DDSABT . D:@DDSREFT@("MSG",DDSI)]"" WLIN(^(DDSI)) ; D EOP Q ; WLIN(DDSX,DDSINDNT) ;Write a single line, wrap at word boundaries N I D WRAP^DIKCU2(.DDSX,IOM-1-$G(DDSINDNT),IOM-1) S DDSX(0)=DDSX F I=0:1 Q:'$D(DDSX(I)) D Q:DDSABT . I $Y+4>IOSL D EOP I 'Y S DDSABT=1 Q . W !,$J("",$S(I:$G(DDSINDNT),1:0))_DDSX(I) Q EOP ;Issue EOP prompt N X S DX=0,DY=IOSL-1 X IOXY W $$EZBLD^DIALOG(8053) R X:DTIME ;** S Y=X'[U&$T I Y S (DX,DY)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S $X=0,$Y=0 Q DDS5 DDS5 ;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;9:53 AM 1 Oct 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. I X="" D:DDSOLD="" NF^DDS01 D:DDSOLD]"" DM^DDS6 Q I DIR0N,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSGL,1,28))=$E(DDSGL,29,999)_X I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDS5PG=^(DDO) E I $P($G(DDSO(7)),U,2)="" D:X=DDSOLD NF^DDS01 Q D MULT,R^DDSR ; K DDSSTACK X:$G(^DIST(.404,DDSBK,40,DDO,10))'?."^" ^(10) I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSBR D:$D(DDSBR)#2 BR^DDS2 Q MULT ; N DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP ; I $G(DDS5PG) S DDSPG=DDS5PG K DDS5PG E D . S DDSPG(1)=$P($G(DDSO(7)),U,2) Q:DDSPG(1)="" . S DDSPG=$O(^DIST(.403,+DDS,40,"B",DDSPG(1),"")) Q:DDSPG="" Q:$D(^DIST(.403,+DDS,40,+$G(DDSPG),0))[0 N:'$P(^(0),U,6) DDSSC ; D DDA(Y,.DA,.DDSDL) I Y'=-1 D . N DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG . S DIE=U_$P(DDSU("M"),U,2),DDP=$P(DDSU("M"),U,3) . S DDSDLORG=DDSDL,DDSDAORG=DA,DDSDA=DA_"," . F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI),DDSDA=DDSDA_DA(DDSI)_"," . K DDSI . S DDSSTK=1 . D PROC^DDS D LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD) D UDA(.DA,.DDSDL) Q ; LST(DA,DDSDL,DDP,DDSDA,DDSFLD) ;Save last edited subrecord ;In: DA array, DDSDL at subfile level ; DDP, DDSDA, DDSFLD at file level N DDSDIE,Y S DDSDIE=U_$P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2) I $D(@(DDSDIE_"+$G(DA),0)"))[0 D . S DA=$S($D(@(DDSDIE_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) . I DA>0 D .. N C .. S Y=$P(@(DDSDIE_DA_",0)"),U) .. S C=$P(^DD(+$P(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2) .. D Y^DIQ . E S (DA,Y)="" E S (DA,Y)="" I DA>0,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSDIE,1,28))=$E(DDSDIE,29,999)_DA ; S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y,^("D")=DA,DDACT="N" Q ; SEL ;Issue the read at the Select mult prompt S DIR(0)="PO"_DDSGL_":QEMZ"_$E("L",'$D(DDSTP)&'$P($G(DDSO(4)),U,5))_$E("V",$P($G(DDSO(4)),U,6)) I $D(@(DDSGL_"0)"))[0 S ^(0)=U_$P($G(DDSU("DD")),U,2)_U_U E I $P(@(DDSGL_"0)"),U,2)'=$P($G(DDSU("DD")),U,2) S $P(^(0),U,2)=$P($G(DDSU("DD")),U,2) D DDA(0,.DA,.DDSDL) S DDSDA="0,"_DDSDA D ^DIR K DIR,DUOUT,DIRUT,DIROUT D UDA(.DA,.DDSDL) S DDSDA=$P(DDSDA,",",2,999) Q:DDACT'="N" ; I DIR0N S (X,Y)=DDSOLD Q I $P(Y,U,3)=1 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL E S DIR0N=1 S Y=$P(Y,U) S:X="" Y="" Q ; DDA(Y,DA,DL) ;Push Y onto DA array N I F I=DL:-1:1 S DA(I+1)=DA(I) S DA(1)=DA,DL=DL+1 S (DA,@("D"_DL))=$S(+$P($G(Y),"E"):+$P(Y,"E"),1:0) Q ; UDA(DA,DL) ;Pop DA array N I S DA=DA(1) F I=2:1:DL S DA(I-1)=DA(I) K DA(DL),@("D"_DL) S DL=DL-1 Q NP(Y) ;Returns: Next page ; (Y=1 if found, 0 if not found) N P,P1 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,4) I P1]"" D . S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1 Q $S(Y=1:P,1:DDSPG) PP(Y) ; N P,P1 S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,5) I P1]"" D . S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) . I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1 Q $S(Y=1:P,1:DDSPG) NB(Y) ; N B,BO,X S (B,Y)=0,BO=$P($G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2) I BO F D Q:B=DDSBK!Y . S BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO)) S:'BO BO=$O(^("")) S B=$O(^(BO,"")) . S X=$G(@DDSREFS@(DDSPG,B)) . I $P(X,U)]"",$P(X,U,5)'="h",$P(X,U,9),B'=DDSBK S Y=1 Q B DDS6 DDS6 ;SFISC/MKO-DELETIONS ; 14NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;Enter here if user deleted record from the .01 of the (sub)record ;(called from DDS01) ;In: DDSU array, DDSOLD, DDSFLD D D I 'Y D ;DELETE DIDN'T HAPPEN . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD . S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X") E D . I $D(DDSREP) D .. D DEL^DDSM1(DDSDA) ;THIS WILL COME BACK TO K IN THIS ROUTINE! . E D K(DDSDA,DIE) I $D(DDSPTB) D .. S DDACT="NB" .. S $P(@DDSREFT@(DDSPG,DDSBK),U)="" .. D DB^DDSR(DDSPG,DDSBK) .. D RPF^DDS7(DDP,DDSPTB,DDSDA,.DA) . E S DDACT="Q",DA="",DDSDAORG=DA,DDSDA="0," . I '$D(DDSPTB),'$P(DDSSC(DDSSC),U,4),'$D(DDSREP) D .. D PG^DDSRSEL .. I $G(DDSSEL) D ... D CLRDAT^DDSRSEL ... D R^DDSR ... D PUT^DDSVALF(1,1,$P(^DIST(.403,+DDS,21),U),"","","0,") Q ; DM ;Enter here if user deleted record from the Select prompt ;(called from DDS5) ;In: DDSU array, DDSOLD, DDSFLD ; ;Get DA and DIE for subfile level and delete D DDA^DDS5(DDSOLD,.DA,.DDSDL) D . N DIE,DDSDA . S DIE=U_$P(DDSU("M"),U,2) . S DDSDA=DA_"," F DDSI=1:1:DDSDL S DDSDA=DDSDA_DA(DDSI)_"," . K DDSI . D D . D:Y K(DDSDA,DIE) ; I 'Y D . S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD . S:$D(DDSU("X"))#2 @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSU("X") . D UDA^DDS5(.DA,.DDSDL) E D . D LST^DDS5(.DA,.DDSDL,DDP,DDSDA,DDSFLD) . D UDA^DDS5(.DA,.DDSDL) Q ; D ;Delete the subrecord ;In: DA array, DIE, DDSDL; Out: Y=1 if successful N DR,DDS6DA,DDSI D:DDM CLRMSG^DDS S DDM=1 ; K DIR S DIR(0)="YO" D BLD^DIALOG(8080,$$EZBLD^DIALOG(8078+(DDSDL>0)),"","DIR(""A"")") D BLD^DIALOG(9038,"","","DIR(""?"")") ; S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^3^"_(IOSL-3)_"^0" D ^DIR K DIR D CLRMSG^DDS I X=""!$D(DIRUT)!'Y S Y=0 K DIRUT,DUOUT,DIROUT,DTOUT Q ; S DDS6DA=DA N D0 F DDSI=1:1 Q:$D(DA(DDSI))[0 S DDS6DA(DDSI)=DA(DDSI) N @("D"_DDSI) W $P(DDGLVID,DDGLDEL,9) S X=IOM X DDGLZOSF("RM") S DR=".01///@" D ^DIE K DI ;DELETE THE SUB-RECORD! W $P(DDGLVID,DDGLDEL,8) S X=0 X DDGLZOSF("RM") ; ;I $D(DA) H 2 W $P(DDGLCLR,DDGLDEL,2) D R^DDSR S Y=0 Q I $D(DA) S:$Y>(DDSHBX+1) DDSKM=1,DDM=1 S Y=0 Q ; S Y=1,DA=DDS6DA I '$G(DDSCHANG),$G(DDSPARM)["C" S DDSCHANG=1 F DDSI=1:1 Q:$D(DDS6DA(DDSI))[0 S DA(DDSI)=DDS6DA(DDSI) Q ; K(DDSIEN,DIE) ;Remove all data pertaining to the (sub)record from @DDSREFT ;In: DDSIEN = IENS of record being deleted ; DIE = global root ; N B,P,FN,PAT,PDA,IENS S PAT=".E1"""_DDSIEN_"""" ; ;Loop through all pages/blocks in ^TMP S P=0 F S P=$O(@DDSREFT@(P)) Q:'P D . S B=0 F S B=$O(@DDSREFT@(P,B)) Q:'B D .. ;Get file number of the block .. S FN="F"_$P(@DDSREFS@(P,B),U,3) .. ; .. ;Loop through all records loaded for that block .. S IENS=" " B .. F S IENS=$O(@DDSREFT@(P,B,IENS)) Q:IENS'["," D ... ; ... ;If the data pertains to the current or ancestor file, kill it ... ;Get the parent IENS (also indicates the block is repeating) ... S PDA=$P($G(@DDSREFT@(P,B,IENS)),U,2) ... ; ... I 'PDA,IENS?@PAT,$P(@DDSREFT@(P,B,IENS,"GL"),DIE)="" D .... K @DDSREFT@(P,B,IENS) .... K @DDSREFT@(FN,IENS) SUB ... E I $P($G(@DDSREFT@(P,B,IENS)),U,6)!PDA,@DDSREFT@(P,B,IENS,"GL")=DIE D ;IF IT'S A MULTIPLE IN A REPEATING BLOCK .... D DELP(P,B,PDA,DDSIEN) .... K @DDSREFT@(FN,DDSIEN) Q ; DELP(P,B,PDA,IENS) ;Delete subrecord from parent's list ;In: P = page number ; B = block number ; PDA = parent IENS ; IENS = IENS of record to remove N R,S ; S S=$G(@DDSREFT@(P,B,PDA,"B",IENS)) Q:'S K @DDSREFT@(P,B,PDA,"B",IENS) ; F S=S:1 Q:$D(@DDSREFT@(P,B,PDA,S+1))[0 D . S R=@DDSREFT@(P,B,PDA,S+1) . S @DDSREFT@(P,B,PDA,S)=R . S @DDSREFT@(P,B,PDA,"B",R)=S K @DDSREFT@(P,B,PDA,S) Q ; DEL ;Delete (sub)records added between saves ;(user quit without saving) N DA,DIK S DDSI=0 F S DDSI=$O(@DDSREFT@("ADD",DDSI)) Q:'DDSI D . K DA . S DA=$P(@DDSREFT@("ADD",DDSI),U),DIK=U_$P(^(DDSI),U,2) . F DDSX=2:1:$L(DA,",")-1 S DA(DDSX-1)=$P(DA,",",DDSX) . S DA=+DA . D ^DIK K DDSI,DDSX Q ;#8078 record ;#8079 subrecord ;#8080 WARNING: DELETIONS ARE DONE... ;#9038 Enter 'Y' to delete... DDS7 DDS7 ;SFISC/MKO-Relational ;1:39 PM 28 Jun 1996 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. RPB(DDP,DDSFLD,DDSPG) ;Repaint pointed-to block(s) recursively N DDS7B S DDS7B="" F S DDS7B=$O(@DDSREFS@("PT",DDP,DDSFLD,DDSPG,DDS7B)) Q:DDS7B="" D . N DDP,DDSFLD . I $P($G(@DDSREFS@(DDSPG,DDS7B)),U,8) D .. D BLK^DDS1(DDSPG,DDS7B,"","",1) .. D DB^DDSR(DDSPG,DDS7B) . S DDP=$P($G(@DDSREFS@(DDSPG,DDS7B)),U,3) . D:$D(@DDSREFS@("PT",DDP)) .. S DDSFLD="" .. F S DDSFLD=$O(@DDSREFS@("PT",DDP,DDSFLD)) Q:DDSFLD="" D ... D:$D(@DDSREFS@("PT",DDP,DDSFLD,DDSPG)) RPB(DDP,DDSFLD,DDSPG) Q ; RPF(DDP,DDSPTB,DDSDA,DA) ;Repaint and update pointer field of ;pointer blocks because user changed the .01 value S DDS7V=$G(@DDSREFT@("F"_DDP,DDSDA,.01,"D")) I DDS7V]"",$D(^("X"))#2 S DDS7V=^("X") S DDS7DAS=U_DA_U F DDS7I=$L(DDSPTB,U):-1:1 D Q:$G(DDS7FD)'=.01 . S DDS7PTB=$P(DDSPTB,U,DDS7I) . D:DDS7PTB]"" RPF1 K DDS7B,DDS7D,DDS7DA,DDS7DAS,DDS7DAST,DDS7DDO,DDS7FD,DDS7FI K DDS7I,DDS7L,DDS7PTB,DDS7REF,DDS7RJ,DDS7V,DDS7X Q RPF1 ; I DDS7PTB[";J" S DDS7FD="" Q S DDS7PTB=$P(DDS7PTB,";") I $L(DDS7PTB,",")=2 S DDS7FI=+DDS7PTB,DDS7FD=$P(DDS7PTB,",",2) E I $L(DDS7PTB,",")=3 S DDS7FI=0,DDS7FD=$P(DDS7PTB,",",2,3) E Q Q:DDS7FI=""!(DDS7FD="") ; ;Repaint pointer field on current page S DDS7B="" F S DDS7B=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B)) Q:DDS7B="" D . S DDS7DDO="" . F S DDS7DDO=$O(@DDSREFS@("F"_DDS7FI,DDS7FD,"L",DDSPG,DDS7B,DDS7DDO)) Q:DDS7DDO="" D .. Q:$G(@DDSREFS@(DDSPG,DDS7B,DDS7DDO,"D"))="" S DY=+^("D"),DX=$P(^("D"),U,2),DDS7L=$P(^("D"),U,3),DDS7RJ=$P(^("D"),U,10) .. X IOXY .. S DDS7X=$P(DDGLVID,DDGLDEL)_$E(DDS7V,1,DDS7L)_$P(DDGLVID,DDGLDEL,10) .. W $S(DDS7RJ:$J(" ",DDS7L-$L(DDS7V))_DDS7X,1:DDS7X_$J(" ",DDS7L-$L(DDS7V))) ; ;Reset external form of pointer data. ; ;If the pointer field is the .01, then we may have to follow back ;to pointers that point to this pointer block. ; ;DDS7DAS initially contains a list of records whose .01s we changed. ;DDS7DAST keeps a running list of all records in the pointer block ;that we change. ;DDS7DAS is finally set to this running list, so that when we go ;to update the pointer to the pointer block, we know which pointers ;to update. ; S DDS7DAST="",DDS7DA=" " F S DDS7DA=$O(@DDSREFT@("F"_DDS7FI,DDS7DA)) Q:DDS7DA'["," D . S DDS7REF=$NA(@DDSREFT@("F"_DDS7FI,DDS7DA,DDS7FD)) . S DDS7D=$G(@DDS7REF@("D")) . I DDS7DAS[(U_$P(DDS7D,";")_U),$S(DDS7D[";":U_$P(DDS7D,";",2)=DIE,1:1) D .. I DDS7V="",DDS7FD'=.01 S @DDS7REF@("D")="",^("F")=3 .. S:$D(@DDS7REF@("X"))#2 ^("X")=$S(DDS7V=""&(DDS7FD=.01):@DDS7REF@("D"),1:DDS7V) .. I DDS7FD=.01,DDS7DAST_U'[(U_+DDS7DA_U) S DDS7DAST=DDS7DAST_U_+DDS7DA S DDS7DAS=DDS7DAST_U Q DDSBOX DDSBOX(DDSUL,DDSLR) ;SFISC/MKO-DRAW A BOX ;08:17 AM 9 Apr 1993 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D BOUNDS Q:'Y ; S DDS3L="" S $P(DDS3L,$P(DDGLGRA,DDGLDEL,3),$P(DDSLR,",",2)-$P(DDSUL,",",2))="" S DDS3M=$P(DDGLGRA,DDGLDEL,4)_$J("",$P(DDSLR,",",2)-$P(DDSUL,",",2)-1)_$P(DDGLGRA,DDGLDEL,4) ; S DY=$P(DDSUL,",")-1,DX=$P(DDSUL,",",2)-1 X IOXY W $P(DDGLGRA,DDGLDEL)_$P(DDGLGRA,DDGLDEL,5)_DDS3L_$P(DDGLGRA,DDGLDEL,6) ; F DY=$P(DDSUL,","):1:$P(DDSLR,",")-2 D . S DX=$P(DDSUL,",",2)-1 X IOXY . W DDS3M ; S DY=$P(DDSLR,",")-1,DX=$P(DDSUL,",",2)-1 X IOXY W $P(DDGLGRA,DDGLDEL,7)_DDS3L_$P(DDGLGRA,DDGLDEL,8)_$P(DDGLGRA,DDGLDEL,2) ; K DDS3L,DDS3M Q ; CLEAR(DDSUL,DDSLR) ;Clear area within upper left and lower right coords N S D BOUNDS Q:'Y ; S S=$J("",$P(DDSLR,",",2)-$P(DDSUL,",",2)+1) S DX=$P(DDSUL,",",2)-1 F DY=$P(DDSUL,",")-1:1:$P(DDSLR,",")-1 X IOXY W S Q ; BOUNDS ;Make sure area is within acceptable boundaries N DDSV,DDSP S Y=1 I $G(DDSUL)=""!($G(DDSLR))="" S Y=0 Q ; F DDSV="DDSUL","DDSLR" D . S:$P(@DDSV,",")>DDSHBX $P(@DDSV,",")=DDSHBX . S:$P(@DDSV,",",2)>(IOM-1) $P(@DDSV,",",2)=IOM-1 . F DDSP=1,2 S:$P(@DDSV,",",DDSP)<1 $P(@DDSV,",",DDSP)=1 ; I $P(DDSLR,",")-$P(DDSUL,",")<2 S Y=0 Q I $P(DDSLR,",",2)-$P(DDSUL,",",2)<2 S Y=0 Q ; Q DDSCAP DDSCAP ;SFISC/MKO-INPUT TRANSFORM FOR CAPTIONS ;01:24 PM 14 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; FUNC(X) ; Q:$E(X)'="!" N E,F,Y S F=$E(X,2,999) S:$P(F,"(")?.A1.L.A F=$$UPCASE($P(F,"("))_$S(F["(":"("_$P(F,"(",2,999),1:"") Q:$P(F,"(")'?1U.7UN X Q:$T(@$P(F,"("))="" X ; D Q:$G(E) X . N X S X="S Y=$$"_F . N F D ^DIM . S:'$D(X) E=1 ; S @("Y=$$"_F) Q Y ; L() ;;Get label of field N F1,F2 S X="" S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X S X=$P($G(^DD(F2,F1,0)),U) Q X ; T() ;;Get title of field N F1,F2 S X="" S F1=$$GET^DDSVAL(DIE,.DA,4) Q:'F1 X S F2=$$GET^DDSVAL(.404,DA(1),1) Q:'F2 X S X=$G(^DD(F2,F1,.1)) Q X ; U() ;;Get unique name of field Q $$GET^DDSVAL(DIE,.DA,3.1) ; DUP(X1,X) ;;The DUP function Q:$G(X1)="" "" N % S %=X,X="",$P(X,X1,%\$L(X1)+1)=X1,X=$E(X,1,%) Q X ; UPCASE(X) ;Convert X to uppercase Q $$UP^DILIBF(X) ;** DDSCLONE DDSCLONE ;SFISC/MKO-CLONE A FORM ;2OCT2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N %,%CHK,%RET,%X,%Y,D,D0,D1,DA,DI,DIOVRD,DIC,DIR,DIZ,DQ,DREF,X,Y K ^TMP("DDSCLONE",$J) S DDSQUIT=0,DIOVRD=1 ; S DDSFORM=$$FORM G:DDSFORM=-1 QUIT ; D GETBLKS D REPORT G:DDSQUIT QUIT D RENMSP G:DDSQUIT QUIT D RENAME G:DDSQUIT QUIT D ^DDSCLONF DONE I '$G(DDSQUIT) W !!!,"DONE!" ; QUIT ;Cleanup K ^TMP("DDSCLONE",$J) K DDSBK,DDSBKDA,DDSFILE,DDSFORM,DDSNFRM,DDSNNS,DDSONS,DDSQUIT K DDH,DIRUT,DIROUT,DTOUT,DUOUT Q ; FORM() ;Prompt for form ;Select file N D,DIC EGP S DDS1=8108 D W^DICRW K DDS1 G:Y<0 FORMQ ;**CCO/NI 'CLONE FORM' I '$D(@(DIC_"0)")) S Y=-1 G FORMQ S DDSFILE=Y ; ;Select form W ! K DIC S DIC="^DIST(.403,",DIC(0)="QEAM" S DIC(0)="QEA",D="F"_+DDSFILE S DIC("S")="I $P(^(0),U,8)=+DDSFILE" S DIC("A")="Select FORM to clone: " S DIC("W")=$P($T(DICW),";",3,999) DICW ;;N %G S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE OUTOUT D IX^DIC ; FORMQ Q Y ; GETBLKS ;Get all blocks on form ; ^TMP("DDSCLONE",$J,bk#)=Block name ; N B,P S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2) . I B]"",'$D(^TMP("DDSCLONE",$J,B)) D .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U) . S B=0 . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D .. Q:$D(^TMP("DDSCLONE",$J,B)) .. S ^TMP("DDSCLONE",$J,B)=$P($G(^DIST(.404,B,0)),U) Q ; REPORT ;Print report N B W !!! I '$D(^TMP("DDSCLONE",$J)) S DDSQUIT=1 W "There are no blocks on this form." Q ; W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")" W !!," Internal" W !," Entry Number Block Name" W !," ------------ ----------" ; S B="" F S B=$O(^TMP("DDSCLONE",$J,B)) Q:B="" D . W !," "_B,?17,$P(^TMP("DDSCLONE",$J,B),U) ; K DIR S DIR(0)="E" W ! D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 W ! Q ; RENMSP ;Prompt for new namespace W !!,"The new form and blocks must be given unique names.",! ; K DIR S DIR(0)="Y",DIR("B")="YES" S DIR("A",1)="Give the new form and blocks the same names as the original," S DIR("A")="but a different namespace" S DIR("?",1)=" Answer 'YES' if the original form and blocks are namespaced, and you want" S DIR("?")=" the new forms and blocks to have a different namespace." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q I 'Y K DDSONSP,DDSNNSP Q ; K DIR W !! S DIR(0)="FA^1:30" S DIR("A")="Original namespace: " S DIR("?")=" Enter the namespace of the original form and blocks" D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSONS=Y ; K DIR,X,Y S DIR(0)="FA^1:30" S DIR("A")=" New namespace: " S DIR("?")=" Enter the namespace of the new form and blocks" D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSNNS=Y K X,Y Q ; RENAME ;Prompt for new names N DDSBK,DDSBKDA D:'$D(IOST) HOME^%ZIS W @IOF W "Enter names for the new form and blocks." ; D RENFORM Q:DDSQUIT ; W ! S DDSBKDA=0 F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA) . D RENBLK(.DDSBK) Q:DDSQUIT . S ^TMP("DDSCLONE",$J,DDSBKDA)=DDSBK . S ^TMP("DDSCLONE",$J,"B",$P(DDSBK,U,2))="" ; Q ; RENFORM ;Rename the form N DDSANS,DDSCOD F D Q:DDSANS]""!DDSQUIT . W !!,"Original form name: "_$P(DDSFORM,U,2) . W !," New form name: " . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSFORM,U,2),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD) . ; . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS="" . Q:DDSANS="" . S X=DDSANS X $P(^DD(.403,.01,0),U,5,999) . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q . I $D(^DIST(.403,"B",DDSANS)) D Q .. S DDSANS="" .. W !!,$C(7)_" Form with this name already exists." Q:DDSQUIT ; S $P(DDSFORM,U,3)=DDSANS Q ; RENBLK(DDSBK) ;Rename the blocks N DDSANS,DDSCOD F D Q:DDSANS]""!DDSQUIT . W !!,"Original block name: "_$P(DDSBK,U) . W !," New block name: " . D EN^DIR0($S($Y>IOSL:IOSL-1,1:$Y),$X,30,1,$$NAME($P(DDSBK,U),$G(DDSONS),$G(DDSNNS)),30,"","","",.DDSANS,.DDSCOD) . ; . I $P(DDSCOD,U)="TO"!(DDSANS=U) S DDSQUIT=1 Q . I DDSANS?1."?" W !!," Enter the name of the new form." S DDSANS="" . Q:DDSANS="" . S X=DDSANS X $P(^DD(.404,.01,0),U,5,999) . I '$D(X) S DDSANS="" W !!,$C(7)_" Invalid name." Q . D:$D(^DIST(.404,"B",DDSANS))!$D(^TMP("DDSCLONE",$J,"B",DDSANS)) .. S DDSANS="" .. W !!,$C(7)_" Block with this name already exists." Q:DDSQUIT ; S $P(DDSBK,U,2)=DDSANS Q ; NAME(NAME,ONS,NNS) ;Replace old namespace with new I $G(ONS)=""!($G(NNS)="") Q NAME I $P(NAME,ONS)]"" Q NAME Q NNS_$E(NAME,$L(ONS)+1,999) DDSCLONF DDSCLONF ;SFISC/MKO-CLONE A FORM ;15OCT2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D ASKCONT Q:DDSQUIT D CREATBK Q:DDSQUIT D CREATFM Q:DDSQUIT D EDITFM D INDEXFM K DDSNFRM Q ; CREATBK ;Create blocks N DA,DIC W !!,"Creating new blocks ...",! S DDSBKDA=0 F S DDSBKDA=$O(^TMP("DDSCLONE",$J,DDSBKDA)) Q:'DDSBKDA!DDSQUIT D . S DDSBK=^TMP("DDSCLONE",$J,DDSBKDA) . W !?2,$P(DDSBK,U,2) . K DIC,DD,DO . S DIC="^DIST(.404,",DIC(0)="QL",X=$P(DDSBK,U,2) . D FILE^DICN K DIC . I Y=-1 D Q .. W !,$C(7)_"Attempt to create block "_$P(DDSBK,U,2)_" failed." .. S DDSQUIT=1 . M ^DIST(.404,+Y)=^DIST(.404,DDSBKDA) . S $P(^DIST(.404,+Y,0),U)=$P(DDSBK,U,2) . W ?35,"#"_+Y . S $P(^TMP("DDSCLONE",$J,DDSBKDA),U,3)=+Y Q ; CREATFM ;Create form N DA,DIC,DDSI,DDSJ W !!,"Creating new form ..." W !?2,$P(DDSFORM,U,3) K DIC S DIC="^DIST(.403,",DIC(0)="QL",X=$P(DDSFORM,U,3) D FILE^DICN K DIC I Y=-1 D Q . W !,$C(7)_"Attempt to create form "_$P(DDSFORM,U,3)_" failed." . S DDSQUIT=1 M ^DIST(.403,+Y)=^DIST(.403,+DDSFORM) S $P(^DIST(.403,+Y,0),U,5)=DT ;GFT CREATE DATE IS TODAY! ; ;Kill page and block multiple indexes S DDSJ=" " F S DDSJ=$O(^DIST(.403,+Y,40,DDSJ)) Q:DDSJ="" D . K ^DIST(.403,+Y,40,DDSJ) S DDSI=0 F S DDSI=$O(^DIST(.403,+Y,40,DDSI)) Q:'DDSI D . S DDSJ=" " . F S DDSJ=$O(^DIST(.403,+Y,40,DDSI,40,DDSJ)) Q:DDSJ="" D .. K ^DIST(.403,+Y,40,DDSI,40,DDSJ) K @$$REF^DDS0(+Y) ; S $P(^DIST(.403,+Y,0),U)=$P(DDSFORM,U,3) W ?35,"#"_+Y S DDSNFRM=+Y Q ; EDITFM ;Edit blocks used on new form W !!,"Repointing to new blocks ..." N DDSBK,DDSNBK,DDSPG S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSNFRM,40,DDSPG)) Q:'DDSPG D . S DDSBK=$P(^DIST(.403,DDSNFRM,40,DDSPG,0),U,2) . I DDSBK]"" D .. N DIE,DA,DR .. S DIE="^DIST(.403,"_DDSNFRM_",40," .. S DA(1)=DDSNFRM,DA=DDSPG .. S DR="1////"_$P(^TMP("DDSCLONE",$J,DDSBK),U,3) .. D ^DIE . ; . N DA,DIK . S DIK="^DIST(.403,"_DDSNFRM_",40,"_DDSPG_",40," . S DA(2)=DDSNFRM,DA(1)=DDSPG . S DDSBK=0 . F S DDSBK=$O(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK D .. Q:$D(^TMP("DDSCLONE",$J,DDSBK))[0 S DDSNBK=$P(^(DDSBK),U,3) .. M ^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK)=^DIST(.403,DDSNFRM,40,DDSPG,40,DDSBK) .. S $P(^DIST(.403,DDSNFRM,40,DDSPG,40,DDSNBK,0),U)=DDSNBK .. S DA=DDSBK .. D ^DIK Q ; INDEXFM ;Index new form W !,"Reindexing new form ..." N DIK,DA S DIK="^DIST(.403,",DA=DDSNFRM D IX1^DIK ; D EN^DDSZ(DDSNFRM) Q ; ASKCONT ;Final chance to abort K DIR S DIR(0)="Y" S DIR("A",1)="" S DIR("A")="Ready to clone form" S DIR("?")=" Enter 'Y' to clone form. Enter 'N' to exit." D ^DIR K DIR S:$D(DIRUT)!'Y DDSQUIT=1 Q DDSCOM DDSCOM ;SFISC/MLH-COMMAND UTILS ;12NOV2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. COM ;Command line prompt D:$G(@DDSREFT@("HLP"))>0 HLP^DDSMSG() N DDSCOM,DIR K DTOUT D SETUP(.DDSCOM,.X,.DIR) S DIR("?",1)=X S DIR("A")=$$EZBLD^DIALOG(8000),DIR("?",2)=" ",DIR("?")=$$EZBLD^DIALOG($S($G(DDSMOUSY):8000.101,1:8000.1)) ;'COMMAND' LINE & 'Enter a COMMAND' S DIR("??")="^D CHLP^DDSCOM" D:'$G(DDSKM) .K DDH,DDQ .F DDH=1:1:IOSL-DDSHBX-6 S DDH(DDH,"T")=" " ;ERASE EVERYTHING IN HELP AREA... .S DDH=DDH+1,DDH(DDH,"T")=DIR("?",1) .S DDH=DDH+1,DDH(DDH,"T")=DIR("?",2) .S DDH=DDH+1,DDH(DDH,"T")=DIR("?") .D SC^DDSU S DDM=1 K DDSKM S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^30^"_(IOSL-1)_"^0" D ^DIR K DUOUT,DIROUT,DIRUT TRANS S:X?1A.E (X,Y,Y(0))=$E("ECSNRPQ",$F(DIR("X"),$E($$UP^DILIBF(X)))-1) M DDSMOUSE(IOSL-5)=DDSCOM ;...DOWN TO 'Exit Save....' REMEMBER WHERE THESE SHOW FOR MOUSE D:X="C" . S:DDACT="N" Y="c" . S Y(0)="CLOSE" . S:DDACT'="N" (X,Y,Y(0))="" Q ; BOT ;from DIR0 & DIR02 I DDS?.N1"^MSCXQSCR" Q ;!!!!!! N X,XVIS,I,DIR,M,DIREPLIN S DY=IOSL-1,DX=0,$X=0 X IOXY W $P(DDGLCLR,DDGLDEL) ;Clear the bottom line S DIREPLIN=$P($$EZBLD^DIALOG(7002),U,$S($G(DIR0("REP")):2,1:1)) ;INSERT/REPLACE I '$G(DDSMOUSY) D .I DDO,'$G(DDM) W $$EZBLD^DIALOG(8000) ;**'COMMAND:' E I DDO D .D SETUP(.M,.X,.DIR) .K DDSMOUSE(DY) M DDSMOUSE(DY)=M S DX=0 W X S X=$$EZBLD^DIALOG($G(DDSMOUSY)/10+8074),DX=IOM-$L(DIREPLIN)-3-$L(X) I DX>$X D ;'F1-H FOR HELP' or 'HELP' if we have room . X IOXY . W $P(DDGLVID,DDGLDEL,10)_$P(DDGLVID,DDGLDEL,6)_X_$P(DDGLVID,DDGLDEL,10) .S DDSMOUSE(DY,DX,DX+$L(X)-1)="H^DIR0H" S DX=IOM-$L(DIREPLIN)-1 X IOXY W $S('$D(DDGLVAN):$P(DDGLVID,DDGLDEL,6),1:"")_DIREPLIN_$P(DDGLVID,DDGLDEL,10) ;INSERT/REPLACE S DDSMOUSE(DY,DX,DX+$L(DIREPLIN)-1)="RPM^DIR01" ;Make 'REPLACE' clickable Q ; ; ; SETUP(DDSM,X,DIR) ;DDSM, DIR, & X are return variables ;DDSM shows mouse positions ;DIR is array ;X is writeable string K DDSM,DIR("X") N DDSCH,DDSPP,XVIS F X=1:1:7 S DDSCH(X)=$$EZBLD^DIALOG(X/100+8000),$E(DIR("X"),X)=$C($A(DDSCH(X))),DDSCH(X,0)=$C($A(DDSCH(X))+32)_":"_$$UP^DILIBF(DDSCH(X)) S DDSPP=$$PP^DDS5(.X) I 'X S DDSPP="" ;Previous Page S X="" ;This will be the string of COMMANDs, with control sequences to highlight S XVIS="" ;just visible chars S DIR(0)="SO^" I DDSSC>1!$P(DDSSC(DDSSC),U,4) D ;POP-UP PAGE. IT ALSO DID THIS IF $G(DDSSEL) .D EXSANEXR(2,"CL"),EXSANEXR(5,"RF") .S DIR("B")=DDSCH(2) ;"Close" in Command Line E D .D EXSANEXR(1,"EX") D:$D(DDSFDO)[0 EXSANEXR(3,"SV") D:DDSNP]"" EXSANEXR(4,"NP^DDS2") D:DDSPP]"" EXSANEXR(6,"PP") D EXSANEXR(5,"RF") D EXSANEXR(7,"QT") S X=$E(X,1,$L(X)-4) Q EXSANEXR(N,JUMP) S DIR(0)=DIR(0)_DDSCH(N,0)_";",N=DDSCH(N),DDSM=$L(XVIS) S XVIS=XVIS_N_" " ;BUILD 'Exit Save ...' STRING I $G(DDSMOUSY) S X=X_$$HIGH^DDSU(N)_" " E S X=XVIS S DDSM(DDSM,DDSM+$L(N)-1)=JUMP ;Mouse positions for each character of displayed text Q ; ; ; CHLP ; K DDH,DDQ S DDH=0,DDS3CD=$P(DIR(0),U,2) F DDS3PC=1:1:$L(DDS3CD,";") D . S DDS3C=$C($A($P($P(DDS3CD,";",DDS3PC),":"))-32) . I "^E^C^S^N^R^P^Q^"[(U_DDS3C_U) D .. S DDH=DDH+1 .. S DDH(DDH,"T")=$E($P($T(@("H"_DDS3C)),";",3)_" ",1,11)_"- "_$$EZBLD^DIALOG($P($T(@("H"_DDS3C)),";",4)) ;**CC0/NI THE DIFFERENT COMMAND-LINE RESPONSES D:DDH>0 SC^DDSU K DDS3C,DDS3CD,DDS3PC Q HE ;;Exit;8000.11;**CCO/NI CHANGED THRU BOTTOM OF ROUTINE HC ;;Close;8000.12 HS ;;Save;8000.13 HN ;;Next Page;8000.14 HR ;;Refresh;8000.15 HP ;;Previous Page;8000.16 HQ ;;Quit;8000.17 DDSCOMP DDSCOMP ;SFISC/MKO-EVALUATE COMPUTED EXPRESSIONS ;8:55 AM 12 Feb 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PARSE(DDP,EXP,BK,NEXP,AR,FDL) ;Parse the computed expression EXP ;Returns: ; NEXP = EXP with {expr} replaced with DDSE(n) ; AR = array when executed sets DDSE(n) ; FDL = list of fields referenced N I,J,N,ST ; S NEXP="",(N,AR)=0,ST=1 S I=0 F D Q:'I!$G(DIERR) . S I=$$FIND^DDSLIB(EXP,"{",I) Q:'I . S N=N+1 . S NEXP=NEXP_$E(EXP,ST,I-2)_"DDSE("_N_")" . S ST=$$FIND^DDSLIB(EXP,"}",I) . D EVAL(DDP,$E(EXP,I,ST-2),BK,N,.AR,.FDL) Q:$G(DIERR) . S I=ST Q:$G(DIERR) S NEXP=$S(EXP?1"=".E:"S Y",1:"")_NEXP_$E(EXP,ST,999) ; S AR=N S:$G(FDL)]"" FDL=$E(FDL,1,$L(FDL)-1) Q ; EVAL(DDP,EXP,BK,N,AR,FDL) ;Evaluate field expression ;In: ; EXP = computed expr ; N = expr number -- index into DDSE() ;Out: ; AR = array of code that sets DDSE(n) ; FDL = list of fields used in expr ; N CD D:EXP?1"FO(".E FO^DDSPTR(DDP,EXP,"","",BK,.CD,.FDL,1) D:EXP'?1"FO(".E DD^DDSPTR(DDP,EXP,"",.CD,.FDL,1) Q:$G(DIERR) ; I CD=1 S AR(N)="N X "_CD(1)_",DDSE("_N_")=X" E D . F CD=1:1:CD S AR(N,CD)=CD(CD) . S AR(N,CD)=AR(N,CD)_",DDSE("_N_")=X" . S AR(N)="N DDSI,X S DDSE("_N_")="""" F DDSI=1:1:"_CD_" Q:DDSI>1&($G(X)'>0)!'$D(*DDSREFC*,DDSI)) X ^(DDSI)" Q ; RPCF(DDSPG) ;Repaint computed fields ;Called from ^DDS01 and ^DDSVALF when value used in ;computed expression changes N DDSCBK,DDSCDDO ; S DDSCBK="" F S DDSCBK=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK)) Q:DDSCBK="" D . I $P($G(@DDSREFS@(DDSPG,DDSCBK)),U,7)>1 D DB^DDSR(DDSPG,DDSCBK) Q . N DA,DDSDA . D GETDA(DDSPG,DDSCBK,.DA) . S DDSDA=$$DDSDA(.DA) . S DDSCDDO="" F S DDSCDDO=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK,DDSCDDO)) Q:DDSCDDO="" D RPCF1 ; Q ; RPCF1 ; N DDSC,DDSE,DDSLEN,DDSX S DDSC=$G(@DDSREFS@(DDSPG,DDSCBK,DDSCDDO,"D")) Q:DDSC="" S DDSX=$$VAL(DDSCDDO,DDSCBK,DDSDA) ; S DY=+DDSC,DX=$P(DDSC,U,2),DDSLEN=$P(DDSC,U,3) I $P(DDSC,U,10) S DDSX=$J("",DDSLEN-$L(DDSX))_$E(DDSX,1,DDSLEN) E S DDSX=$E(DDSX,1,DDSLEN)_$J("",DDSLEN-$L(DDSX)) X IOXY W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10) ; N DDP,DDSFLD S DDP=0,DDSFLD=DDSCDDO_","_DDSBK D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF(DDSPG) ; Q ; GETDA(P,B,DA) ;Get DA array of block N I K DA S DA=$G(@DDSREFT@(P,B)) Q:DA="" Q:'$G(^(B,DA)) F I=2:1:$L(DA,",")-1 S DA(I-1)=$P(DA,",",I) S DA=+DA Q ; VAL(DDSDDO,DDSBK,DDSDA) ;Return value of computed field N DDSE,DDSX,Y I $D(DDSDA) N DA D DA(DDSDA,.DA) S DDSX=0 F S DDSX=$O(@DDSREFS@("COMPE",DDSBK,DDSDDO,DDSX)) Q:DDSX="" X ^(DDSX) K Y X $G(@DDSREFS@("COMPE",DDSBK,DDSDDO)) Q $G(Y) ; DA(DDSDA,DA) ;Return DA array based on DDSDA N I S DA=$P(DDSDA,",") F I=2:1:$L(DDSDA,",") S DA(I-1)=$P(DDSDA,",",I) Q ; DDSDA(DA) ;Return DDSDA based on DA array N DDSDA,I I $G(DA)="" S DDSDA="0," E D . S DDSDA=DA_"," . F I=1:1 Q:$G(DA(I))="" S DDSDA=DDSDA_DA(I)_"," Q DDSDA DDSDBLK DDSDBLK ;SFISC/MKO-DELETE UNUSED BLOCKS ;01:25 PM 11 Oct 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N %,D,DIAC,DIC,DIFILE,DIOVRD,X,Y D INIT S DDSFILE=$$FILE G:DDSFILE=-1 QUIT D SUB(+DDSFILE,DDSSUB),FINDB(DDSSUB,DDSBLK),PROC,QUIT Q ; ALL ;Purge all unused blocks regardless of file N %,DIC,DIOVRD,X,Y K DDSFILE D INIT,FINDALL(DDSBLK),PROC,QUIT Q ; PROC ;Delete blocks in @DDSBLK I '$D(@DDSBLK) D Q . W !!!,"There are no unused blocks associated with this file." ; D REPORT D ASKDEL Q:DDSQUIT D ASKCONT Q:DDSQUIT ; ;Delete blocks D:$G(DDSDEL) DELNPR D:'$G(DDSDEL) DELPR W !!,"DONE!" Q ; INIT ;Initialize variables S (DDSDEL,DDSQUIT)=0,DIOVRD=1 S DDSBLK=$NA(^TMP("DDSDBLK",$J,"BLK")) S DDSSUB=$NA(^TMP("DDSDBLK",$J,"SUB")) K @DDSBLK,@DDSSUB Q ; QUIT ;Cleanup K @DDSBLK,@DDSSUB K DDSBLK,DDSDEL,DDSFILE,DDSQUIT,DDSSUB K DDH,DIRUT,DIROUT,DTOUT,DUOUT Q ; FINDB(DDSSUB,DDSBLK) ;Find blocks associated with a specific file N B,B0,N S B=0 F S B=$O(^DIST(.404,B)) Q:'B S B0=$G(^(B,0)) D . S N=$P(B0,U,2) . I N,$D(@DDSSUB@(N)),'$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) S @DDSBLK@(B)=$P(B0,U) Q ; FINDALL(DDSBLK) ;Find all unused blocks N B,B0 S B=0 F S B=$O(^DIST(.404,B)) Q:'B S B0=$G(^(B,0)) D . I '$D(^DIST(.403,"AB",B)),'$D(^DIST(.403,"AC",B)) D .. S @DDSBLK@(B)=$P(B0,U) Q ; FILE() ;Prompt for form ;Select file N DIC,Y EGP S DDS1=8108.1 D W^DICRW K DDS1 G:Y<0 FILEQ ;**CCO/NI 'PURGE UNUSED BLOCKS' S:'$D(@(DIC_"0)")) Y=-1 FILEQ Q Y ; DELPR ;Delete blocks with prompting N DDSB W ! K DIK,DIR,DIRUT S DIR(0)="YA",DIR("B")="NO" S DIR("?")=" Enter 'Y' to delete, 'N' to keep." S DIK="^DIST(.404," ; S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT D . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? " . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y . S DA=DDSB D ^DIK K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT Q ; DELNPR ;Delete blocks without prompting N DDSB W ! K DIK S DIK="^DIST(.404," S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..." . S DA=DDSB D ^DIK K DIK,DA Q ; ASKDEL ;Ask if user wants to delete all unused blocks w/o confirmation W ! S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Delete all unused blocks without prompting (Y/N)? " S DIR("?",1)=" Enter 'Y' to delete unused blocks from the BLOCK file" S DIR("?",2)=" without confirmation." S DIR("?",3)="" S DIR("?")=" Enter 'N' to confirm each delete." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSDEL=Y Q ; ASKCONT ;Final chance to abort K DIR S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Continue (Y/N)? " S DIR("?")=" Enter 'Y' to delete form. Enter 'N' to exit." D ^DIR K DIR S:$D(DIRUT)!'Y DDSQUIT=1 Q ; REPORT ;Print report N B W !!! W " UNUSED BLOCKS" W:$D(DDSFILE) " ASSOCIATED WITH FILE "_$P(DDSFILE,U,2)_" (#"_$P(DDSFILE,U)_")" W !!," Internal" W !," Entry Number Block Name" W !," ------------ ----------" ; S B="" F S B=$O(@DDSBLK@(B)) Q:B="" W !," "_B,?17,@DDSBLK@(B) Q ; SUB(FN,OUT) ; ;Set OUT array for file number FN and all its subfiles N SUB I $D(^DD(FN)) S @OUT@(FN)="" S SUB="" F S SUB=$O(^DD(FN,"SB",SUB)) Q:SUB="" D SUB(SUB,OUT) Q DDSDEL DDSDEL ;SFISC/MKO-DELETE FORMS FOR A FILE ;24JUL2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; FORM(DDSFILE,DDSECHO) ; ;Delete all forms/blocks associated with file DDSFILE N DDSREF,DDSBLK,DDSBNAM,DDSFRM,DDSOFRM,DDSLN,DDSPDD,DDSPG N %,DIK,DIOVRD,DA,D0,X,Y I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIOVRD=1 D SETUP,GETFORMS(DDSFILE,DDSREF) ; ;Delete forms W:DDSECHO !?3,"Deleting the FORMS..." S DDSFRM="",DIK="^DIST(.403," F S DDSFRM=$O(@DDSREF@("FRM",DDSFRM)) Q:'DDSFRM S DA=DDSFRM D ^DIK K DIK,DA ; ;Delete blocks W:DDSECHO !?3,"Deleting the BLOCKS..." S DDSBLK="",DIK="^DIST(.404," F S DDSBLK=$O(@DDSREF@("BLK",DDSBLK)) Q:'DDSBLK D . S DDSLN=@DDSREF@("BLK",DDSBLK) . S DDSBNAM=$P(DDSLN,U),DDSOFRM=$P(DDSLN,U,2),DDSPDD=$P(DDSLN,U,3) . ; . I DDSOFRM,DDSPDD D .. I DDSECHO D ... W !!?3,$C(7)_"*** Warning ***" ... W !!?3,"Block "_DDSBNAM_" (#"_DDSBLK_")" ... W !?3,"was deleted from the Block file." ... W !!?3,"I'm deleting pointers to that block from" .. S DDSFRM="" .. F S DDSFRM=$O(@DDSREF@("BLK",DDSBLK,DDSFRM)) Q:'DDSFRM D ... W:DDSECHO !?6,"Form "_$P(^DIST(.403,DDSFRM,0),U)_" (#"_DDSFRM_") ..." ... D DELBLK(DDSBLK,DDSFRM) .. W:DDSECHO !!?3,"The above form(s) need to be redesigned.",! . ; . E I 'DDSOFRM D .. S DA=DDSBLK D ^DIK ; QUIT ;Cleanup and quit K @DDSREF Q ; SETUP ;Setup local variables S:$D(DDSECHO)[0 DDSECHO=0 S DDSREF="^TMP(""DDSDEL"","""_$J_""")" ;IF $J IS NOT NUMERIC K @DDSREF Q ; GETFORMS(FILE,REF) ; ;Get all forms and blocks associated with file number FILE ;and all subfiles associated with FILE ;Put results in ; @REF@("DD",file#) = null ; ("FRM",form#) = form name ; ("BLK",block#) = block name^used on forms not being ; deleted^dd of block is being deleted ; ("BLK",block#,form#) = null for all blocks that are found ; on a form not being deleted ; N B,F,P,FNAM ;Get DDs of file and subfiles D DD(FILE,REF) ; ;Get all forms associated with file S FNAM="" F S FNAM=$O(^DIST(.403,"F"_FILE,FNAM)) Q:FNAM="" D . S F="" F S F=$O(^DIST(.403,"F"_FILE,FNAM,F)) Q:F="" D .. Q:$D(^DIST(.403,F,0))[0 .. S @REF@("FRM",F)=$P(^DIST(.403,F,0),U) ; ;Get all blocks associated with each form S F="" F S F=$O(@REF@("FRM",F)) Q:F="" D . S P=0 F S P=$O(^DIST(.403,F,40,P)) Q:'P D .. S B=$P($G(^DIST(.403,F,40,P,0)),U,2) .. I B D SETBLK(B,REF) .. S B=0 F S B=$O(^DIST(.403,F,40,P,40,B)) Q:'B D SETBLK(B,REF) Q ; SETBLK(B,REF) ; ;Put block info into @REF N B0 S B0=$G(^DIST(.404,B,0)) Q:B0?."^" S @REF@("BLK",B)=$P(B0,U)_U_$$OTHER(B,REF)_U_($D(@REF@("DD",+$P(B0,U,2)))#2) Q ; DELBLK(DDSBLK,DDSFRM) ; ;Delete block DDSBLK from form DDSFRM N DIK,DA,D0 S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG D . I $D(^DIST(.403,DDSFRM,40,DDSPG,40,"B",DDSBLK)) D .. S DIK="^DIST(.403,"_DDSFRM_",40,"_DDSPG_",40," .. S DA(2)=DDSFRM,DA(1)=DDSPG,DA=DDSBLK .. D ^DIK Q ; DD(F,REF,K) ; ;Put file # and all its subfile #s into array @REF@("DD") ;Kill REF first if $G(K)="" N SB K:$G(K)="" @REF@("DD") S @REF@("DD",F)="" S SB="" F S SB=$O(^DD(F,"SB",SB)) Q:SB="" D DD(SB,REF,1) Q ; OTHER(B,REF) ; ;Is block B found on forms other than what's in @REF@("FRM",F)="" ;If so, put form numbers in @REF@("BLK",B,F) N F,O,C S O=0,F="" F C="AB","AC" F S F=$O(^DIST(.403,C,B,F)) Q:F="" D . I $D(@REF@("FRM",F))[0 S O=1,@REF@("BLK",B,F)="" Q O DDSDFRM DDSDFRM ;SFISC/MKO-DELETE A FORM ;11:22 AM 4 Dec 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N %,DIC,DIOVRD,X,Y D INIT S (DDSDEL,DDSQUIT)=0 ; S DDSFORM=$$FORM G:DDSFORM=-1 QUIT ; D GETBLKS D REPORT I $D(@DDSBLK) D ASKDEL G:DDSQUIT QUIT D ASKCONT G:DDSQUIT QUIT ; ;Delete form W !!,"Deleting form "_$P(DDSFORM,U,2)_" (IEN #"_+DDSFORM_") ..." S DIK="^DIST(.403,",DA=+DDSFORM D ^DIK K DIK,DA ; ;Delete blocks I DDSDEL D:'$G(DDSDEL(1)) DELPR D:$G(DDSDEL(1)) DELNPR W !!,"DONE!" D QUIT Q ; EN(DDSFORM) ;Delete form number DDSFORM N %,DA,DDSB,DDSBLK,DIC,DIK,DIOVRD,X,Y I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D INIT D GETBLKS ; ;Delete form S DIK="^DIST(.403,",DA=+DDSFORM D ^DIK K DIK,DA ; ;Delete blocks S DIK="^DIST(.404," S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D . Q:$P(@DDSBLK@(DDSB),U,2) . S DA=DDSB D ^DIK ; K @DDSBLK Q ; INIT ;Setup S DIOVRD=1 S DDSBLK=$NA(^TMP("DDSDFRM",$J,"BLK")) K @DDSBLK Q ; QUIT ;Cleanup K @DDSBLK K DDSBLK,DDSDEL,DDSFILE,DDSFORM,DDSQUIT K DDH,DIRUT,DIROUT,DTOUT,DUOUT Q ; FORM() ;Prompt for form ;Select file N D,DIC EGP S DDS1=8108.2 D W^DICRW K DDS1 G:Y<0 FORMQ ;**CCO/NI 'DELETE FORM' I '$D(@(DIC_"0)")) S Y=-1 G FORMQ S DDSFILE=Y ; ;Select form W ! K DIC S DIC="^DIST(.403,",DIC(0)="QEAM" S DIC(0)="QEA",D="F"_+DDSFILE S DIC("S")="I $P(^(0),U,8)=+DDSFILE" S DIC("A")="Select FORM to delete: " S DIC("W")=$P($T(DICW),";",3,999) DICW ;;N %G S %G=^(0) W:$X>35 ! W ?35,"#"_Y N Y S Y=$P(%G,U,5) W:Y]"" ?43,$$OUT^DIALOGU(Y,"FMTE","2D") S Y=$P(%G,U,4) W:Y]"" ?53," User #"_Y S Y=$P(%G,U,8) W:Y]"" ?65," File #"_Y ;**CCO/NI NICE DATE FORMAT D IX^DIC ; FORMQ Q Y ; GETBLKS ;Get all blocks on form ; @DDSBLK@(bk#)=Block name^flag (1=used on other forms) ; N P,B S P=0 F S P=$O(^DIST(.403,+DDSFORM,40,P)) Q:'P D . S B=$P(^DIST(.403,+DDSFORM,40,P,0),U,2) . I B]"",'$D(@DDSBLK@(B)) D .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM) . S B=0 . F S B=$O(^DIST(.403,+DDSFORM,40,P,40,B)) Q:'B D:'$D(@DDSBLK@(B)) .. S @DDSBLK@(B)=$P($G(^DIST(.404,B,0)),U)_U_$$COMMON(B,+DDSFORM) Q ; DELPR ;Delete blocks with prompting N DDSB W ! K DIK,DIR,DIRUT S DIR(0)="YA",DIR("B")="NO" S DIR("?")=" Enter 'Y' to delete, 'N' to keep." S DIK="^DIST(.404," ; S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB=""!DDSQUIT D . Q:$P(@DDSBLK@(DDSB),U,2) . S DIR("A")=$P(@DDSBLK@(DDSB),U)_$J("",30-$L($P(@DDSBLK@(DDSB),U)))_"Delete (Y/N)? " . D ^DIR S:$D(DIRUT) DDSQUIT=1 Q:'Y . S DA=DDSB D ^DIK K DA,DIR,DIK,DIRUT,DTOUT,DUOUT,DIROUT Q ; DELNPR ;Delete blocks without prompting N DDSB W ! K DIK S DIK="^DIST(.404," S DDSB="" F S DDSB=$O(@DDSBLK@(DDSB)) Q:DDSB="" D . Q:$P(@DDSBLK@(DDSB),U,2) . W !,"Deleting block "_$P(@DDSBLK@(DDSB),U)_" (IEN #"_DDSB_") ..." . S DA=DDSB D ^DIK K DIK,DA Q ; ASKDEL ;Ask if user wants to delete all the blocks on this form K DIR W ! S DIR(0)="YA",DIR("B")="YES" S DIR("A",1)="" S DIR("A",2)="Delete all deletable blocks used on form "_$P(DDSFORM,U,2) S DIR("A")="from the BLOCK file (Y/N)? " S DIR("?",1)=" Enter 'Y' to delete blocks used on form" S DIR("?",2)=" "_$P(DDSFORM,U,2)_" from the BLOCK file." S DIR("?",3)=" (Only blocks not used on other forms can be deleted.)" S DIR("?",4)="" S DIR("?")=" Enter 'N' to delete the form but not the blocks." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSDEL=Y Q:'DDSDEL ; ;Ask if user wants to delete without prompting W ! S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Delete blocks without prompting (Y/N)? " S DIR("?",1)=" Enter 'Y' to delete blocks from the BLOCK file" S DIR("?",2)=" without confirmation." S DIR("?",3)="" S DIR("?")=" Enter 'N' to confirm each delete." D ^DIR K DIR I $D(DIRUT) S DDSQUIT=1 Q S DDSDEL(1)=Y Q ; ASKCONT ;Final chance to abort K DIR S DIR(0)="YA",DIR("B")="NO" S DIR("A",1)="" S DIR("A")="Continue (Y/N)? " S DIR("?")=" Enter 'Y' to delete form. Enter 'N' to exit." D ^DIR K DIR S:$D(DIRUT)!'Y DDSQUIT=1 Q ; REPORT ;Print report N B W !!! I '$D(@DDSBLK) W "There are no blocks on this form." Q W " BLOCKS USED ON FORM """_$P(DDSFORM,U,2)_""" (IEN #"_+DDSFORM_")" W !!," Internal",?50,"Used on" W !," Entry Number Block Name",?50,"Other Forms? Deletable?" W !," ------------ ----------",?50,"------------ ----------" ; S B="" F S B=$O(@DDSBLK@(B)) Q:B="" D . W !," "_B,?17,$P(@DDSBLK@(B),U),?54 . W $S($P(@DDSBLK@(B),U,2):"YES",1:"NO") . W ?68,$S($P(@DDSBLK@(B),U,2):"NO",1:"YES") Q ; COMMON(B,F) ;Is block B found on forms other than F N C,F1 S C=0,F1="" F S F1=$O(^DIST(.403,"AB",B,F1)) Q:F1="" I F1'=F S C=1 Q I 'C S F1="" F S F1=$O(^DIST(.403,"AC",B,F1)) Q:F1="" I F1'=F S C=1 Q Q C DDSFO DDSFO ;SFISC/MKO-FORM ONLY FIELDS ;1:52 PM 19 Jun 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. DIR ;Setup input variables to DIR N I,J S DIR(0)=$P(DDSO(20),U)_$P(DDSO(20),U,2,3) S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) S:$P(DIR(0),U)'["O" $P(DIR(0),U)=$P(DIR(0),U)_"O" I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D . S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z" . S $P(I,":",2)=$P(I,":",2)_"Z" . S $P(DIR(0),U,2)=I S:$G(^DIST(.404,DDSBK,40,DDO,22))'?."^" $P(DIR(0),U,3)=^(22) I $D(^DIST(.404,DDSBK,40,DDO,21)) D . S (I,J)=0 . F S I=$O(^DIST(.404,DDSBK,40,DDO,21,I)) Q:I="" I $D(^(I,0))#2 S J=J+1,DIR("?",J)=^(0) . I J>0 S DIR("?")=DIR("?",J) K DIR("?",J) X:$G(^DIST(.404,DDSBK,40,DDO,24))'?."^" ^(24) Q DDSIT DDSIT ;SFISC/MKO-INPUT TRANSFORMS ;09:07 AM 24 Oct 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PFIELD ;Input transform for the PARENT FIELD field of the PAGE multiple ;of the Form file. N DDSMF S DDSMF=$$GETFLD^DDSLIB($P(X,","),$P(X,",",2),$P(X,",",3),DA(1)) G QUIT ; PLINK ;Input transform for POINTER LINK field of the BLOCK multiple of ;the PAGE MULTIPLE of the Form file. N DDP,DDSCD,DDSERR,DDS ; S DDP=$P($G(^DIST(.403,DA(2),0)),U,8) I 'DDP D G QUIT . N P . S P(1)="PRIMARY FILE",P(2)="FORM" . D BLD^DIALOG(3011,.P) ; S DDS=DA(2)_U_$P(^DIST(.403,DA(2),0),U) D:X?1"FO(".E FO^DDSPTR(DDP,X,DA(2),DA(1)) D:X'?1"FO(".E DD^DDSPTR(DDP,X,DA) G QUIT ; CEXPR ;Input transform for COMPUTED EXPRESSION field N DDP,DDSX,DDSNEXP S DDP=$P($G(^DIST(.404,DA(1),0)),U,2) D PARSE^DDSCOMP(DDP,X,DA(1),.DDSNEXP) G:$G(DIERR) QUIT ; S DDSX=X,X=DDSNEXP D ^DIM S:$D(X) X=DDSX Q ; QUIT ;Check error and quit I $G(DIERR) N DDSERR D MSG^DIALOG("AB",.DDSERR),EN^DDIOL(.DDSERR) K X Q DDSLIB DDSLIB ;SFISC/MKO-LIBRARY FUNCTIONS ;11:55 AM 14 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FIND(E,C,S) ;Find in expression E, starting from pos S, the char pos ;after the next occurrence of char C, ignoring those within quoted ;strings. N I,J,P S:'$D(S) S=1 F D Q:$D(P) . S I=$F(E,C,S),J=$F(E,"""",S) . I 'I S P=I Q . I J,J1 S DDSSN=DDSSN-1 I DDSCL>1 D . S DDSCL=DDSCL-1 D MDA E D . S DDSSTL=DDSSTL-1 . D MDA,DB^DDSR(DDSPG,DDSBK) Q ; MDN ;Move down a line Q:'DA S DDSSN=DDSSN+1 I DDSCL0,'$G(@DDSREFT@(DDSPG,DDSBK,"COMP MUL")) D ;If this is top level of a pointing file, stuff the pointer back to where we came from .. N DR,X,Y .. S Y=$P(DDSREP,U,9) Q:Y="" .. S DR=$O(^DD(DDSFN,0,"IX",Y,DDSFN,""))_"////"_+DDSREP Q:'DR .. D ^DIE . ; . D ADD(DDSDA,DDSPDA,DDSSN) . S DDSFN="F"_DDSFN . D DMULT1^DDSR(DDSPG,DDSBK,DDSFN,DDSDA,DDSLN,DDSSN) . S DDSCHKQ=2 E D . S DDSCHKQ=1 . D POSDA(DDSDA) ;They have entered something already on the muliple display. Jump to it. ; S Y=$P(Y,U) S:X="" Y="" Q ; END ; S DDACT="N" Q:'DA D POSSN(999999999999) Q ; PGDN ;Page down S DDACT="N" I 'DA D . I DDSNP]"" S DDSPG=DDSNP,DDACT="NP" E D POSSN($P(DDSREP,U,2)+$P(DDSREP,U,5)) Q ; PGUP ;Page up S DDACT="N" I $P(DDSREP,U,4)=1 D . S DDSPG=$$PP^DDS5(.Y) . S:Y=1 DDACT="NP" E D POSSN($P(DDSREP,U,2)-$P(DDSREP,U,5)) Q ; POSSN(DDSSN,DDSPAINT) ;Make line with given DDSSN current N DDSLSN,DDSPDA,DDSSTL S DDSPDA=$P(DDSREP,U) S DDSSTL=$P(DDSREP,U,2) ; S DDSLSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1)+1 S DDSSN=$$MIN(DDSLSN,DDSSN) S:DDSSN<1 DDSSN=1 ; S DDSDA=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),"0,"_$P(DDSDA,",",2,999)) S DA=+DDSDA,@("D"_DDSDL)=DA ; S:'DA DDO=$P(DDSREP,U,8) I DDSSN'Y:X,1:Y) DDSM1 DDSM1 ;SFISC/MKO-MULTILINE, LOAD AND DELETE ;26SEP2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; LOAD(DDSIEN) ;Load subentries MLOAD ;Entry point from MLOAD^DDSUTL ;@DDSIEN is an array of record numbers ; Q:$D(DDSIEN)[0 Q:$D(@DDSIEN)<9 ; N DDSI,DDSPDA,DDSRN,DDSSN S DDSPDA=$P(DDSREP,U) S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA," "),-1) ; ;Add records to internal ^TMP array ;Load data for each record S DDSI="" F S DDSI=$O(@DDSIEN@(DDSI)) Q:DDSI="" D . S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN . S DA=+DDSRN,$P(DDSDA,",")=DA,@("D"_DDSDL)=DA . I $D(@DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA))[0 D .. S DDSSN=DDSSN+1 .. S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)=DDSSN .. S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSDA .. S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIE . D ^DDS11(DDSBK) . S DDSCHG=1 ; ;Position the cursor on blank (Select) line ;Repaint all lines in the repeating block D POSSN^DDSM(999999999999) D DMULTN^DDSR(DDSPG,DDSBK,DDSPDA,$P(DDSREP,U,5),1) ; ;Update DIR0 DIR0 S DIR0=$P(@DDSREFS@(DDSPG,DDSBK,DDO,"D"),U,1,3) S:$P($G(DDSREP),U,3)>1 $P(DIR0,U)=$P(DIR0,U)+($P(DDSREP,U,3)-1*$$HITE^DDSR(DDSBK)) ;DJW/GFT Q ; DEL(DDSIEN) ;Delete subentries MDEL ;Entry point from MDEL^DDSUTL ;In: ; If DDSIEN contains a record number, delete that one (G MDELONE) ; If DDSIEN contains a closed root, @DDSIEN is an array ; of record numbers to delete ; DIE = global root ; DDSDA = current IENS ; Q:$D(DDSIEN)[0 G:+$P(DDSIEN,"E") MDELONE Q:$D(@DDSIEN)<9 ; N DDSI,DDSPDA,DDSRN,DDSSN S DDSPDA=$P(DDSREP,U) ; ;Loop through passed array and delete subentries S DDSI="" F S DDSI=$O(@DDSIEN@(DDSI)) Q:DDSI="" D . ;S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN . ;S DDSIENS=DDSDA,$P(DDSIENS,",")=+DDSRN . ;D K^DDS6(DDSIENS,DIE) . ;Q . ; . S DDSRN=@DDSIEN@(DDSI) Q:'DDSRN . S DA=+DDSRN,$P(DDSDA,",")=DA . S DDSSN=$G(@DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA)) Q:'DDSSN . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSDA) . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN) . K @DDSREFT@("F"_DDP,DDSDA) . K @DDSREFT@("F0",DDSDA) ; ;Close up gaps in ^TMP array S (DDSI,DDSSN)=0 F S DDSI=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSI)) Q:'DDSI D . S DDSSN=DDSSN+1 Q:DDSI=DDSSN . S DDSRN=@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSI) . S @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)=DDSRN . S @DDSREFT@(DDSPG,DDSBK,DDSPDA,"B",DDSRN)=DDSSN ; F S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN)) Q:'DDSSN D . K @DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN) ; ;Position cursor on "Select" line ;Repaint all lines in repeating block D POSSN^DDSM(999999999999,1) ; ;Update DIR0 DIR01 D DIR0 Q ; MDELONE ;Delete one subentry in the current repeating block ;In: DDSIEN = IENS of record to be deleted ; DDSREP = data for repeating blocks ; DDSDA = current IENS ; DIE = current global root ; N DDSPDA,DDSRN,DDSSN ; ;Get parent IENS S DDSPDA=$P(DDSREP,U) ; ;Kill all data pertaining to current (sub)record D K^DDS6(DDSIEN,DIE) ; ;Repaint lines and reposition cursor I DDSDA=DDSIEN D . D DMULTN^DDSR(DDSPG,DDSBK,DDSPDA,$P(DDSREP,U,5),$P(DDSREP,U,3)) . S DDSSN=$P(DDSREP,U,4) . I $D(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN))[0 D .. S DDSSN=$O(@DDSREFT@(DDSPG,DDSBK,DDSPDA,DDSSN),-1) . D POSSN^DDSM(DDSSN) ; E D POSSN^DDSM(999999999999,1) ; DIR02 D DIR0 Q DDSMSG DDSMSG ;SFISC/MKO-PRINT MESSAGES ;3:14 PM 9 Feb 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ERR ;Print "DIERR" messages in help box N DDSE,DDSL,DDSLMT,DDSN K DDH,DDQ S DDSLMT=$G(DDC,15),DDSE=0 ; W $C(7) S DDSN=0 F S DDSN=$O(^TMP("DIERR",$J,DDSN)) Q:'DDSN!DDSE D . S DDSL=0 . F S DDSL=$O(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)) Q:'DDSL!DDSE D .. D LD($G(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)),"!") .. I DDH'DDSHBX SETDDH S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0 ; F S DDSL=$O(@DDSG@(DDSL)) Q:'DDSL!DDSE D . S DDST=$G(@DDSG@(DDSL)) . I DDST="$$EOP" S DDH=$G(DDH)+1,DDH(DDH,"E")="" . E D LD(DDST,$G(@DDSG@(DDSL,"F"),"!")) . S DDSNXTF=$G(@DDSG@(DDSL+1,"F"),"!") . I DDH'DDSHBX SETDDH S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0 ; F S DDSL=$O(@DDSR@(DDSL)) Q:'DDSL!DDSE D . D LD($G(@DDSR@(DDSL,0)),$G(@DDSR@(DDSL,"F"),"!")) . S DDSNXTF=$G(@DDSR@(DDSL+1,"F"),"!") . I DDH'DDSHBX SETDDH ; I $D(DDSMSG)=1 D . D LD(DDSMSG,$S($G(DDSFMT)]"":DDSFMT,1:"!")) ; E S DDSL=0 F S DDSL=$O(DDSMSG(DDSL)) Q:'DDSL D . D LD($G(DDSMSG(DDSL)),$G(DDSMSG(DDSL,"F"),"!")) Q:'$G(DDH) ; I $G(DDH) D . S:$G(DDH(1,"T"))?1.C DDH(1,"T")="" . S:$G(DDSFLG)[1 DDH(1,"T")=$C(7)_$G(DDH(1,"T")) . D SC^DDSU S:'$D(DDSID) DDSKM=1 Q ; SETDDH ;Setup DDH and DDQ for identifiers and executable help ;that called EN^DDIOL S:$X>IOM $X=IOM S DDH=1 S DDH(1,"T")=$TR($J("",$X)," ",$C(0)) S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)-1_U_$X Q ; LD(S,F) ;Load string S with format F into DDH array N A,C,J,L S DDH=+$G(DDH) F J=1:1:$L(F,"!")-1 S DDH=DDH+1,DDH(DDH,"T")="" S:'DDH DDH=1 S:F["?" @("C="_$P(F,"?",2)) S L=$G(DDH(DDH,"T")) S S=L_$J("",$G(C)-$L(L))_S ; D WRAP(S,.A,IOM-1) S DDH=DDH-1 F A=1:1:A S DDH=$G(DDH)+1,DDH(DDH,"T")=A(A) Q ; WRAP(L,A,M) ;Wrap line at word boundaries ; L = Line of text ; M = Margin width ;Return: ; A = Number of lines ; A(n) = Array of text ; S:'$G(M) M=$S($G(IOM):IOM-5,1:75) N I,N S N=0 F I=$L(L," "):-1:1 D Q:L="" . I I=1 S N=N+1,A(N)=$E(L,1,M),L=$E(L,M+1,999) Q . I $L($P(L," ",1,I))'>M D .. S N=N+1,A(N)=$P(L," ",1,I),L=$P(L," ",I+1,999) S A=N Q DDSOPT DDSOPT ;SFISC/MLH,MKO-SCREENMAN OPTIONS ;18JAN2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. 0 S DIC="^DOPT(""DDS""," G OPT:$D(^DOPT("DDS",7)) S ^(0)="SCREENMAN OPTION^1.01" K ^("B") F X=1:1:7 S ^DOPT("DDS",X,0)=$P($T(@X),";;",2) S DIK=DIC D IXALL^DIK OPT ; S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0 ; EN ;Entry point for all screenman options D @DI W !! Q K %,DI,DIC,DIK,X,Y Q ; 1 ;;EDIT/CREATE A FORM CREATE G ^DDGF ; 2 ;;RUN A FORM G ^DDSRUN ; 3 ;;DELETE A FORM G ^DDSDFRM ; 4 ;;PURGE UNUSED BLOCKS G ^DDSDBLK ; 5 ;;PRINT A FORM G PRINT^DDS ; 6 ;;CUSTOMIZE COLORS I $G(^XTV(8989.5,0))'?1"PARAM".E W !,"PARAMETERS SYSTEM IS NOT INSTALLED HERE" Q D EDITPAR^XPAREDIT("DI SCREENMAN COLORS") Q ; 7 ;;CLONE A FORM D ^DDSCLONE DDSPRNT DDSPRNT ;SFISC/MKO-PRINT A FORM ;02:51 PM 18 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; N DDSFORM,DDSPBRK D SELFORM(.DDSFORM) Q:DDSFORM=-1 D PAGEBRK(.DDSPBRK) Q:$D(DDSPBRK)[0 ; ;Device S %ZIS=$S($D(^%ZTSK):"Q",1:"") W ! D ^%ZIS K %ZIS I $G(POP) K POP Q K POP ; ;Queue report I $D(IO("Q")),$D(^%ZTSK) D G END . S ZTRTN="PRINT^DDSPRNT" . S ZTDESC="Report of Form "_$P(DDSFORM,U,2) . N I F I="DDSFORM","DDSFORM(0)","DDSPBRK" S ZTSAVE(I)="" . D ^%ZTLOAD . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),! . E W !,"Report canceled!",! . K ZTSK . S IOP="HOME" D ^%ZIS ; U IO ; PRINT ;Entry point for queued reports N DDSBK,DDSCOL1,DDSCOL2,DDSCOL3,DDSCRT,DDSFILE N DDSHLIN,DDSHBK,DDSPAGE,DDSQUE N DX,DY,X,Y ; I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU D INIT D @("HDR"_(2-DDSCRT)) D FORM,END Q ; FORM ;Form data W ! ; ;Description D WP($NA(^DIST(.403,+DDSFORM,15))) Q:$D(DIRUT) ; ;Other properties D W("PRIMARY FILE: "_$P(DDSFORM(0),U,8),9) Q:$D(DIRUT) W ?49,"READ ACCESS: "_$P(DDSFORM(0),U,2) D W("DATE CREATED: "_$$EXTERNAL^DILFD(.403,4,"",$P(DDSFORM(0),U,5)),9) Q:$D(DIRUT) W ?48,"WRITE ACCESS: "_$P(DDSFORM(0),U,3) D W("DATE LAST USED: "_$$EXTERNAL^DILFD(.403,5,"",$P(DDSFORM(0),U,6)),7) Q:$D(DIRUT) W ?53,"CREATOR: "_$P(DDSFORM(0),U,4) D W() Q:$D(DIRUT) ; I $P(DDSFORM(0),U,7)]"" D W("TITLE: "_$P(DDSFORM(0),U,7),16) Q:$D(DIRUT) I $P($G(^DIST(.403,+DDSFORM,21)),U)]"" D W("RECORD SELECTION PAGE: "_$P(^(21),U)) Q:$D(DIRUT) ; I $X D W() Q:$D(DIRUT) S X=$G(^DIST(.403,+DDSFORM,11)) I X]"" D W("PRE ACTION:",11) Q:$D(DIRUT) D PCOL(X,23) S X=$G(^DIST(.403,+DDSFORM,12)) I X]"" D W("POST ACTION:",10) Q:$D(DIRUT) D PCOL(X,23) S X=$G(^DIST(.403,+DDSFORM,14)) I X]"" D W("POST SAVE:",12) Q:$D(DIRUT) D PCOL(X,23) S X=$G(^DIST(.403,+DDSFORM,20)) I X]"" D W("DATA VALIDATION:",6) Q:$D(DIRUT) D PCOL(X,23) K DDSFORM(0) ; ;Loop through all pages I $X D W() Q:$D(DIRUT) Q:'$O(^DIST(.403,+DDSFORM,40,0)) ; N DDSPG,DDSPGN S DDSPGN="",DDSPFRST=1 F S DDSPGN=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN)) Q:DDSPGN=""!$D(DIRUT) S DDSPG=0 F S DDSPG=$O(^DIST(.403,+DDSFORM,40,"B",DDSPGN,DDSPG)) Q:'DDSPG!$D(DIRUT) D PAGE^DDSPRNT1 K DDSPFRST Q:$D(DIRUT) ; D:$D(DDSHBK) HBLKS^DDSPRNT1 Q ; WR(DDSLAB,DDSVAL,DDSFLG) ;Write label and value I DDSVAL="",'$G(DDSFLG) Q ; D W() Q:$D(DIRUT) W ?DDSCOL2,DDSLAB ; I $X>DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1 D PCOL(DDSVAL,DDSCOL3) Q ; PCOL(DDSVAL,DDSCOL) ;Print DDSVAL N DDSWIDTH,DDSIND S DDSWIDTH=IOM-DDSCOL-1 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D Q:$D(DIRUT) . I DDSIND>1 D W() Q:$D(DIRUT) . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1) Q ; WP(DDSWP,DIWL,DDSLF) ;Print text in array @DDSWP ;DDSLF [ A : LF after (def) ; B : LF feed before ; Q:'$P($G(@DDSWP@(0)),U,3) N DIW,DIWF,DIWI,DIWR,DIWT,DIWTC,DIWX,DN N DDSI,DDSCNT,I,X,Z ; K ^UTILITY($J,"W") S:'$G(DIWL) DIWL=1 S DIWR=IOM-1 S:'$D(DDSLF) DDSLF="A" ; S DDSCNT=$P($G(@DDSWP@(0)),U,3) I DDSCNT D . F DDSI=1:1:DDSCNT I $D(@DDSWP@(DDSI,0))#2 S X=^(0) D ^DIWP . ; . I DDSLF'["B" D .. W ?DIWL-1,$G(^UTILITY($J,"W",DIWL,1,0)) .. S DDSCNT=1 . E S DDSCNT=0 . F S DDSCNT=$O(^UTILITY($J,"W",DIWL,DDSCNT)) Q:'DDSCNT!$D(DIRUT) D .. D W($G(^UTILITY($J,"W",DIWL,DDSCNT,0)),DIWL-1) ; K ^UTILITY($J,"W") D:DDSLF["A" W() Q ; W(DDSSTR,DDSCOL) ;Write DDSSTR I $Y+3'DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1 D PCOL(DDSVAL,DDSCOL3) Q ; PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL N DDSWIDTH,DDSIND S DDSWIDTH=IOM-DDSCOL-1 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D Q:$D(DIRUT) . I DDSIND>1 D W() Q:$D(DIRUT) . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1) Q ; W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL I $Y+3'DDSCOL3 N DDSCOL3 S DDSCOL3=$X+1 D PCOL(DDSVAL,DDSCOL3) Q ; PCOL(DDSVAL,DDSCOL) ;Print DDSVAL starting in column DDSCOL N DDSWIDTH,DDSIND S DDSWIDTH=IOM-DDSCOL-1 F DDSIND=1:DDSWIDTH:$L(DDSVAL) D Q:$D(DIRUT) . I DDSIND>1 D W() Q:$D(DIRUT) . W ?DDSCOL,$E(DDSVAL,DDSIND,DDSIND+DDSWIDTH-1) Q ; W(DDSSTR,DDSCOL) ;Write DDSSTR preceded by !?DDSCOL I $Y+3'1 S D=D_",DIC(0)=""MF""",S=" D MIX^DIC1" .. E S D=D_",DIC(0)=""F""",S=" D IX^DIC" S:D="" D=",DIC(0)=""MF""",S=" D ^DIC" S D=D_" S:$G(DDS1E) DIC(0)=DIC(0)_""E"_$E("L",L)_"""" Q DDSR DDSR ;SFISC/MKO-PAINT ;20FEB2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. R ;All pages ;Called after wp, mults, & deletions F DDSSC=1:1:DDSSC D RP(DDSSC(DDSSC),DDSSC=1) Q ; RP(X,DDS3LIN) ;Paint page ; X = DDSSC(DDSSC) node ; DDS3LIN = paint bottom line ; S DDS3P=$P(X,U),DDS3UL=$P(X,U,2),DDS3LR=$P(X,U,3) I DDS3UL="" W $P(DDGLCLR,DDGLDEL,2) E D ^DDSBOX(DDS3UL,DDS3LR) ; ;Write caps in "X" nodes D CAP^DDSR1 ; ;Paint data & exec caps ;Hdr blk S DDS3B=$P($G(^DIST(.403,+DDS,40,DDS3P,0)),U,2) D:DDS3B]"" DB(DDS3P,DDS3B) ; ;Other blks S DDS3BO="" F S DDS3BO=$O(^DIST(.403,+DDS,40,DDS3P,40,"AC",DDS3BO)) Q:'DDS3BO S DDS3B=$O(^(DDS3BO,"")) Q:'DDS3B D DB(DDS3P,DDS3B) K DDS3B,DDS3BO ; I DDS3LIN D . S DDSH=1,DX=0,DY=DDSHBX X IOXY W $TR($J("",IOM-1)," ","_") ;WRITE ____ LINE SO WE ARE AT LAST (80TH) COLUMN POSITION .I DDS3UL]"" S DY=DY+1 X IOXY W $P(DDGLCLR,DDGLDEL,3) N Y F Y=DY:1:IOSL K DDSMOUSE(Y) K DDS3P,DDS3UL,DDS3LR Q ; DB(DDS3P,DDS3B) ;Paint data K @DDSREFT@("XCAP",DDS3P,DDS3B) S DDS3=@DDSREFS@(DDS3P,DDS3B) S DDS3FN="F"_$P(DDS3,U,3),DDS3REP=$P(DDS3,U,7),DDS3PTB=$P(DDS3,U,8) K DDS3 ; I $G(DDS3REP)'>1 D . N DIE . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B)) . S:DDS3DA]"" DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3DA,"GL")) . S DDS3DDO=0 . F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) D:DDS3C]"" DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3PTB) . K DDS3C,DDS3DA,DDS3DDO E D DMULT(DDS3P,DDS3B,DDS3FN) ; K DDS3FN,DDS3PTB,DDS3REP Q ; DMULT(DDS3P,DDS3B,DDS3FN) ;Paint data, all lines N X,DIE S DDS3PDA=$P($G(@DDSREFT@(DDS3P,DDS3B)),U) GFT I '$D(^(DDS3B,"COMP MUL")),'DDS3PDA D . S X="",DDS3STL=1 . S DDS3NREP=$P(@DDSREFS@(DDS3P,DDS3B),U,7),DDS3SEL=$P(^(DDS3B),U,10) E D . S X=@DDSREFT@(DDS3P,DDS3B,DDS3PDA) . S DDS3STL=$P(X,U,3),DDS3NREP=$P(X,U,6),DDS3SEL=$P(X,U,9) ;3RD PIECE SAYS WHICH LINE IS NOW TOP LINE S DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"GL")) ; F DDS3LN=1:1:DDS3NREP D ;PAINT LINES ONE BY ONE . S DDS3SN=DDS3LN+DDS3STL-1 . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN)) . S:DDS3LN=1 DDS3MORE=$S(DDS3STL>1:"+",1:" ") ;IF 1ST LINE ISN'T REALLY FIRST LAST . I DDS3LN=DDS3REP S DDS3MORE=" " I $D(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN+1))#2 S DDS3MORE="+",DDS3MORE("LAST")=1 ;IF LAST LINE ISN'T REALLY LAST . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,.DDS3MORE,DDS3SEL) . K DDS3MORE ; K DDS3DA,DDS3LN,DDS3NREP,DDS3PDA,DDS3SEL,DDS3SN,DDS3STL Q ; DMULTN(DDS3P,DDS3B,DDS3PDA,DDS3REP,DDS3LN) ;Paint lines from DDS3LN S DDS3FN="F"_$P(@DDSREFS@(DDS3P,DDS3B),U,3) S DDS3STL=$P(@DDSREFT@(DDS3P,DDS3B,DDS3PDA),U,3),DDS3SEL=$P(^(DDS3PDA),U,9) F DDS3LN=DDS3LN:1:DDS3REP D . S DDS3SN=DDS3LN+DDS3STL-1 . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN)) . S:DDS3LN=1 DDS3MORE=$S(DDS3STL>1:"+",1:" ") . S:DDS3LN=DDS3REP DDS3MORE=$S($D(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN+1))#2:"+",1:" ") . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,.DDS3MORE,DDS3SEL) . K DDS3MORE K DDS3DA,DDS3FN,DDS3LN,DDS3SEL,DDS3SN,DDS3STL Q ; DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3MORE,DDS3SEL) ;Paint 1 line, LINE DDS3LN N DDSHITE S DDSHITE=$$HITE(DDS3B),DDS3DDO=0 F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) I DDS3C]"" D ;go thru fields in the multiple . S $P(DDS3C,U)=$P(DDS3C,U)+(DDS3LN-1*DDSHITE) ;DJW/GFT . S:$P(DDS3C,U,5)]"" $P(DDS3C,U,5)=$P(DDS3C,U,5)+(DDS3LN-1*DDSHITE) ;DJW/GFT . I $D(DDS3MORE),DDS3SEL=DDS3DDO,$P(DDS3C,U)?1.N D .. S DY=+DDS3C,DX=$P(DDS3C,U,2)-1 Q:DX<0 PLUSSIGN .. X IOXY D ...I DDS3MORE="+" S DDSMOUSE(DY,DX,DX)=$S($D(DDS3MORE("LAST")):"NP",1:"PP") I $G(DDSMOUSY) S DDS3MORE=$$HIGH^DDSU(DDS3MORE) ...W DDS3MORE . D DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,1,DDS3LN,DDS3SN) ;7TH parameter says ALWAYS PAINT AREA even if value is null K DDS3C,DDS3DDO Q ; HITE(BLK) N D,Z,H,L,F S D=1,H=1,L=999 F F=0:0 S F=$O(^DIST(.404,BLK,40,F)) Q:'F S Z=$G(^(F,2)) D .I 'Z S Z=$P(Z,U,3) ;MIGHT BE JUST A CAPTION .I Z S:ZH H=Z S D=H-L+1 ;GFT Q D ; ; DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3FLG,DDS3LN,DDS3SN) ; ;Paint field N DDS3FLD,DDS3LEN,DDSX D:$P(DDS3C,U,5)]"" XCAP ; S DY=+DDS3C,DX=$P(DDS3C,U,2) S DDS3LEN=$P(DDS3C,U,3),DDS3FLD=$P(DDS3C,U,4) ; ;Computed flds I DDS3DA]"",$P(DDS3C,U,9) S DDSX=$$VAL^DDSCOMP(DDS3DDO,DDS3B,DDS3DA) ; ;Form only flds Q:DDS3FLD="" I DDS3FLD'=+DDS3FLD N DDS3FN S DDS3FN="F0" ; ;External form S:DDS3FLD DDSX=$S(DDS3DA="":"",$D(@DDSREFT@(DDS3FN,DDS3DA,DDS3FLD,"X"))#2:^("X"),1:$G(^("D"))) PAINT D ;I $G(DDSX)]""!$G(DDS3FLG) D PAINT NULL FIELD TO SHOW COLOR . I DDS3LEN=1 I $$WPLUS^DDSWP(DDS3FN,DDS3DA,DDS3FLD) S DDSX="+" ;GO SEE IF WE NEED PLUS SIGN IN WORD-PROCESSING BOX . S:$D(DDSX)[0 DDSX="" . X IOXY . I '$P(DDS3C,U,10) S DDSX=$E(DDSX,1,DDS3LEN)_$J("",DDS3LEN-$L(DDSX)) . E S DDSX=$J("",DDS3LEN-$L(DDSX))_$E(DDSX,1,DDS3LEN) . W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10) ;I DDSX["^DIZ(600001,""C""," W "<" H 9 Q ; ; XCAP ;Paint exec caps N Y,DDSLN,DDSSN I 'DDS3DA N DA,D0 S (DA,D0)="" ; I DDS3DA N DDSDL S DDSDL=$L(DDS3DA,",")-2 I N DA,@$$D0^DDS(DDSDL) I D BLDDA^DDS(DDS3DA) ; S DDS3TP=$P($G(@DDSREFS@(DDS3P,DDS3B)),U,5) S DDS3L0=$G(^DIST(.404,DDS3B,40,DDS3DDO,0)) G:DDS3L0?."^" XCAPQ S DDS3L01=$G(^DIST(.404,DDS3B,40,DDS3DDO,.1)) G:DDS3L01?."^" XCAPQ ; S:$D(DDS3LN) DDSLN=DDS3LN S:$D(DDS3SN) DDSSN=DDS3SN ; X DDS3L01 G:$G(Y)="" XCAPQ S DDS3CAP=Y ; I DDS3TP="e","^2^3^"[(U_$P(DDS3L0,U,3)_U)!'$P(DDS3L0,U,3) D . S Y=$$UP^DILIBF(Y) ;** . S @DDSREFT@("XCAP",DDS3P,Y,DDS3B,DDS3DDO)="" ; S DY=$P(DDS3C,U,5),DX=$P(DDS3C,U,6) S DDS3CAP=DDS3CAP_$P(DDS3C,U,7) S:$P(DDS3C,U,8) DDS3CAP=$P(DDGLVID,DDGLDEL,4)_DDS3CAP_$P(DDGLVID,DDGLDEL,10) X IOXY W DDS3CAP XCAPQ K DDS3CAP,DDS3L0,DDS3L01,DDS3TP Q DDSR1 DDSR1 ;SFISC/MKO-PAINT ;11AUG2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CAP ;Write captions in "X" nodes N DDGLVAN S DDGLVAN=1 ;** DEFEAT OLD LOGIC ABOUT LO-INTENSITY W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,2) ; EGP N DDCAP,A,C,C1,C2,P,PC,V,X ;**CCO/NI I $G(DUZ("LANG"))>1 S DY=$NA(@DDSREFS@("CAP")) F S DY=$Q(@DY) Q:$QS(DY,4)'="CAP" D ;IF WE HAVE A FIELD WITH A FOREIGN LABEL ENTERED, USE IT .I $QS(DY,7)=DDS3P S C1=+$QS(DY,8),C2=$P($G(@DDSREFS@(DDS3P,C1)),U,3) I C2 S X=$G(^(C1,+$QS(DY,9),"D")),A=$P(X,U,4) I A S P=$P($G(^DD(C2,A,0)),U),A=$$LABEL^DIALOGZ(C2,A) I A]"",A'=P S DDCAP($$UP^DILIBF($QS(DY,5)))=A S DY="" F S DY=$O(@DDSREFS@("X",DDS3P,DY)) Q:DY="" S DX=$O(^(DY,"")),DDS3CAP=^(DX) D X IOXY W DDS3CAP .I $G(DUZ("LANG"))>1 D ..;I $D(@DDSREFS@("X",DDS3P,DY,DX,"LANG",DUZ("LANG"))) S DDS3CAP=^(DUZ("LANG")) Q ..S C="",C2=$$UP^DILIBF(DDS3CAP) F S C=$O(DDCAP(C)) Q:C="" D ...S C1=$L(C),P=$F(C2,C) I P S $E(DDS3CAP,P-C1,P-1)=$E(DDCAP(C)_$J("",80),1,C1) ;COULD FIND "NAME" IN "FATHER'S NAME" AND REPLACE IT WITH "NOBRE"! ..Q ..S C=DDS3CAP,C1=C?.E1":" I C1 S C=$E(C,1,$L(C)-1) . Q:'$D(@DDSREFS@("X",DDS3P,DY,DX,"A")) S A=^("A") . S X=DDS3CAP,DDS3CAP="",P=1 . F PC=1:1:$L(A,U) S C=$P(A,U,PC) D:C]"" .. S C1=$P(C,";"),C2=$P(C,";",2) .. S V=$S($P(C,";",3)="U":$P(DDGLVID,DDGLDEL,4),1:"") .. S DDS3CAP=DDS3CAP_$E(X,P,C1-1)_V_$E(X,C1,C2)_$P(DDGLVID,DDGLDEL,10)_$S($D(DDGLVAN):$P(DDGLVID,DDGLDEL,2),1:"") .. S P=C2+1 . S DDS3CAP=DDS3CAP_$E(X,P,999) ; W:$D(DDGLVAN) $P(DDGLVID,DDGLDEL,10) K DDS3CAP Q DDSRP DDSRP ;GFT/GFT - PRINT FORM 'DDS', PAGE 'DDS3P';2013-01-25 12:19 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN(DDS,DDS3P,DDSJ) ; Main Entry Point I '$G(DDSJ) S DDSJ=$J N X,Y,IOP,POP,BLK,DDSREFS,DDSREFT S DDSREFT=$NA(^TMP("DDS",DDSJ,DDS)) S DDSREFS=$NA(^DIST(.403,+DDS,"AY")) K ^UTILITY($J,"DDSRP") ;Set terminal characterstics for scroll mode W *27,"[?1000l" ; Mouse Off W $P(DDGLCLR,DDGLDEL,2) ; Clear ALL screen S DX=0,DY=0 X IOXY ; Take cursor to 0,0 W $P(DDGLVID,DDGLDEL)_"PRINT SCREEN"_$P(DDGLVID,DDGLDEL,10) ; Write to screen in bold D KILL^DDGLIB0() ; Turn off screen handling D ^%ZIS ; Select Device I POP D HLP^DDSUTL("SORRY, PRINTING FAILED") G ENQ ; Quit if can't open I $E(IOST,1,2)="C-" S IOF="!" ; On a terminal, make Form Feed a Line Feed U IO ; Use printer device D CAP,BLKS,PRINT ; This is where the printing really happens. D ; Block to new DDS so that the reader can't find it for writing to screen . N DDS,DIR I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR ; Press Enter to continue D ^%ZISC ; Close device ENQ ; Goto label in case we fail to open the device. D INIT^DDGLIB0() ; Turn screen handling back on again. I $G(DDS)>0 W *27,"[?1000h" ; Mouse On D FINISH^DDGLIBP() ; Turn on terminators, off echo, and set RM to zero. Q BLKS ;FROM ^DDSR S BLK=$P($G(^DIST(.403,+DDS,40,DDS3P,0)),U,2) ;Hdr blk D:BLK]"" DB(DDS3P,BLK) ; ;Other blks N DDS3BO S DDS3BO="" F S DDS3BO=$O(^DIST(.403,+DDS,40,DDS3P,40,"AC",DDS3BO)) Q:'DDS3BO S BLK=$O(^(DDS3BO,"")) Q:'BLK D DB(DDS3P,BLK) Q ; PRINT ; N DDSI S DDSI=1 F Y=0:1:$O(^UTILITY($J,"DDSRP",""),-1) W !,$G(^UTILITY($J,"DDSRP",Y)) S DDSI=DDSI+1 I $G(IOSL),DDSI'1 D . N DIE . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B)) . S:DDS3DA]"" DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3DA,"GL")) . S DDS3DDO=0 . F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) D:DDS3C]"" DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3PTB) . K DDS3C,DDS3DA,DDS3DDO E D DMULT(DDS3P,DDS3B,DDS3FN) ; K DDS3FN,DDS3PTB,DDS3REP Q ; DMULT(DDS3P,DDS3B,DDS3FN) ;Paint data, all lines N X,DIE S DDS3PDA=$P($G(@DDSREFT@(DDS3P,DDS3B)),U) GFT I '$D(^(DDS3B,"COMP MUL")),'DDS3PDA D . S X="",DDS3STL=1 . S DDS3NREP=$P(@DDSREFS@(DDS3P,DDS3B),U,7),DDS3SEL=$P(^(DDS3B),U,10) E D . S X=@DDSREFT@(DDS3P,DDS3B,DDS3PDA) . S DDS3STL=$P(X,U,3),DDS3NREP=$P(X,U,6),DDS3SEL=$P(X,U,9) ;3RD PIECE SAYS WHICH LINE IS NOW TOP LINE S DIE=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"GL")) ; F DDS3LN=1:1:$O(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,"A"),-1) D ;PAINT LINES ONE BY ONE . S DDS3SN=DDS3LN ;START WITH LINE 1 ALWAYS . S DDS3DA=$G(@DDSREFT@(DDS3P,DDS3B,DDS3PDA,DDS3SN)) . D DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL) F DDS3LN=DDS3LN+1:1:DDS3REP S DY=DY+1,DX=2 D PUT(" ") ;BLANK LINES AT END OF MULTIPLES K DDS3DA,DDS3LN,DDS3NREP,DDS3PDA,DDS3SEL,DDS3SN,DDS3STL Q ; DMULT1(DDS3P,DDS3B,DDS3FN,DDS3DA,DDS3LN,DDS3SN,DDS3SEL) ;Paint 1 line, LINE DDS3LN N DDSHITE S DDSHITE=$$HITE^DDSR(DDS3B),DDS3DDO=0 F S DDS3DDO=$O(@DDSREFS@(DDS3P,DDS3B,DDS3DDO)) Q:DDS3DDO'=+DDS3DDO S DDS3C=$G(^(DDS3DDO,"D")) I DDS3C]"" D . S $P(DDS3C,U)=$P(DDS3C,U)+(DDS3LN-1*DDSHITE) ;DJW/GFT . S:$P(DDS3C,U,5)]"" $P(DDS3C,U,5)=$P(DDS3C,U,5)+(DDS3LN-1*DDSHITE) ;DJW/GFT . D DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,1,DDS3LN,DDS3SN) K DDS3C,DDS3DDO Q ; DF(DDS3P,DDS3B,DDS3DDO,DDS3DA,DDS3C,DDS3FN,DDS3FLG,DDS3LN,DDS3SN) ;Paint field N DDS3FLD,DDS3LEN,DDSX D:$P(DDS3C,U,5)]"" XCAP ; S DY=+DDS3C,DX=$P(DDS3C,U,2) S DDS3LEN=$P(DDS3C,U,3),DDS3FLD=$P(DDS3C,U,4) ; ;Computed flds I DDS3DA]"",$P(DDS3C,U,9) S DDSX=$$VAL^DDSCOMP(DDS3DDO,DDS3B,DDS3DA) ; ;Form only flds Q:DDS3FLD="" I DDS3FLD'=+DDS3FLD N DDS3FN S DDS3FN="F0" ; ;External form S:DDS3FLD DDSX=$S(DDS3DA="":"",$D(@DDSREFT@(DDS3FN,DDS3DA,DDS3FLD,"X"))#2:^("X"),1:$G(^("D"))) I $G(DDSX)]""!$G(DDS3FLG) D . S:$D(DDSX)[0 DDSX="" . I '$P(DDS3C,U,10) S DDSX=$E(DDSX,1,DDS3LEN)_$J("",DDS3LEN-$L(DDSX)) . E S DDSX=$J("",DDS3LEN-$L(DDSX))_$E(DDSX,1,DDS3LEN) . D PUT(DDSX) Q ; XCAP ;Paint exec caps N Y,DDSLN,DDSSN I 'DDS3DA N DA,D0 S (DA,D0)="" ; I DDS3DA N DDSDL S DDSDL=$L(DDS3DA,",")-2 I N DA,@$$D0^DDS(DDSDL) I D BLDDA^DDS(DDS3DA) ; S DDS3TP=$P($G(@DDSREFS@(DDS3P,DDS3B)),U,5) S DDS3L0=$G(^DIST(.404,DDS3B,40,DDS3DDO,0)) G:DDS3L0?."^" XCAPQ S DDS3L01=$G(^DIST(.404,DDS3B,40,DDS3DDO,.1)) G:DDS3L01?."^" XCAPQ ; S:$D(DDS3LN) DDSLN=DDS3LN S:$D(DDS3SN) DDSSN=DDS3SN ; X DDS3L01 G:$G(Y)="" XCAPQ S DDS3CAP=Y ; I DDS3TP="e","^2^3^"[(U_$P(DDS3L0,U,3)_U)!'$P(DDS3L0,U,3) D . S Y=$$UP^DILIBF(Y) ;** . S @DDSREFT@("XCAP",DDS3P,Y,DDS3B,DDS3DDO)="" ; S DY=$P(DDS3C,U,5),DX=$P(DDS3C,U,6) S DDS3CAP=DDS3CAP_$P(DDS3C,U,7) D PUT(DDS3CAP) XCAPQ K DDS3CAP,DDS3L0,DDS3L01,DDS3TP Q ; PUT(X) S $E(^UTILITY($J,"DDSRP",DY),DX+1,DX+$L(X))=X Q ; DDSRSEL DDSRSEL ;SFISC/MKO-RECORD SELECTION ;7JAN2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PG ;Called from: ; DDS01 when user presses SELECT ; FIRSTPG^DDS0 if no DA was passed in. ; ;Returns (if there is a record selection page and we're not in ;a multiple) ; DDSPG = Record selection page # ; DDACT = "NP" ; DDSSEL = 1 (undefined if no record selection page) ; N P,P1 K DDSSEL I $D(DDSSC),$P($G(DDSSC(DDSSC)),U,4) Q ;GFT ; S P="",P1=$P($G(^DIST(.403,+DDS,21)),U) I P1]"" D . S P=$O(^DIST(.403,+DDS,40,"B",P1,"")) . I P]"",$D(^DIST(.403,+DDS,40,P,0))[0 S P="" ; I P]"" D . I $G(DDO),$G(DDSDN)=1 D .. D ERR3^DDS3 . E S DDSPG=P,DDACT="NP",DDSSEL=1 Q ; GDA ;Called from DDS ;After a record selection page is closed get the DA from ;the first field on the page. N DDSANS,DDSREC,Y,PG S DDSANS="" GFT S PG=$P($G(^DIST(.403,+DDS,21)),U) G KILL:'PG N P S P=$O(^(40,"B",PG,0)) D:P I '$D(Y) G KILL .F Y=0:0 S Y=$O(^DIST(.403,+DDS,40,P,40,Y)) Q:'Y I $G(^(Y,"COMP MUL"))]"" K Y Q E S DDSREC=$$GET^DDSVALF(1,1,PG) ;ON THE OLD KIND OF LOOKUP PAGE, THERE IS 1 FIELD, 1 BLOCK ; K DA,DDSDAORG S DDSDA=DDSDASV,DDSDL=DDSDLSV D BLDDA^DDS(DDSDA) M DDSDAORG=DDSORGSV ; I 'DDSREC,DA S DDSREC=DA E I DDSREC,DDSREC'=DA D . I DA D Q:DDSREC=DA .. S DDSANS=$$ASKSAVE .. I DDSANS="R" S DDSREC=DA .. E I DDSANS="S" D ... D ^DDS4 ... S:Y'=1 DDSREC=DA . ; . S DA=DDSREC . D REC^DDS0(DDP,.DA) . ; . I $G(DIERR) D Q .. D ERR^DDSMSG H 2 .. S DA=+$G(DDSDASV),DDACT="N" .. D REC^DDS0(DDP,.DA) . ; . S DDACT="N" . I DDSSC=1 D FRSTPG^DDS0(DDS,.DA,$G(DDSPAGE)) . D CLRDAT,UNLOCK ; KILL K DDSSEL,DDSDASV,DDSDASV,DDSDLSV,DDSORGSV Q ; ASKSAVE() ; ;Ask user whether to save the previous record N X,Y D:DDM CLRMSG^DDS S DDM=1 ; K DIR S DIR(0)="SM^S:SAVE;D:DISCARD;R:RETURN" S DIR("A",1)=" NOTE: You must Save or Discard all edits to the" S DIR("A",2)=" previous record before editing the next record." S DIR("A",3)=" " S DIR("A")="Save, Discard, or Return (S/D/R)" S DIR("B")="SAVE" ; S DIR("?",1)="Enter 'S' to save or 'D' to discard." S DIR("?")="Enter 'R' or '^' to return to previous record." ; S DIR0=IOSL-1_U_($L(DIR("A"))+1)_"^7^"_(IOSL-4)_"^0" D ^DIR I $D(DIRUT) S Y="R" E I X="SAVE" S Y="S" K DIR,DIROUT,DIRUT,DTOUT,DUOUT Q Y ; CLRDAT ;Clear all data values from @DDSREFT N F,P S P=0 F S P=$O(@DDSREFT@(P)) Q:'P K @DDSREFT@(P) S F="F" F S F=$O(@DDSREFT@(F)) Q:$E(F)'="F" K @DDSREFT@(F) Q ; UNLOCK ;Unlock all records locked Q:'$D(^TMP("DDS",$J,"LOCK")) N I S I="" F S I=$O(^TMP("DDS",$J,"LOCK",I)) Q:I="" D . I I'=(DIE_DA_")") L -@I K ^TMP("DDS",$J,"LOCK",I) Q DDSRUN DDSRUN ;SFISC/MKO-RUN A FORM ;8DEC2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;Select file (DDSFILE) EGP S DDS1=8108.3 D W^DICRW K DDS1 G:Y<0 RUNQ ;**CCO/NI 'RUN FORM:' G:'$D(@(DIC_"0)")) RUNQ K DDSFILE S DDSFILE=+Y ; ;Select form (DDSRUNDR) K DIC S DIC=.403,DIC(0)="QEA",D="F"_+Y S DIC("S")="I $P(^(0),U,8)=+DDSFILE" I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,2)) I DUZ(0)[$E($P(^(0),U,2),DDSI) Q" W ! D IX^DIC K DIC,D G:Y<0 RUNQ S DDSRUNDR=+Y ; I '$$COMPILED^DDS0(DDSRUNDR) D EN^DDSZ(DDSRUNDR) G:$G(DIERR) RUNQ ; ;Select page (DDSPAGE) PAGE K DIR S Y=$O(^DIST(.403,DDSRUNDR,40,0)) I '$O(^(Y)) S DDSPAGE=1 G REC ;DON'T ASK IF ONLY ONE! S Y=$G(^DIST(.403,DDSRUNDR,21)) I Y S DDSPAGE=+Y G REC ;IF THERE'S A RECORD SELECTION PAGE, USE IT S DIR(0)="NOA^1:999.9:1" S DIR("A")="Enter number of first page: ",DIR("B")=1 W ! D ^DIR K DIR G:$D(DIRUT) RUNQ K DDSPAGE S:Y'=1 DDSPAGE=Y ; REC ;Select record (DA) K DA I '$P(^DIST(.403,DDSRUNDR,0),U,10),$S($G(DDSPAGE):$G(^(21))-DDSPAGE,1:1) D G:DA<0 RUNQ ;IF IT'S A RECORD SELECTION PAGE, THAT WILL FIND 'DA' . S DIC=DDSFILE,DIC(0)="QEALM" . W ! D ^DIC K DIC . S DA=+Y K D,DIC,X,Y ; ;Invoke form K DR S DR=DDSRUNDR D ^DDS G:$D(DA) REC ; RUNQ ;Clean up and quit I $D(DIERR) W !,$C(7) D MSG^DIALOG("BW") K D,DIC,X,Y K DDSFILE,DDSPAGE,DDSRUNDR,DA,DR K DIRUT,DTOUT,DUOUT Q DDSSTK DDSSTK ;SFISC/MKO-STACK CONTEXT, GO TO A NEW PAGE ;19JUNE2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DDO N DDSBK,DDSDN,DDSFLD,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP ; I DDSSTACK?1"`".E D . S DDSSTACK=+$E(DDSSTACK,2,999) E I DDSSTACK=+$P(DDSSTACK,"E") D . S DDSSTACK=+$O(^DIST(.403,+DDS,40,"B",DDSSTACK,"")) E D UP . S DDSSTACK=$O(^DIST(.403,+DDS,40,"C",$$UP^DILIBF(DDSSTACK),"")) ;** ; I 'DDSSTACK!($D(^DIST(.403,+DDS,40,+$G(DDSSTACK),0))[0) D Q . K DDSSTACK,DDSBR ; N DDSDAORG,DDSDLORG,DDSFLORG,DDSPG N:'$P(^DIST(.403,+DDS,40,+$G(DDSSTACK),0),U,6) DDSSC ;N DDSSC (Page array) if not going to a POPUP PAGE ; S DDSPG=DDSSTACK K DDSSTACK,DDSBR ; S DDSDLORG=DDSDL,DDSDAORG=DA F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI) K DDSI ; DDSH S DDSSTK=1,DDSH=1 ;DDSH tells SM+6^DIR0 to refresh the COMMAND LINE D PROC^DDS Q DDSU DDSU ;SFISC/MLH-PROCESS HELP ; 14NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. LIST ; I '$D(DDS) D Q FM .;FileMan help - Non screen .N A0,A1,A2,A3,A4,DDSDIW,DDSDIY,Y .S A0="" .F S A0=$O(DDH(A0)) Q:'A0 S DDSDIW=$X,DDSDIY=$Y D W I $G(DDD)>2,DDSDIW-$X!(DDSDIY-$Y) D STP Q:$D(DTOUT) .I $G(DIPGM)="DICQ1",$G(DP),$G(DIC("?N",DP)) D ..N DIZ S DIZ=0 D T Q Q .I '$D(DTOUT) D SV S DDH=0 Q .K DDH D:'DTOUT Q ..K DTOUT N % S %=$G(DIPGM) I %'="DICQ1",%'="DIEQ" Q ..S DUOUT=1 ; ;SCREENMAN HELP N DIR0A K DICQRETA,DICQRETV D SC I $D(DIR0A) S DICQRETV=DIR0A ;RETURN VALUE from MOUSE Q ; SC ;Screen Help, also from DDS2,DDSCOM,DDSMSG N A0,A1,A2,A3,A4,A5,A6,DDSB1,X,Y K DTOUT,DUOUT ; W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X DDGLZOSF("RM") I $D(DDQ)#2,DDQ<(IOSL-1),DDQ>DDSHBX!$P(DDQ,U,2)!$D(DDIOL) S DY=$P(DDQ,U),DX=$P(DDQ,U,2) E D CLRMSG^DDS S DY=DDSHBX X DDXY ; S:$G(DDD,5)=5 DDD=1 S:$D(DDO) DDSB1=DDO S DDM=1,DDO=.5 S (A0,DIY,X)="",A1=0,A5=$S(DDD=2:$O(DS(0)),1:$O(DDH(A0))) K A2,DDSQ ;Now loop thru the DDHs F D Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT)!$D(DIR0A) SC1 .S A6=A0,A0=$O(DDH(A0)) S:A6="" A6=A0-1 .I 'A0,DDD Q:DDD=1 Q:DDDDSHBX) S DY=DY+1 X DDXY .I A4="E" D SC2 Q MORE .I $Y'<(IOSL-2)!'A0 D SC2 Q:DDO'<1!(X=U)!'A0!DIY!$D(DTOUT)!$D(DUOUT)!$D(DIR0A) S DY=DDSHBX+1,DX=0 X DDXY .Q:A4="" .D WR ;Write something! .I $Y'<(IOSL-1),'$D(DTOUT),'$D(DUOUT) D Q ;SEE IF WE ARE 2 LINES FROM BOTTOM ..W ! S A6=A0 D SC2 ;Now that we have written choice #A0, allow them to choose it ..W $P(DDGLVID,DDGLDEL,8) S X=0 X DDGLZOSF("RM") D REFRESH^DDSUTL ..W $P(DDGLVID,DDGLDEL,9) S X=$G(IOM,80)-1 X DDGLZOSF("RM") ..S DX=0,DY=DDSHBX X DDXY .S DY=$Y,DX=0 I $D(DDSB1) S:DDO<1 DDO=DDSB1 E K DDO ; S %=0 S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_DX S:DDQ>DDSHBX DDM=1 I $D(A2) K DDD,DDH,DDQ S %=A2 S:%'=1 DDSQ=1 D CLRMSG^DDS G QQ I $D(DDC),DDC'<0 D SV E K DDD,DDH S DDSQ=1 ;DDSQ means we're done with the Lister ; QQ S A0=$X S X=0 X DDGLZOSF("RM") W $P(DDGLVID,DDGLDEL,8) S $X=A0 Q ; ; SC2 S DX=0,DY=IOSL-1 X DDXY I DDD=1 W $$EZBLD^DIALOG(8053) D READ Q ;DDD=1 means 'HIT RETURN to CONTINUE' W $$EZBLD^DIALOG(8081,A5_"-"_A6)_$P(DDGLCLR,DDGLDEL) ;CHOOSE 1-3 ... D READ I $G(DUOUT) K DDC G Q2 I X]"",XA6) W $C(7) G SC2 E I X S:DDD["J" DDO=$O(DDH(X,"")) K DDC D CLRMSG^DDS S DDM=1 Q2 S DIY=X,DY=DDSHBX Q ; ; SV ;Kill DDH array, but save the "ID" nodes and DDH itself K A1,A2 S:$D(DDH("ID")) A1=DDH("ID") S:$D(DDH("ID",1)) A2=DDH("ID",1) K DDH S DDH=0 S:$D(A1) DDH("ID")=A1 S:$D(A2) DDH("ID",1)=A2 Q ; ; ; Z ;From DICQ1,DIEQ D Y,T Q ; Y D:'$D(DISYS) OS^DII S $X=0,$Y=0 S DIZ=$S($D(DILN)&'$D(DIR0):DILN,$G(IOSL):IOSL-3,1:21) ;** Q ; ; ; STP Q:$D(DD)[0!($D(DIY)[0) I DD+DIY'>79 W ?DD S DD=DD+DIY Q ; T W !?3 S DD=DIY+3 I $Y>DIZ!'$Y D .N DDSUP S DDSUP=$$EZBLD^DIALOG(8053) W DDSUP R %Y:$G(DTIME,300) ;** . E S DTOUT=1 K DDD . W $C(13),$J("",$L(DDSUP)+3),$C(13) Q:$D(DTOUT) . I %Y[U S DTOUT=0 K DDD . D Y W ?3 Q ; W S A4=$O(DDH(A0,"")) Q:A4="" Q:DDH(A0,A4)="" W:'$D(DDD) ! I $G(DDD)=3,A4["T" K DDD ; WR I A4["X" D Q . N DDD,DIY,DDSXEC . S DDSXEC=DDH(A0,A4) . N DDH . I $D(DDS) N DDSID S DDSID=1 S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_DX . X DDSXEC ; I A4["Q" D Q . S A4=DDH(A0,A4),%=$P(A4,U,1) . I $D(DDS) D ASK Q . W $P(A4,U,2) . D YN^DICN ; I A4["T" D Q . I DDH(A0,A4)[$C(0) D .. S DX=$L(DDH(A0,A4),$C(0))-1 .. X DDXY .. S DDH(A0,A4)=$TR(DDH(A0,A4),$C(0),"") . W DDH(A0,A4) ; I '$D(DDS),$G(DDD)'["J",A4'=+A4 Q I $D(DDS),$G(DDD)=2!($G(DDD)["J") W A0,?7 ; CHOICE I $D(DDS),$G(DDSMOUSY) D .W " " D WRITMOUS(DDH(A0,A4)) E W DDH(A0,A4) I $D(DDH("ID")) D S:$D(DUOUT) DIY=U . N DDD,DIY,DDSID . S DDSID=DDH("ID") . S:$D(DDH("ID",1))#2 DDSID(1)=DDH("ID",1) . N DDH . S:$D(DDSID(1))#2 DDH("ID",1)=DDSID(1) K DDSID(1) . S Y=A4 . S:$D(DDS) DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)_U_$X . X DDSID Q ; ; WRITMOUS(C) ;MAKE THE CHOICES IN THE COMMAND AREA CLICKABLE!! W $P(DDGLCLR,DDGLDEL) N F F Q:$A(C)-32 S C=$E(C,2,999) W " " ;LEADING BLANKS F F=0:1 Q:$A(C,$L(C))-32 S C=$E(C,1,$L(C)-1) I $G(DDSMOUSY) S DDSMOUSE($Y,$X,$X+$L(C)-1,1)=C W $$HIGH(C) E W C W $J("",F) Q ; ; ; HIGH(X) ;also from DDSCOM, DDSR I '$D(DDGLVID) Q X Q $P(DDGLVID,DDGLDEL,10)_$P(DDGLVID,DDGLDEL,6)_X_$P(DDGLVID,DDGLDEL,10) ; ; ; ASK W $P(A4,U,2)_$S(%'>2:"? ",1:"")_$S(%>0&(%<3):$P($$EZBLD^DIALOG(7001),U,%)_"// ",1:"")_$P(DDGLCLR,DDGLDEL) S A2=0 D READ I $G(DUOUT) S A2=-1 Q I %>2 S A2=X Q N %1 S %1=$$PRS^DIALOGU(7001,X) S:%1>0 X=$E($P(%1,U,2)) K %1 I "YyNn^"'[X W $C(7) X DDXY G ASK I X]"","^Nn"[X S A2=2 K DDC Q S:"Yy"[X A2=1 S:X=""&(%]"") A2=+% S DDD=1 Q ; ; READ ;RETURNS 'X' & 'DICQRETA' N DIR0P,DIR0KD,S X DDGLZOSF("EOFF") S (DIR0P,X)="" F D Q:'$D(S) .D READ^DIR01(.S) I S="TO" S DTOUT=1 K DCC G Q2 .I $L(S)=1 S X=X_S W S Q .I S="CR" K S Q .I S="EX"!(S="SV")!(S="QT") S DICQRETA=S,DUOUT=1,X=U K S Q .I S="MOUSEDN" Q ;ignore down-click .I S="MOUSE" K S D MOUSE^DIR01 K:$G(DIR0A)?."??" DIR0A S DUOUT=1,DDSQ=1 Q .W *7 X DDGLZOSF("EON") I X?1."^" S DUOUT=1,X=U Q D CLRMSG^DDS S DDM=1 Q ; ; ; ; H ;From DICN S:'$D(A1) A1="T" S DDH=$G(DDH)+1,DDH(DDH,A1)=DST K A1,DST D SC Q ;#8053 Press 'RETURN' to continue... ;#8081 Choose |from-to| or '^'... ;#7001 Yes^No DDSUTL DDSUTL ;SFISC/MKO-PROGRAMMER UTILITIES ;11:37 AM 25 Jul 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; MSG(TXT) ; ;Data validation messages D PROC(.TXT,$NA(@DDSREFT@("MSG"))) Q ; HLP(TXT) ; ;Help box messages D PROC(.TXT,$NA(@DDSREFT@("HLP"))) Q PROC(TXT,GLB) ; ;Put text into global N CNT,I S CNT=$G(@GLB) I $D(TXT)<9 S CNT=CNT+1,@GLB@(CNT)=TXT E S I="" F CNT=CNT:1 S I=$O(TXT(I)) Q:I="" S @GLB@(CNT+1)=TXT(I) S @GLB=CNT Q ; REFRESH ;Refresh the screen G R^DDSR ; MLOAD(DDSIEN) ;Load subrecords for current multiple G MLOAD^DDSM1 ; MDEL(DDSIEN) ;Delete subrecords for current multiple G MDEL^DDSM1 ; UNED(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change DISABLE EDITING attribute S:$D(DDSVAL)[0 DDSVAL="" D SETATT(4) Q ; REQ(DDSF,DDSB,DDSP,DDSVAL,DDSUDA) ;Change REQUIRED attribute S:$D(DDSVAL)[0 DDSVAL="" D SETATT(1) Q ; ; SETATT(DDSUPC) ;Set attribute node, piece DDSUPC N DDSOVAL,DDSUDDP,DDSUFLD,DDSUTP I $D(DDSPG)[0 N DDSPG S DDSPG="" I $D(DDSBK)[0 N DDSBK S DDSBK="" S DDSP=$$GETFLD^DDSLIB(DDSF,$G(DDSB),$G(DDSP),+DDS,DDSPG,DDSBK) I $G(DIERR) D ERR^DDSMSG Q ; S DDSF=$P(DDSP,","),DDSB=$P(DDSP,",",2),DDSP=$P(DDSP,",",3) ; S DDSUDDP=+$P($G(^DIST(.404,DDSB,0)),U,2) I DDSUDDP,$G(DDSUDA)]"" N DDSDA S DDSDA=DDSUDA E I DDSUDDP,DDSB'=DDSBK N DDSDA D GL^DDS10(DDSUDDP,.DDSDAORG,"","",.DDSDA) ; S DDSUTP=$P($G(^DIST(.404,DDSB,40,DDSF,0)),U,3) S:'DDSUTP DDSUTP=3 I DDSUTP=2 D . S DDSUFLD=DDSF_","_DDSB . S DDSUDDP=0 E I DDSUTP=3 D Q:'DDSUFLD . S DDSUFLD=$P($G(^DIST(.404,DDSB,40,DDSF,1)),U) E Q ; S DDSOVAL=$P($G(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A")),U,DDSUPC) Q:DDSVAL=DDSOVAL S $P(@DDSREFT@("F"_DDSUDDP,DDSDA,DDSUFLD,"A"),U,DDSUPC)=DDSVAL Q ; ADD(DDSFIL,X,DA,DINUM,DDSDIC0,DDSDR,DDSL) ; ;Add an entry as part of a transaction ;DDSL=1 means don't lock ; N %,%W,%Y,C,D0,DD,DO,DI,DIC,DIE,DQ,DR N DDSDA,DDSDIC,DDSFD,DDSREQ,DDSUP,I K DIERR,^TMP("DIERR",$J) K:'$G(DINUM) DINUM S:$G(DDSDIC0)="" DDSDIC0="L" S DIC(0)=DDSDIC0,Y=-1 S:$G(DDSDR)]"" DIC("DR")=DDSDR S DIC=$$ROOT^DILFD(DDSFIL,.DA),DDSDIC=$$CREF^DIQGU(DIC) ; I $D(@DDSDIC@(0))[0 D Q:$G(DIC("P"))="" . S DDSUP=$G(^DD(DDSFIL,0,"UP")) Q:'DDSUP . S DDSFD=$O(^DD(DDSUP,"SB",DDSFIL,"")) Q:'DDSFD . S DIC("P")=$P($G(^DD(DDSUP,DDSFD,0)),U,2) ; I DDSDIC0'["E",$$REQID(DDSFIL,.DDSREQ) D Q:$G(DIERR) . N F . S F="" . F S F=$O(DDSREQ(F)) Q:'F I $G(DIC("DR"))'[(F_"///") D BLD^DIALOG(3031,"ADD^DDSUTL") Q ; D FILE^DICN K DTOUT,DUOUT Q:Y=-1!'$D(DDS) ; I '$G(DDSL) D . N I,L,R . S L=1,R=DIC_DA_"," . F I=$L(R,",")-1:-1:1 I $D(^TMP("DDS",$J,"LOCK",$P(R,",",1,I)_")"))#2 S L=0 Q . I L,$D(^TMP("DDS",$J,"LOCK",$P(R,"(")))#2 S L=0 . I L L +@(DIC_+Y_")"):0 S ^TMP("DDS",$J,"LOCK",DIC_+Y_")")="" ; S DDSDA=+Y_"," F I=1:1 Q:$D(DA(I))[0 S DDSDA=DDSDA_DA(I)_"," S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=DDSDA_DIC Q ; REQID(FIL,REQ) ; ;Get list of required identifiers into DDSREQ N F K REQ S F="" F S F=$O(^DD(FIL,0,"ID",F)) Q:F'=+$P(F,"E") D . S:$P($G(^DD(FIL,F,0)),U,2)["R" REQ(F)="" Q $D(REQ)>0 ; DESTROY(PG) ;Destroy all data for page PG N P,B,F,IENS,TP,FIL,FLD S P=$O(^DIST(.403,+DDS,40,"B",PG,"")) Q:'P S B=0 F S B=$O(^DIST(.403,+DDS,40,P,40,B)) Q:'B D . Q:'$D(^DIST(.403,+DDS,40,P,40,B,0)) . Q:'$D(^DIST(.404,B,0)) S FIL=$P(^(0),U,2) . S F=0 F S F=$O(^DIST(.404,B,40,F)) Q:'F D .. Q:'$D(^DIST(.404,B,40,F,0)) S TP=$P(^(0),U,3) .. S:'TP TP=3 .. ; .. I TP=3 S FF="F"_FIL,FLD=$G(^DIST(.404,B,40,F,1)) Q:FLD?."^" .. E I TP=2 S FF="F0",FLD=F_","_B .. E Q .. ; .. S IENS=" " .. F S IENS=$O(@DDSREFT@(FF,IENS)) Q:IENS="" K ^(IENS,FLD) ; K @DDSREFT@(P),@DDSREFT@("XCAP",P) Q ; ; DDSDA(DA,DL,DDSDA) ;Determine DDSDA ; N I I DA="" S DDSDA="" Q S DDSDA=DA_"," F I=1:1:DL S DDSDA=DDSDA_DA(I)_"," Q DDSVAL DDSVAL ;SFISC/MKO-GET,PUT FOR DD IELDS ;2OCT2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. GET(DDSFILE,DA,DDSFLD,DDSER,DDSPARM) ;Get value for file/field N DDP,DIE,DDSANS,DDSTMP,X N DDSVDA,DDSVDDL0,DDSVDL,DDSVDV,DDSVND,DDSVPC,DIERR ; S DDSANS="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I" ; D GDIE() G:$G(DIERR) GETQ G:'$G(DDSVDA) GETQ ; I DDSFLD[":",$$FIND^DDSLIB(DDSFLD,":") D G GETQ . S DDSANS=$$REL^DDSVALM(DDP,.DA,DDSFLD,DDSPARM) ; S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) GETQ ; S:$D(DDSREFT)#2 DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD)) I $D(DDS),$D(DDSREFT)#2,$D(@DDSTMP@("D")) D . I $D(@DDSTMP@("M")),'^("M") D Q .. S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSVDA,DDSFLD)) .. M @DDSANS=@DDSTMP@("D") . S DDSANS=$G(@DDSTMP@("D")) I DDSPARM["E",$D(^("X"))#2 S DDSANS=^("X") E D . D GNDPC Q:$G(DIERR) . I DDSVPC=0,DDSVDV["W" D GETWP^DDSVALM Q . S DDSANS=$$GVAL(DIE,DA,DDSVND,DDSVPC) . I DDSPARM["E" S DDSANS=$$EXTERNAL^DILFD(DDP,DDSFLD,"",DDSANS) ; GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVAL") Q DDSANS ; PUT(DDSFILE,DA,DDSFLD,DDSVAL,DDSER,DDSPARM) ;Put value for file/field N DDP,DDSVDA,DDSV0,DDSV02,DDSVDL,DIE N DIERR ; S:$D(DDSVAL)[0 DDSVAL="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E" ; D GDIE($D(DDS)#2) G:$G(DIERR) PUTQ G:'$G(DDSVDA) PUTQ S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) PUTQ I DDSFLD=.01,"@"[DDSVAL D BLD^DIALOG(3086) G PUTQ ; S DDSV0=^DD(DDP,DDSFLD,0),DDSV02=$P(DDSV0,U,2) I +DDSV02 D . D MULT^DDSVALM E D VALPUT ; PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVAL") Q ; VALPUT ;Validate and put N DDSVY I DDSPARM["E" D . D VAL^DIE(DDP,DDSVDA,DDSFLD,"ER",DDSVAL,.DDSVY) E D . D AUXVAL^DIEV(DDP,DDSVDA,DDSFLD,"EIR",DDSVAL,.DDSVY,DDSV0,DDSV02) Q:$G(DIERR) I DDSVY=DDSVY(0),'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"X")) K DDSVY(0) ; I $D(DDS) D . S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD)) ^("GL")=DIE . D UPDATE(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.DDSVY) . S DDSCHG=1 E D . N DDSFDA . S DDSFDA(DDP,DDSVDA,DDSFLD)=DDSVY . D FILE^DIE("","DDSFDA") Q ; UPDATE(DDP,DDSVDA,DA,FLD,PG,Y) ;Store value, repaint N DX,DY,BK,DDO,LEN,EXT,PAGE,RJ,REP,VAL S (EXT,@DDSREFT@("F"_DDP,DDSVDA,FLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (EXT,^("X"))=Y(0) ; D:FLD=.01 . S PAGE=0 F S PAGE=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE)) Q:'PAGE D .. S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE,BK)) Q:'BK D ... D:$P($G(@DDSREFS@(PAGE,BK)),U,8) .... N DDSPTB S DDSPTB=$G(@DDSREFS@(PAGE,BK,"PTB")) .... D:DDSPTB]"" RPF^DDS7(DDP,DDSPTB,DDSVDA,.DA) ; S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK)) Q:'BK D . S DDO=0 F S DDO=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK,DDO)) Q:'DDO D .. S LEN=$G(@DDSREFS@(PG,BK,DDO,"D")) Q:LEN="" .. S DY=+LEN,DX=$P(LEN,U,2),RJ=$P(LEN,U,10),LEN=$P(LEN,U,3) .. S REP=$P($G(@DDSREFS@(PG,BK)),U,7) .. I $G(REP) D Q:DY="" ... N SN,PDA,OFS ... S PDA=$G(@DDSREFT@(PG,BK)) I 'PDA S DY="" Q ... S REP=$P($G(@DDSREFT@(PG,BK,PDA)),U,2,999) I REP="" S DY="" Q ... S SN=$G(@DDSREFT@(PG,BK,PDA,"B",DDSVDA)) I 'SN S DY="" Q HITE ... N HITE S HITE=$$HITE^DDSR(BK),OFS=SN-$P(REP,U,2)*HITE ;DJW/GFT ... I OFS'<0,$P(REP,U,5)*HITE>OFS S DY=DY+OFS ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW ... E S DY="" .. S VAL=$P(DDGLVID,DDGLDEL)_$E(EXT,1,LEN)_$P(DDGLVID,DDGLDEL,10) .. X IOXY .. W $S(RJ:$J("",LEN-$L(EXT))_VAL,1:VAL_$J("",LEN-$L(EXT))) ; D:$D(@DDSREFS@("PT",DDP,FLD)) RPB^DDS7(DDP,FLD,PG) D:$D(@DDSREFS@("COMP",DDP,FLD,PG)) RPCF^DDSCOMP(PG) Q ; GDIE(DDSVL) ;In: ; DDSFILE = File # or root ; DA = Record array ; DDSVL = Flag to lock record ;Returns: ; DIE = Global root of file ; DDP = File # ; DDSVDL = Level # ; DDSVDA = DA,DA(1),..., S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2)) I DDP=0 D BLD^DIALOG(202,"file") Q D GL^DDS10(DDP,.DA,.DIE,.DDSVDL,.DDSVDA,$G(DDSVL)) Q ; GNDPC ;In: ; DDP = File # ; DDSFLD = Field # ;Returns: ; DDSVDDL0 = 0 node of DD ; DDSVND = Node where data resides ; DDSVPC = Piece where data resides ; DDSVDV = Field specifications ; X = Pointed to file root or set of codes I $G(DDSFLD)="" D BLD^DIALOG(202,"field") Q S DDSVDDL0=$G(^DD(DDP,DDSFLD,0)) I DDSVDDL0?."^" D Q . N I,E . S (I("FILE"),E("FILE"))=DDP,I(1)="#"_DDSFLD,E("FIELD")=DDSFLD . D BLD^DIALOG(501,.I,.E) ; S DDSVPC=$P(DDSVDDL0,U,4) S DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2) S DDSVDV=$P(DDSVDDL0,U,2),X=$P(DDSVDDL0,U,3) ; N P S P("FILE")=DDP,P("FIELD")=DDSFLD I DDSVPC=" " D . D BLD^DIALOG(520,"computed",.P) I DDSVPC=0 D . S DDSVDV=+DDSVDV_$P($G(^DD(+DDSVDV,.01,0)),U,2) . D:DDSVDV'["W" BLD^DIALOG(520,"multiple",.P) Q ; GVAL(DIE,DA,ND,PC) ;Get value N LN,Y S LN=$G(@(DIE_"DA,ND)")) I $E(PC)'="E" S Y=$P(LN,U,PC) E S Y=$E(LN,+$E(PC,2,999),$P(PC,",",2)) S:Y?." " Y="" Q Y ; FIELD(DDP,FLD) ;Get field number N F,P S:$E(FLD)="""" FLD=$$UQT^DDSLIB($E(FLD,1,$$AFTQ^DDSLIB(FLD)-1)) ; S F=FLD,P("FILE")=DDP I FLD'=+$P(FLD,"E") D Q:$G(DIERR) "" . S F=$O(^DD(DDP,"B",FLD,"")) . I F="" S P(1)=FLD D BLD^DIALOG(501,.P) ; I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q "" Q F DDSVALF DDSVALF ;SFISC/MKO-GET,PUT VALUES FOR FORM ONLY FIELDS ;2OCT2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. GET(DDSVFD,DDSVBK,DDSVPG,DDSPARM,DDSVDA) ;Get value ;In: DDSPG = Current page ; DDSBK = Current block ; DDSPARM = "I" : internal, "E" : external form ; N DDSANS,DDSFLD,DDSVDDP,DIERR I $D(DDSPG)[0 N DDSPG S DDSPG=0 I $D(DDSBK)[0 N DDSBK S DDSBK=0 S DDSANS="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I" ; S DDSFLD=$P($$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,$G(DDSPG),$G(DDSBK),"F"),",",1,2) G:$G(DIERR) GETQ ; S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2) ; S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2) I DDSVDDP,$G(DDSVDA)]"" N DDSDA D . I DDSVDA'["," S DDSVDA=$$IENS^DILF(.DDSVDA) . E S:DDSVDA'?.E1"," DDSVDA=DDSVDA_"," . S DDSDA=DDSVDA E I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA) ; I $D(@DDSREFT@("F0",DDSDA,DDSFLD,"D"))#2 S DDSANS=^("D") S:DDSPARM["E"&($D(^("X"))#2) DDSANS=^("X") G GETQ ; I "013"[$P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3) D BLD^DIALOG(520,"DD or caption-only") G GETQ ; ;Form-only fields I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=2 D G:$G(DIERR) GETQ . I $P($G(^DIST(.404,DDSVBK,40,DDSVFD,20)),U)="" D Q .. N P S P(1)="READ TYPE",P(2)="FIELD multiple of the BLOCK" .. D BLD^DIALOG(3011,.P) . D:$D(^DIST(.404,DDSVBK,40,DDSVFD,3))#2 DEF(^(3),$G(^(3.1)),.DDSANS) . S (@DDSREFT@("F0",DDSDA,DDSFLD,"D"),^("O"))=DDSANS . I DDSANS]"" D .. D:$D(DDSANS(0)) ... S @DDSREFT@("F0",DDSDA,DDSFLD,"X")=$G(DDSANS(0,0),DDSANS(0)) ... S:DDSPARM["E" DDSANS=$G(DDSANS(0,0),DDSANS(0)) .. S $P(@DDSREFT@("F0",DDSDA,DDSFLD,"F"),U)=3,DDSCHG=1 ; ;Computed fields E S:$P($G(^DIST(.404,DDSVBK,40,DDSVFD,0)),U,3)=4 DDSANS=$$VAL^DDSCOMP(DDSVFD,DDSVBK,DDSDA) ; GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVALF") Q DDSANS ; PUT(DDSVFD,DDSVBK,DDSVPG,DDSVAL,DDSPARM,DDSVDA) ;Put value N DIR,X,Y N DDER,DDSFLD,DDSVDDP,DDSVX,DIERR I $D(DDSPG)[0 N DDSPG S DDSPG=0 I $D(DDSBK)[0 N DDSBK S DDSBK=0 S:$D(DDSVAL)[0 DDSVAL="" I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E" ; S DDSFLD=$$GETFLD^DDSLIB($G(DDSVFD),$G(DDSVBK),$G(DDSVPG),DDS,DDSPG,DDSBK,"F") G:$G(DIERR) PUTQ S DDSVFD=+DDSFLD,DDSVBK=+$P(DDSFLD,",",2),DDSVPG=$P(DDSFLD,",",3) S DDSFLD=$P(DDSFLD,",",1,2) ; S DDSVDDP=+$P($G(^DIST(.404,DDSVBK,0)),U,2) I DDSVDDP,$G(DDSVDA)]"" N DDSDA D . I DDSVDA'["," S DDSVDA=$$IENS^DILF(.DDSVDA) . E S:DDSVDA'?.E1"," DDSVDA=DDSVDA_"," . S DDSDA=DDSVDA E I DDSVDDP,DDSVBK'=DDSBK N DDSDA D GL^DDS10(DDSVDDP,.DDSDAORG,"","",.DDSDA) ; I $P(^DIST(.404,DDSVBK,40,DDSVFD,0),U,3)'=2 D BLD^DIALOG(520,"DD, computed, or caption-only") G PUTQ ; S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3) I DDSPARM["I",$E(DIR(0))="P"!(DIR(0)?1"DD".E) D . N FIL,FILROOT,FLD . S Y=DDSVAL . I $E(DIR(0))="P" D .. S FIL=$P($P(DIR(0),U,2),":") .. I 'FIL S FILROOT=U_FIL,FIL=+$P($G(@(U_FIL_"0)")),U,2) Q:'FIL .. E S FILROOT=$G(^DIC(FIL,0,"GL")) Q:FILROOT="" .. S Y(0)=$P($G(@(FILROOT_Y_",0)")),U) .. S Y(0)=$$EXTERNAL^DILFD(FIL,.01,"",Y(0)) . E D .. N DV,I S FIL=$P($P(DIR(0),","),U,2),FLD=$P(DIR(0),",",2) .. S DV=$P($G(^DD(FIL,FLD,0)),U,2) .. F I="O","P","V","D","S" I DV[I S Y(0)=$$EXTERNAL^DILFD(FIL,FLD,"",Y) Q E D G:$G(DDER) PUTQ . I DDSVAL="" D Q .. N DDSVREQ .. S DDSVREQ=$P($G(@DDSREFT@(DDSVPG,DDSVBK,DDSVFD)),U) .. S:DDSVREQ]"" DDSVREQ=$P($G(^DIST(.404,DDSVBK,40,DDSVFD,4)),U) .. I DDSVREQ S DDER=1 .. E S Y="" . S DIR("V")="",(X,DIR("B"))=DDSVAL . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) . I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D .. N I .. S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z" .. S $P(I,":",2)=$P(I,":",2)_"Z" .. S $P(DIR(0),U,2)=I . D ^DIR . I $E($P(DIR(0),U))="P" S Y=$P(Y,U) ; ;Update ^TMP S DDSCHG=1 S (DDSVX,@DDSREFT@("F0",DDSDA,DDSFLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (DDSVX,^("X"))=$S($D(Y(0,0))#2:Y(0,0),1:Y(0)) I $D(^("X"))#2,Y="" S (DDSVX,^("X"))="" ; ;Repaint field if it appears on the current page I $D(@DDSREFS@("F0",DDSFLD,"L",DDSPG,DDSVBK,DDSVFD))#2 D . N DY,DX,DDSVL,DDSVRJ,DDSX,DDSVREP . S DDSVREP=$P($G(@DDSREFS@(DDSPG,DDSVBK)),U,7) . S DY=+@DDSREFS@(DDSPG,DDSVBK,DDSVFD,"D"),DX=$P(^("D"),U,2),DDSVL=$P(^("D"),U,3),DDSVRJ=$P(^("D"),U,10) . I $G(DDSVREP) D Q:DY="" .. N DDSVSN,DDSVPDA,DDSVOFS .. S DDSVPDA=$G(@DDSREFT@(DDSPG,DDSVBK)) I 'DDSVPDA S DY="" Q .. S DDSVREP=$P($G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA)),U,2,999) I DDSVREP="" S DY="" Q .. S DDSVSN=$G(@DDSREFT@(DDSPG,DDSVBK,DDSVPDA,"B",DDSDA)) I 'DDSVSN S DY="" Q HITE .. N HITE S HITE=$$HITE^DDSR(DDSVBK),DDSVOFS=DDSVSN-$P(DDSVREP,U,2)*HITE ;DJW/GFT .. I DDSVOFS'<0,$P(DDSVREP,U,5)*HITE>DDSVOFS S DY=DY+DDSVOFS ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW .. E S DY="" . S DDSX=$P(DDGLVID,DDGLDEL)_$E(DDSVX,1,DDSVL)_$P(DDGLVID,DDGLDEL,10) . X IOXY . W $S(DDSVRJ:$J("",DDSVL-$L(DDSVX))_DDSX,1:DDSX_$J("",DDSVL-$L(DDSVX))) ; D . N DDP,DDSDA S DDP=0,DDSDA="0," . D:$D(@DDSREFS@("PT",DDP,DDSFLD)) RPB^DDS7(DDP,DDSFLD,DDSPG) . D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF^DDSCOMP(DDSPG) ; PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVALF") Q ; DEF(DDSLN3,DDSLN31,Y) ;Get default N DDER,DIR,X Q:DDSLN3="" ; I DDSLN3'="!M" S Y=DDSLN3 E I DDSLN31'?."^" X DDSLN31 S:$D(Y)[0 Y="" Q:Y="" ; S DIR(0)=$P(^DIST(.404,DDSVBK,40,DDSVFD,20),U)_$P(^(20),U,2,3) S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999) S DIR("V")="",(X,DIR("B"))=Y D ^DIR I DDER K Y S Y="" ; I Y]"",$E($P(DIR(0),U))="P" S Y=$P(Y,U) Q ; DDSVALM DDSVALM ;SFISC/MKO-PUT FOR MULTIPLES (SELECT PROMPT) ;10:45 AM 9 Sep 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; MULT ;Put multiple or wp field N DDSVDIC,DDSVDV,DDSVND,DDSVPC,DDSVSUB S DDSVPC=$P(DDSV0,U,4),DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2) S DDSVSUB=+DDSV02 Q:$D(^DD(DDSVSUB,.01,0))[0 S DDSVDV=DDSVSUB_$P(^DD(DDSVSUB,.01,0),U,2),X=$P(^(0),U,3) S DDSVDIC=DIE_DA_","""_DDSVND_"""," ; I DDSVDV["W" D PUTWP I DDSVDV'["W" D PUTMULT Q ; PUTMULT ;Put for multiples N DDSVRN S DDSVRN=$S(DDSVAL="FIRST":$O(@(DDSVDIC_"0)")),DDSVAL="LAST":$O(@(DDSVDIC_""" "")"),-1),1:+$G(DDSVAL)) ; K Y S Y="",Y(0)="" I DDSVRN>0,$D(@(DDSVDIC_+DDSVRN_",0)"))#2 S Y(0)=$P(^(0),U) D . I DDSVDV["O"!(DDSVDV["P")!(DDSVDV["V")!(DDSVDV["D")!(DDSVDV["S") D .. S Y(0)=$$EXTERNAL^DILFD(DDSVSUB,.01,"",DDSVRN) . S Y=DDSVRN ; S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"M")) ^("M")=1_DDSVDIC_U_DDSVSUB D UPDATE^DDSVAL(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.Y) Q ; PUTWP ;File wp field from @DDSVAL into @DDSREFT N DDSTMP S DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSDA)) ; I DDSVAL]"",$D(@DDSVAL) D Q:$G(DIERR) . D PUTWP^DIEFW($E("A",DDSPARM["A"),DDSVAL,$NA(@DDSTMP@(DDSFLD,"D"))) E K @DDSTMP@(DDSFLD,"D") ; S:$D(@DDSTMP@(DDSFLD,"M"))[0 ^("M")="0"_DDSVDIC_U_DDSVSUB S:$D(@DDSTMP@("GL"))[0 ^("GL")=DIE S (DDSCHG,@DDSTMP@(DDSFLD,"F"))=3 Q ; GETWP ;Merge wp field into ^TMP, return root in DDSANS N DDSGL S DDSGL=DIE_DA_","""_DDSVND_"""," S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSDA,DDSFLD)) ; K @DDSANS M:$D(@(DDSGL_"0)"))#2 @DDSANS=@($E(DDSGL,1,$L(DDSGL)-1)_")") Q ; REL(DDP,DA,DDSFLD,DDSPARM) ;Relational syntax N DDSCD,DDSI,X D DD^DDSPTR(DDP,DDSFLD,"",.DDSCD,"",DDSPARM["I"+1) F DDSI=1:1:DDSCD X DDSCD(DDSI) Q X ; ERR(DDSVEP) ;Print error messages Q:'$G(DIERR) I '$D(DDS) D MSG^DIALOG("BW") Q N DDSVMSG S DDSER=DIERR D BLD^DIALOG(3031,DDSVEP,"","DDSVMSG") D MSG^DDSMSG(DDSVMSG(1)),ERR^DDSMSG Q DDSWP DDSWP ;SFISC/MKO-WP ;20FEB2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EDIT ;Edit the word processing field N I S DDSUE=$D(DDSTP)#2!$S($P($G(DDSU("A")),U,4)="":$P($G(DDSO(4)),U,4),1:$P(DDSU("A"),U,4)) I 'DDSUE S I=$P((DDSU("DD")),U,2) I I,$P($G(^DD(I,.01,0)),U,2)["I",$G(DDSGL)["(",$O(@(DDSGL_"0)")) S DDSUE=1 ;UNEDITABLE WORD-PROCESSING FIELD I DDSUE D I $D(DIRUT) K DIRUT,DUOUT,DIROUT G EDITQ .D:DDM CLRMSG^DDS .N DDSWP D BLD^DIALOG(8178,,,"DDSWP"),MSG^DDSMSG(.DDSWP) H 2 Q ;** S DDSUTL=$NA(@DDSREFT@("F"_DDP,DDSDA,DDSFLD)) ; I $D(@DDSUTL@("F"))[0,$D(@(DDSGL_"0)"))#2 D . K @DDSUTL@("D") . M @DDSUTL@("D")=@($E(DDSGL,1,$L(DDSGL)-1)_")") MOUSEOFF W *27,"[?1000l" S (DY,DX)=0 X IOXY W $P(DDGLCLR,DDGLDEL,2) S DIC=$E(DDSUTL,1,$L(DDSUTL)-1)_",""D"",",DWPK=1 S DIWESUB=$P($G(DDSU("DD")),U) K:DIWESUB="" DIWESUB ;S DDWFLAGS=$G(DDWFLAGS)_"K" D EN^DIWE ;,INIT^DDGLIB0() K DIC,DIWESUB,DWPK I 'DDSUE S DDSCHG=1,@DDSUTL@("F")=1 E K @DDSUTL@("D") MOUSEON I $G(DDS)>0,$G(DDSMOUSY) W *27,"[?1000h" EDITQ K DDSUE,DDSUTL Q ; WP ;At the wp field S DIR(0)="FO^0:0" I $$WPLUS("F"_DDP,DDSDA,DDSFLD) S DIR("B")="+" ;WHEN CURSOR IS ON FIELD, "+" WILL SHOW IF THERE IS ALREADY W-P DATA THERE EGP S DIR("?")="^W $$EZBLD^DIALOG(8179)" ;**CCO/NI "Press to edit this word processing field." S DIR("??")="^D HELP^DDSWP" D ^DIR K DIR,DUOUT,DIRUT,DIROUT Q ; WPLUS(FFILE,DA,FIELD) ;SAYS WHETHER WP FIELD HAS SOME DATA ;EXAMPLE: ;^TMP("DDS",4028,181,"F666001","889,",15,"F")=1 ;^TMP("DDS",4028,181,"F666001","889,",15,"M")="0^DIZ(666001,889,""17"",^666001.0" N WP I DA="" Q 0 I 'FIELD Q 0 I $G(@DDSREFT@(FFILE,DA,FIELD,"F"))=1 Q $O(^("D",0))>0 ;IF WE'VE EDITED, ARE THERE LINES LEFT? I $G(@DDSREFT@(FFILE,DA,FIELD,"M"))?1"0^".E S WP=$P(^("M"),U,2) I WP["(" S WP=U_$$CREF^DILF(WP_0),WP=$P($G(@WP),U,3) Q ''WP ;IF WE HAVEN'T EDITED, LOOK IN THE DATA Q 0 ; ; HELP ;?? help at the WP field S DDSFN=+$P(DDSU("M"),U,3) D:$G(^DD(DDSFN,.01,3))]"" MSG^DDSMSG($$HELP^DIALOGZ(DDSFN,.01)) ;**CCO/NI WORD-PROCESSING FIELD HELP X:$G(^DD(DDSFN,.01,4))]"" ^(4) D:$D(^DD(DDSFN,.01,21)) WP^DDSMSG("^DD("_DDSFN_",.01,21)") K DDSFN Q DDSZ DDSZ ;SFISC/MKO-FORM COMPILER ;17JUN2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;Prompt, compile N DDSFRM,DDSDDP,DDSREFS N C,DIC,X,Y I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; S DIC="^DIST(.403,",DIC(0)="AEQZ" D ^DIC K DIC Q:Y=-1!'$D(^DIST(.403,+Y,0)) S DDSFRM=Y,DDSDDP=$P(Y(0),U,8) ; W !!,"Compiling "_$P(Y,U,2)_" (#"_+Y_") ...",! D EN(DDSFRM,DDSDDP) I $G(DIERR) W $C(7) D MSG^DIALOG("BW") Q ; ALL ;Compile all forms N DDSFRM,DDSDDP,DDSFNUM,DDSREFS I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU W:'$D(DDSQUIET) !,"Compiling all forms ...",! ; S DDSFNUM=0 F S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM D . Q:$D(^DIST(.403,DDSFNUM,0))[0 . S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U),DDSDDP=+$P(^(0),U,8) . S DDSREFS=$$REF^DDS0(DDSFRM) . W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")" . D EN(DDSFRM,DDSDDP) . I $G(DIERR),'$D(DDSQUIET) W !,$C(7) D MSG^DIALOG("BW") W ! Q ; EN(DDSFRM,DDSDDP,DDSREFS) ;Compile a form N DDSDO,DDSPG,DDSNDD,DDSPGRP ; S:'$G(DDSDDP) DDSDDP=$P(^DIST(.403,+DDSFRM,0),U,8) S:$G(DDSREFS)="" DDSREFS=$$REF^DDS0(DDSFRM) K @DDSREFS ; ;Find page groups D PGRP^DDSZ3(+DDSFRM,.DDSPGRP) ; S DDSPG=0,(DDSDO,DDSNDD)=1 F S DDSPG=$O(^DIST(.403,+DDSFRM,40,DDSPG)) Q:'DDSPG D PG(DDSFRM,DDSPG,DDSDDP,.DDSDO,.DDSNDD) Q:$G(DIERR) I $G(DIERR) D ERR(DDSFRM,DDSREFS) Q S $P(^DIST(.403,+DDSFRM,0),U,9,11)=+$G(DDSDO)_U_+$G(DDSNDD)_U_1 ;DDSNDD=1 means don't need a starting DA Q ; PG(DDSFRM,DDSPG,DDSDDP,DDSDO,DDSNDD) ;Compile a page ; Q:$D(^DIST(.403,+DDSFRM,40,DDSPG,0))[0 D:$P($G(^DIST(.403,+DDSFRM,40,DDSPG,1)),U,2)]"" ASUB^DDSZ3(DDSPG,DDSFRM) ; ;Get page coordinates S DDSPX=$P(^DIST(.403,+DDSFRM,40,DDSPG,0),U,3) S DDSPY=$P(DDSPX,",")-1,DDSPX=$P(DDSPX,",",2)-1 S:DDSPY<0 DDSPY=0 S:DDSPX<0 DDSPX=0 ; ;Compile header block S DDSB=$P($G(^DIST(.403,+DDSFRM,40,DDSPG,0)),U,2) I DDSB]"" D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,"",1,"",.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END ; ;Compile all other blocks on page S DDSBO="" F S DDSBO=$O(^DIST(.403,+DDSFRM,40,DDSPG,40,"AC",DDSBO)) Q:DDSBO="" S DDSB=$O(^(DDSBO,0)) Q:'DDSB D BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,"",.DDSDO,.DDSNDD,.DDSSCR,.DDSNAV,.DDSORD) G:$G(DIERR) END ; D:$D(DDSSCR)!$D(DDSORD) EN^DDSZ2(.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV) ; END K DDSB,DDSBO,DDSMUL,DDSNAV,DDSORD K DDSP,DDSPX,DDSPY,DDSREP,DDSRNAV,DDSSCR Q ; BLK(DDSFRM,DDSPG,DDSDDP,DDSPY,DDSPX,DDSB,DDSBO,DDSH,DDSDO,DDSNDD,DDSSCR,DDSNAV,DDSORD) ; ;Compile block ; DDSH = 1 if header block ; DDSDO = killed if any edit blocks ; DDSNDD = killed if any DD fields ; N DDP I $D(^DIST(.404,DDSB,0))[0 D BLD^DIALOG(3051,"#"_DDSB) Q S DDSDN=$P(^DIST(.404,DDSB,0),U,3),DDP=+$P(^(0),U,2) ; S DDSPTB="" S:'$G(DDSH) DDSPTB=$G(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,1)) ; ;Get DDSBY,DDSBX,DDSTP I $G(DDSH) S DDSBY=DDSPY,DDSBX=DDSPX,DDSTP="h",DDSREP=1 E D . S DDSBX=$P(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,0),U,3),DDSTP=$P(^(0),U,4) S DDSREP=$S($G(^(2)):^(2),1:1) . K:DDSTP="e" DDSDO . S DDSBY=$P(DDSBX,",")-1,DDSBX=$P(DDSBX,",",2)-1 . S:DDSBY<0 DDSBY=0 S:DDSBX<0 DDSBX=0 . S DDSBY=DDSBY+DDSPY,DDSBX=DDSBX+DDSPX IND . I DDSREP>1,+$G(^DIST(.403,+DDSFRM,21))=+$P($G(^DIST(.403,+DDSFRM,40,DDSPG,0)),U) D ;RECORD SELECTION PAGE USING REPEATING BLOCK ..N IND ..S IND=$P(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,2),U,2) I IND]"",$D(^DD(+DDSDDP,0,"IX",IND,+DDSDDP)) D ...S IND=^DIC(+DDSDDP,0,"GL")_""""_IND_"""" ;BUILD COMPUTED MULTIPLE OFF THE REPEATING-BLOCK INDEX ...I $D(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL")) ...S ^("COMP MUL")="N D,DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTRT)=$NA("_IND_")),DIMSCNT=$QL(DIMQ) F S DIMQ=$Q(@DIMQ) Q:DIMQ="""" Q:$NA(@DIMQ,DIMSCNT)'=DIMSTRT S D=$QS(DIMQ,$QL(DIMQ)) Q:'D I @DIMQ="""" N D0 S D0=D X DICMX" ..I $G(^DIST(.403,+DDSFRM,40,DDSPG,40,DDSB,"COMP MUL"))]"" S ^("COMP MUL PTR")=+DDSDDP ; ;Set @DDSREFS@(DDSPG,DDSB) S @DDSREFS@(DDSPG,DDSB)=DDSBY_U_DDSBX_U_$P($G(^DIST(.404,DDSB,0)),U,2)_U_DDSDN_U_DDSTP_$S(DDSREP>1:U_U_+DDSREP,1:"") ; D:DDSPTB]"" PT^DDSPTR(DDSDDP,DDSPTB,DDSFRM,DDSPG,DDSB) D EN^DDSZ1(DDSPG,DDSB,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,.DDSNDD,.DDSPGRP,.DDSSCR,.DDSNAV,.DDSORD,.DDSRNAV) ; K DDSBX,DDSBY,DDSDN,DDSPTB,DDSTP Q ; ENGRP(DDSFRM) ;Compile a form and all forms that use any of the blocks ;on that form N DDSLST D FRMLST(DDSFRM,.DDSLST) ; ;Compile all forms in DDSLST S DDSFRM=0 F S DDSFRM=$O(DDSLST(DDSFRM)) Q:'DDSFRM D EN(DDSFRM) Q ; DELGRP(DDSFRM) ;Uncompile a form and all forms that use any of the blocks ;on that form N DDSLST D FRMLST(DDSFRM,.DDSLST) ; ;Uncompile all forms in DDSLST S DDSFRM=0 F S DDSFRM=$O(DDSLST(DDSFRM)) Q:'DDSFRM D DEL(DDSFRM) Q ; ENLIST(DDSROOT) ;Compile all forms in @DDSROOT N DDSFRM S DDSFRM=0 F S DDSFRM=$O(@DDSROOT@(DDSFRM)) Q:'DDSFRM D EN(DDSFRM) Q ; FRMLST(DDSFRM,DDSLST) ;Build list of forms that contain blocks on this form N DDSPG,DDSBK S DDSPG=0 F S DDSPG=$O(^DIST(.403,DDSFRM,40,DDSPG)) Q:'DDSPG D . D BLDLST($P($G(^DIST(.403,DDSFRM,40,DDSPG,0)),U,2),.DDSLST) . S DDSBK=0 F S DDSBK=$O(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK)) Q:'DDSBK D .. D BLDLST($P($G(^DIST(.403,DDSFRM,40,DDSPG,40,DDSBK,0)),U),.DDSLST) Q ; BLDLST(DDSBK,DDSLST) ;Build list of forms that contain a given block N DDSFRM Q:'$G(DDSBK) S DDSFRM=0 F S DDSFRM=$O(^DIST(.403,"AB",DDSBK,DDSFRM)) Q:'DDSFRM S DDSLST(DDSFRM)="" S DDSFRM=0 F S DDSFRM=$O(^DIST(.403,"AC",DDSBK,DDSFRM)) Q:'DDSFRM S DDSLST(DDSFRM)="" Q ; DELALL ;Delete compile global for all forms N DDSFRM,DDSFNUM,DDSREFS W:'$D(DDSQUIET) !,"Deleting compiled form data ...",! ; S DDSFNUM=0 F S DDSFNUM=$O(^DIST(.403,DDSFNUM)) Q:'DDSFNUM D . Q:$D(^DIST(.403,DDSFNUM,0))[0 . S DDSFRM=DDSFNUM_U_$P(^DIST(.403,DDSFNUM,0),U) . W:'$D(DDSQUIET) !?3,$P(DDSFRM,U,2),?35,"(#"_+DDSFRM_")" . D DEL(DDSFRM) Q ; DEL(DDSFRM) ;Delete compiled global N DDSREFS S DDSREFS=$$REF^DDS0(DDSFRM) K @DDSREFS S $P(^DIST(.403,+DDSFRM,0),U,11)="" Q ; ERR(DDSFRM,DDSREFS) ;Print error, kill compiled global Q:'$G(DIERR) N DDSNAM S DDSNAM=$P(DDSFRM,U,2) S:DDSNAM="" DDSNAM=$P($G(^DIST(.403,+DDSFRM,0)),U) D BLD^DIALOG(3002,DDSNAM) S $P(^DIST(.403,+DDSFRM,0),U,11)="" K @DDSREFS Q DDSZ1 DDSZ1 ;SFISC/MKO-GET BLOCK INFO,SCREEN IMAGE ;20JAN2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN(DDSPG,DDSBK,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,DDSNDD,DDSPGRP,DDSSCR,DDSNAV,DDSORD,DDSRNAV) ; ;Input: ; DDSREFS = Global ref ;Output: ; DDSSCR ; DDSNAV ; DDSORD ; DDSRNAV ; N Y S:$G(DDSTP)="" DDSTP="e" I DDSTP'="h",$G(DDSBO),$D(DDSORD(DDSBO))[0 D . S DDSORD(DDSBO)=DDSBK . S:$G(DDSREP)>1 $P(DDSORD(DDSBO),U,2)=$S($P(DDSREP,U,5)]"":$P($$GETFLD^DDSLIB($P(DDSREP,U,5),"","","","",DDSBK),","),1:"FIRST") ; LOOP N DDSHITE S DDSHITE=$$HITE^DDSR(DDSBK),DDSF=0 ;DJW/GFT HEIGHT OF MULTIPLES F S DDSF=$O(^DIST(.404,DDSBK,40,DDSF)) Q:DDSF'=+DDSF D FLD ; KILL K DDSC1,DDSC2,DDSCAP,DDSCLN,DDSD1,DDSD2,DDSD3 K DDSDDL0,DDSF,DDSFLD,DDSKEY,DDSL0,DDSL01,DDSL2,DDSL4,DDSN Q ; FLD ;Set up ; @DDSREFS@(pg,bk,ddo, ; "D") = data $Y^data $X^data $L^field# ; ^xcap $Y^xcap $X^xcap colon^xcap req ; ^1 if computed field^1 if right justified ; "COMPE") = M code that sets X ; "COMPE",1) = array sets DDSE(n) ; ; @DDSREFS@("Ffile#",field#,"L",pg,bk,ddo)="" ; ; DDSSCR(row) = captions on that row ; DDSSCR(row,col) = final columns underlined ; DDSNAV(row,col) = ddo,bk for editable fields ; DDSORD(bo,fo) = ddo for editable fields ; ;Get field properties S:'$P(^DIST(.404,DDSBK,40,DDSF,0),U,3) $P(^(0),U,3)=3 S DDSL0=$G(^DIST(.404,DDSBK,40,DDSF,0)),DDSL01=$G(^(.1)),DDSFLD=$S($P(DDSL0,U,3)=2:DDSF_","_DDSBK,1:+$G(^(1))),DDSL2=$G(^(2)),DDSL4=$G(^(4)) K:$P(DDSL0,U,3)=3!'$P(DDSL0,U,3) DDSNDD ;REMEMBER THAT AT LEAST ONE FIELD IS A DATA DICTIONARY S DDSDDL0=$G(^DD(DDP,DDSFLD,0)) Q:DDSL0?."^"!(DDSL2?."^") S DDSKEY=DDSFLD'[","&($D(^DD("KEY","F",DDP,DDSFLD))>1) S DDSD1=$P($P(DDSL2,U),",")+DDSBY-1 S DDSD2=$P($P(DDSL2,U),",",2)+DDSBX-1 S DDSD3=$P(DDSL2,U,2) S DDSC1=$P($P(DDSL2,U,3),",")+DDSBY-1 S DDSC2=$P($P(DDSL2,U,3),",",2)+DDSBX-1 S DDSCAP=$TR($P(DDSL0,U,2)," ",$C(0)) S DDSCLN=$S(DDSCAP="":"",$P(DDSL0,U,3)=1:"",$P(DDSL2,U,4):"",1:":") ; I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D . ;Set CAP xref for ^-jumping . I DDSTP="e","^2^3^"[(U_$P(DDSL0,U,3)_U)!'$P(DDSL0,U,3) D .. N C,I,L .. S I=0 F S I=$O(DDSPGRP(I)) Q:'I Q:U_DDSPGRP(I)_U[(U_DDSPG_U) .. Q:'I .. S C=$P(DDSL0,U,2) .. S:C?1"Select ".E C=$P(C,"Select ",2,999) UP .. S C=$E($$UP^DILIBF(C),1,40) .. S L=$L(DDSREFS)+$L(C)+$L(DDSPGRP(I))+$L(DDSPG)+$L(DDSBK)+$L(DDSF)+30 .. S:L>127 C=$E(C,1,$L(C)-(L-127)) .. S:C]"" @DDSREFS@("CAP",C,DDSPGRP(I),DDSPG,DDSBK,DDSF)="" . ; . ;Set DDSSCR . I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D .. N DDSI,DDSX .. S DDSX=DDSCAP_DDSCLN .. F DDSI=1:1:+DDSREP D CAPS ... S $E(DDSSCR(DDSI-1*DDSHITE+1+DDSC1),DDSC2+1,DDSC2+$L(DDSX))=DDSX ;GFT ... S:$S($P(DDSL4,U)]"":+DDSL4,1:$P(DDSDDL0,U,2)["R")!DDSKEY DDSSCR(DDSI-1*DDSHITE+1+DDSC1,DDSC2+1)=DDSC2+$L(DDSCAP) ; ;Set "D", "L" nodes, DDSNAV, and DDSORD I DDSD1'<0,DDSD2'<0,DDSD3>0 D . S @DDSREFS@(DDSPG,DDSBK,DDSF,"D")=DDSD1_U_DDSD2_U_DDSD3_U_DDSFLD . S @DDSREFS@("F"_$S(DDSFLD[",":0,1:DDP),DDSFLD,"L",DDSPG,DDSBK,DDSF)="" I DDSCAP="!M",DDSC1'<0,DDSC2'<0 S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,5,8)=DDSC1_U_DDSC2_U_DDSCLN_U_($P(DDSDDL0,U,2)["R"!+DDSL4!DDSKEY) S:$P(DDSL4,U,3) $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,10)=1 ; ;Computed fields I $P(DDSL0,U,3)=4 D K DDSCOMP,DDSAR,DDSEXP,DDSFD Q . S DDSCOMP=$G(^DIST(.404,DDSBK,40,DDSF,30)) Q:DDSCOMP?."^" . D PARSE^DDSCOMP(DDP,DDSCOMP,DDSBK,.DDSEXP,.DDSAR,.DDSFD) . Q:DDSEXP=""!$G(DIERR) . S @DDSREFS@("COMPE",DDSBK,DDSF)=DDSEXP . F DDSAR=1:1:DDSAR D .. S:DDSAR(DDSAR)["*DDSREFC*" DDSAR(DDSAR)=$P(DDSAR(DDSAR),"*DDSREFC*")_$E(DDSREFS,1,$L(DDSREFS)-1)_",""COMPE"","_DDSBK_","_DDSF_","_DDSAR_$P(DDSAR(DDSAR),"*DDSREFC*",2,999) .. S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR)=DDSAR(DDSAR) .. I $D(DDSAR(DDSAR))>9 N I F I=1:1 Q:$D(DDSAR(DDSAR,I))[0 D ... S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR,I)=DDSAR(DDSAR,I) . S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,9)=1 . I $G(DDSFD)]"" F DDSAR=1:1:$L(DDSFD,U) D .. N F S F=$P(DDSFD,U,DDSAR) Q:F="" .. S @DDSREFS@("COMP",$P(F,","),$P($P(F,",",2,99),";"),DDSPG,DDSBK,DDSF)="" ; Q:DDSD1<0!(DDSD2<0)!(DDSD3'>0)!(DDSL2?."^") Q:$P(DDSDDL0,U,4)=" ; " Q:DDSTP="h" Q:DDSFLD=.001 I '$P(DDSDDL0,U,2),DDSTP'="e" Q ; S DDSORD(DDSBO,+DDSL0)=DDSF S DDSNAV(DDSD1,DDSD2)=DDSF_","_DDSBK S:$P(DDSDDL0,U,2) DDSMUL(DDSBK,DDSF)="" ; I $G(DDSREP)>1 D . S $P(DDSNAV(DDSD1,DDSD2),",",3)=DDSBO . S DDSRNAV(DDSBO,DDSD1)=DDSBK . S DDSRNAV(DDSBO,DDSD1,DDSD2)=DDSF HITE . S DDSRNAV(DDSBO,DDSD1-.4,DDSD2)=DDSF_",-1" ;DJW/GFT?? . S DDSRNAV(DDSBO,DDSD1+.4,DDSD2)=DDSF_",+1" Q DDSZ2 DDSZ2 ;SFISC/MKO-LOAD SCR, NAV, AND ORDER INFO ;21JAN2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN(SC,N,O,RNAV) ; ;Input: ; DDSPG ; DDSREFS ; D SCR(.SC),NAV(.N,.RNAV),ORD(.O) D:$D(RNAV) RNAV(.RNAV,.O) Q ; SCR(SC) ;Move image from SC to global N C,P,R,S Q:'$D(SC) S R=0 F S R=$O(SC(R)) Q:'R D . F C=1:1 Q:$E(SC(R),C)'=" " . S @DDSREFS@("X",DDSPG,R-1,C-1)=$TR($E(SC(R),C,999),$C(0)," ") . I $D(SC(R))=11 D .. S S="",P=0 .. F S P=$O(SC(R,P)) Q:'P S S=S_(P-C+1)_";"_(SC(R,P)-C+1)_";U"_U .. S:S?.E1"^" S=$E(S,1,$L(S)-1) .. S:S]"" @DDSREFS@("X",DDSPG,R-1,C-1,"A")=S Q ; NAV(N,RNAV) ; N B,D1,D2,F,LN S N(9999,1)="0,0" ; S D1="" F S D1=$O(N(D1)) Q:D1="" D . S D2="" F S D2=$O(N(D1,D2)) Q:D2="" D .. S F=$P(N(D1,D2),","),B=$P(N(D1,D2),",",2),LN="" .. D NAV1(.N,.RNAV,D1,D2,.LN) .. S @DDSREFS@(DDSPG,B,F,"N")=LN .. S:$D(DDSMUL(B,F)) $P(@DDSREFS@(DDSPG,B,F,"N"),U,11)=1 Q ; NAV1(N,RNAV,D1,D2,LN) ;Setup "N" for navigation N E1,E2,I ; S E1=$S($O(N(D1),-1)]"":$O(N(D1),-1),1:$O(N(""),-1)) S E2=D2 I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2))) I E1]"",E2]"" D . N RBO . S RBO=$P(N(E1,E2),",",3) . I RBO,$D(RNAV(RBO,E1))#2 D Q:E2="" .. S E2="" F S E2=$O(RNAV(RBO,E1,E2)) Q:E2="" Q:RNAV(RBO,E1,E2)'["," . S $P(LN,U)=$P(N(E1,E2),",",1,2) ; S E1=$S($O(N(D1))]"":$O(N(D1)),1:$O(N(""))) S E2=D2 I $D(N(E1,E2))[0 S E2=$S($O(N(E1,E2),-1)]"":$O(N(E1,E2),-1),1:$O(N(E1,E2))) I E1]"",E2]"" D . N RBO . S RBO=$P(N(E1,E2),",",3) . I RBO,$D(RNAV(RBO,E1))#2 D Q:E2="" .. S E2="" F S E2=$O(RNAV(RBO,E1,E2)) Q:E2="" Q:RNAV(RBO,E1,E2)'["," . S $P(LN,U,2)=$P(N(E1,E2),",",1,2) ; S E1=D1,E2=$O(N(D1,D2)) I E2="" S E1=$S($O(N(E1))]"":$O(N(E1)),1:$O(N(""))),E2=$O(N(E1,"")) I E1]"",E2]"" S $P(LN,U,3)=$P(N(E1,E2),",",1,2) ; S E1=D1,E2=$S($O(N(E1,D2),-1)]"":$O(N(E1,D2),-1),1:"") I E2="" S E1=$S($O(N(E1),-1)]"":$O(N(E1),-1),1:$O(N(""),-1)),E2=$S($O(N(E1,""),-1)]"":$O(N(E1,""),-1),1:"") I E1]"",E2]"" S $P(LN,U,4)=$P(N(E1,E2),",",1,2) ; F I=1:1:4 S:$P($P(LN,U,I),",",2)=B!'$P($P(LN,U,I),",",2) $P(LN,U,I)=+$P(LN,U,I) Q ; ORD(O) ;Setup field order info N B,BO,BP,F,FO,FP S (BO,FO)="" F S BO=$O(O(BO)) Q:BO="" S FO=$O(O(BO,"")) Q:FO]"" S:FO="" BO=$O(O("")) S B=+$G(O(+BO)),F=+$G(O(+BO,+FO)) S @DDSREFS@(DDSPG,"FIRST")=F_","_B ; S (BP,FP)=0 S BO="" F S BO=$O(O(BO)) Q:BO="" D . S B=+O(BO),F=0 . S FO=$O(O(BO,"")) S:FO]"" F=O(BO,FO) . S $P(@DDSREFS@(DDSPG,B),U,9)=F . S:$P(O(BO),U,2)]"" $P(@DDSREFS@(DDSPG,B),U,10)=$S($P(O(BO),U,2)="FIRST":F,1:$P(O(BO),U,2)) . S FO="" F S FO=$O(O(BO,FO)) Q:FO="" D .. S F=O(BO,FO) .. S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=F_$S(B'=BP:","_B,1:"") .. S FP=F,BP=B S $P(@DDSREFS@(DDSPG,BP,FP,"N"),U,5)=0 Q ; RNAV(DDSRNAV,DDSO) ;Setup nav and fo info for rep blocks N DDSBO,DDSN,B,D1,D2,DN,F,F1,FO,LN,NX,RT S DDSBO="" F S DDSBO=$O(DDSRNAV(DDSBO)) Q:DDSBO="" D . K DDSN M DDSN=DDSRNAV(DDSBO) . S D1="" F S D1=$O(DDSN(D1)) Q:D1="" D:$D(DDSN(D1))#2 .. S B=DDSN(D1) .. N HITE S HITE=$$HITE^DDSR(B) .. S D2="" F S D2=$O(DDSN(D1,D2)) Q:D2="" D ... S F=DDSN(D1,D2),LN="" Q:F["," ... D NAV1(.DDSN,.DDSRNAV,D1,D2,.LN) ... S $P(@DDSREFS@(DDSPG,B,F,"N"),U,6,9)=LN ... Q:HITE<2 ;GFT FIRST ...S FO=$O(DDSO(DDSBO,"")) S:FO FO=DDSO(DDSBO,FO) ...S F1=$O(DDSO(DDSBO,""),-1) S:F1 F1=DDSO(DDSBO,F1) ... I $P(@DDSREFS@(DDSPG,B,F,"N"),U,9)["-" S $P(^("N"),U,9)=$P(^("N"),U,4) I $P(^("N"),U,4)[","!'$P(^("N"),U,4) S $P(^("N"),U,9)=F1_",-1" ;WHERE 'F4' GOES ... I $P(^("N"),U,8)["+" S $P(^("N"),U,8)=$P(^("N"),U,3) I '$P(^("N"),U,3) S $P(^("N"),U,8)=FO_",+1" ;WHERE 'TAB' GOES . S B=+$G(DDSO(+DDSBO)) Q:'B . S FO=$O(DDSO(DDSBO,"")) Q:FO="" . S (F,F1)=DDSO(DDSBO,FO) . F S FO=$O(DDSO(DDSBO,FO)) Q:FO="" D .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=DDSO(DDSBO,FO) .. S F=DDSO(DDSBO,FO) . S $P(@DDSREFS@(DDSPG,B,F,"N"),U,10)=F1_",+1" . ; . S DN=0 . S F=0 F S F=$O(@DDSREFS@(DDSPG,B,F)) Q:DN=2!(F="") D .. S LN=$G(@DDSREFS@(DDSPG,B,F,"N")) Q:LN="" .. S RT=$P(LN,U,3),NX=$P(LN,U,5) .. S:RT[","!'RT DN=DN+1 .. S:NX[","!'NX DN=DN+1 . ; . S F=0 F S F=$O(@DDSREFS@(DDSPG,B,F)) Q:F="" D .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,3)=RT .. S $P(@DDSREFS@(DDSPG,B,F,"N"),U,5)=NX Q DDSZ3 DDSZ3 ;SFISC/MKO-FORM COMPILER ;02:49 PM 30 Dec 1993 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ASUB(DDSPG,DDSFRM) ; ;Set @DDSREFS@("ASUB",pg,bk,ddo)=subpage for parent field N MF,MB,MP S MF=$P(^DIST(.403,+DDSFRM,40,DDSPG,1),U,2) Q:MF="" S MP=$P(MF,",",3),MB=$P(MF,",",2),MF=$P(MF,",") ; S MF=$$GETFLD^DDSLIB(MF,MB,MP,DDSFRM) I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q S @DDSREFS@("ASUB",$P(MF,",",3),$P(MF,",",2),$P(MF,","))=DDSPG Q ; PGRP(FRM,G) ;Find page groups ;In: FRM = Form number ;Out: G = Array of page groups ; N B,I,NP,P,PP,PG S G=0 S P=0 F S P=$O(^DIST(.403,FRM,40,P)) Q:'P D . Q:'$D(^DIST(.403,FRM,40,P,0)) S NP=$P(^(0),U,4),PP=$P(^(0),U,5) . F PG="NP","PP" I @PG D .. S @PG=$O(^DIST(.403,FRM,40,"B",@PG,"")) Q:'@PG .. S:$D(^DIST(.403,FRM,40,@PG,0))[0 @PG="" . S:NP=P NP=0 S:PP=NP!(PP=P) PP=0 . S I=0 F S I=$O(G(I)) Q:'I Q:U_G(I)_U[(U_P_U) . I 'I S G=G+1,G(G)=P_$S(NP:U_NP,1:"")_$S(PP:U_PP,1:"") Q . F PG="NP","PP" I @PG,U_G(I)_U'[(U_@PG_U) S G(I)=G(I)_U_@PG Q DDU DDU ;SFISC/DCM-DD UTILITES ;18JUN2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; 0 S DIC="^DOPT(""DDU""," G OPT:$D(^DOPT("DDU",4)) S ^(0)="DATA DICTIONARY UTILITY OPTION^1.01" K ^("B") F X=1:1:4 S ^DOPT("DDU",X,0)=$P($T(@X),";;",2) S DIK=DIC D IXALL^DIK OPT ; S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0 ; EN ; D @DI W !! Q K %,DIC,DIK,DI,DA,I,J,X,Y Q ; 1 ;;LIST FILE ATTRIBUTES G ^DID ; 2 ;;MAP POINTER RELATIONS G ^DDMAP ; 3 ;;CHECK/FIX DD STRUCTURE G ^DDUCHK ; 4 ;;FIND POINTERS INTO A FILE G ^DIDGFTPT ; DDUCHK DDUCHK ;SFISC/RWF-CHECK DD ;11:25 AM 30 Dec 2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; DDUCFI=home file, DDUCFE=home field, DDUCFIX=flag to fix DD ; DDUCRFI=referenced file, DDUCRFE=referenced field. A W !!,"Check the Data Dictionary." D . W !,"Note: Messages that begin with an asterisk(*) can NOT be corrected and" . W !,"will need careful evaluation by software development!" S DDUC="" D DT^DICRW D L^DICRW1 I X'>0 D G EXIT . I X'="" Q . W !?5,"*The file: "_$P($G(Y),U,2)_"(#"_$P($G(Y),U)_") is missing its ""GL"" (Global Location) node." . W !?6,"No further checking for this file can occur!" S DDUCFIS=+X-.000001,DDUCFIE=DIB(1) S DIR(0)="Y",DIR("A")="Remove erroneous nodes",DIR("B")="NO",DIR("?",1)="This routine will try to fix certain nodes that are erroneous and may set some nodes to a file referenced by the selected file." S DIR("?")="Say 'NO' here to leave the DD untouched. It will only flag the ones it finds erroneous." D ^DIR G EXIT:$D(DIRUT) S DDUCFIX=+Y K DIR ZIS S %ZIS="Q" D ^%ZIS G EXIT:POP I $D(IO("Q")) S ZTRTN="DQ^DDUCHK",ZTSAVE("DDUCFIX")="",ZTSAVE("DDUCFIS")="",ZTSAVE("DDUCFIE")="" D ^%ZTLOAD G EXIT DQ U IO K DDUCSTK,^TMP("DDUCHK",$J) S DDUCSTK=0,DDUCFX=DDUCFIX F DDUCFILE=DDUCFIS:0:DDUCFIE S DDUCFILE=$O(^DIC(DDUCFILE)) Q:DDUCFILE'>0!(DDUCFILE>DDUCFIE) D PAGE Q:$D(DIRUT) D . N DDUERR S DDUERR=0 . W !!,"Checking file ",DDUCFILE . S (DDUCFI,DIFILE)=+DDUCFILE . D DDAC . D CHKHDR . I DDUERR Q . D CHK EXIT ; I $G(DUZ(0))="@",$D(^TMP("DDUCHK",$J)) D . W:$G(IOF)]"" @IOF . W !!,"List of ;;^^ that contain $Next" . N DDFIL S DDFIL=0 N I S I=1 N DDSP S DDSP=" " . F S DDFIL=$O(^TMP("DDUCHK",$J,DDFIL)) Q:'DDFIL D .. N DDFLD S DDFLD=0 .. F S DDFLD=$O(^TMP("DDUCHK",$J,DDFIL,DDFLD)) Q:'DDFLD D ... N DDXRN S DDXRN=0 ... F S DDXRN=$O(^TMP("DDUCHK",$J,DDFIL,DDFLD,DDXRN)) Q:'DDXRN D .... W !,I_$E(DDSP,1,(8-$L(I)))_";;"_DDFIL_U_DDFLD_U_DDXRN .... S I=I+1 . S I=9999 W !,I_$E(DDSP,1,(8-$L(I)))_";;LAST LINE" K ^TMP("DDUCHK",$J) D ^%ZISC K DDUCFI,DDUCFIX,DDUCFILE,DDUCFIS,DDUCFIE,DDUCFE,DDUCX,DDUCX1,DDUCX2,DDUCX4,DDUCRFI K DDUCRFE,DDUCSTK,DDUCSTK,DDUCDNAM,DDUCNAME,DDUCXX,DDUCY,DDUCUP,DDUCXN K DDUCF,DDUCXREF,DDUCZ,DDUC5,DDUCYY,DDUCYY1,DDUCOK,DDUCYYX,DIB,DDUC,DDUCFX,DIAC,DIFILE Q ; PAGE I $Y+3>IOSL S DIR(0)="E" D:IOST["C-" ^DIR W @IOF Q ; DDAC I DUZ(0)'="@" S DIAC="DD" D ^DIAC S DDUCFIX=DDUCFX I 'DIAC,DDUCFX W !,"You don't have DD access to this file. No fixing will be done on this file." S DDUCFIX=0 Q Q CHK I $G(^DIC(DDUCFI,0))]"",'$P(^(0),U,2) S:DDUCFIX $P(^(0),U,2)=DDUCFI I $D(^DD(DDUCFI,0))[0 S DDUCRFI=DDUCFI W !?5,"*File: "_DDUCRFI_", is missing its file header node." I $D(^DD(DDUCFI,0,"ID")) D ID^DDUCHK1 I $D(^DD(DDUCFI,0,"IX")) D IX^DDUCHK1 I $D(^DD(DDUCFI,0,"PT")) D PT^DDUCHK1 D CHKGL^DDUCHK2 D CHKSB^DDUCHK2 S DDUCNAME=$O(^DD(DDUCFI,0,"NM","")),DDUCDNAM=$O(^(DDUCNAME)),DDUCRFI=DDUCFI I DDUCDNAM]"" D WFI W "has duplicate 'NM' nodes." I DDUCFIX D NM^DDUCHK1 I $D(^DD("ACOMP",DDUCFI)) D AC^DDUCHK1 D INDEX^DDUCHK4(DDUCFI,DDUCFIX),KEY^DDUCHK5(DDUCFI,DDUCFIX) G ^DDUCHK2 WFI W !?8,"File: ",DDUCRFI," " Q ; EN ; Q:'$D(DDUCFI)!'$D(DDUCFIX) S U="^" I DDUCFI Q:'$D(^DIC(DDUCFI,0,"GL")) G EN1 Q:'$D(@(DDUCFI_"0)")) S DDUCFI=+$P(^(0),U,2) EN1 S DDUCFIS=+DDUCFI-.000001,DDUCFIE=+DDUCFI G ZIS ; CHKHDR ; Check for Missing or Incorrect File Header Node ;22*130 ;W !?5,"File: ",DDUCFI," Checking File Header Node." N DDUCGL,DDUCNA,DDUCHDR S DDUCGL=$G(^DIC(DDUCFI,0,"GL")) I DDUCGL="" W !?5,"*File: "_DDUCFI_", is missing file's ""GL"" (Global Location) node.",!?6,"No further checking can occur!" S DDUERR=1 Q S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR) S DDUCNA=$P(^DIC(DDUCFI,0),U) I DDUCHDR="" W !?5,"*File: "_DDUCFI_", is missing the File header node." Q I $P(DDUCHDR,U)'=DDUCNA W !?5,"*File: "_DDUCFI_", header name is incorrect." Q I +$P(DDUCHDR,U,2)'=DDUCFI W !?5,"*File: "_DDUCFI_" File header number is incorrect." Q Q DDUCHK1 DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;3JUNE2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ID S DDUCRFE="" F DDUCZ=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"ID",DDUCRFE)) Q:DDUCRFE="" S DDUCX=$S($D(^DD(DDUCFI,0,"ID",DDUCRFE))#2:^(DDUCRFE),1:"") I DDUCX="Q" W !?5,"'ID' node for field ",DDUCRFE," = 'Q'" D:DDUCFIX ID1 Q ID1 K ^DD(DDUCFI,0,"ID",DDUCRFE) D M1 W """ID"",",DDUCRFE D M2 Q IX S DDUCXREF="" F DDUCZ=0:0 S DDUCXREF=$O(^DD(DDUCFI,0,"IX",DDUCXREF)) Q:DDUCXREF="" F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI)) Q:DDUCRFI'>0 D IX1 Q IX1 D IXDUP ;22*130 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D . I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """IX"" Subscript: "_DDUCXREF_" " D WFE,WMS D:DDUCFIX IX2 Q . I $D(^DD(DDUCRFI,DDUCRFE,1,0))=0,$D(^DD(DDUCRFI,DDUCRFE,1))=10 S:DDUCFIX ^DD(DDUCRFI,DDUCRFE,1,0)="^.1" . S DDUCRFE1=0,DDUCRFEX="" F S DDUCRFE1=$O(^DD(DDUCRFI,DDUCRFE,1,DDUCRFE1)) Q:DDUCRFE1'>0 S DDUCRFEX=$G(^(DDUCRFE1,0)) I $P(DDUCRFEX,U,2)=DDUCXREF K DDUCRFEX Q . I $D(DDUCRFEX) W !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref" D:DDUCFIX IX2 Q K DDUCRFE1 Q IX2 K ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE) D M1 W """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE D M2 Q PT F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"PT",DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D PT1 Q PT1 I $D(^DD(DDUCRFI,0))[0 D WFI,WMS I DDUCFIX K ^DD(DDUCFI,0,"PT",DDUCRFI) D M1 W """PT"",",DDUCRFI D M2 Q I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """PT"" Subscript " D WFE,WMS D:DDUCFIX PTM Q I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D WFI,WFE W "is not a pointer." D:DDUCFIX PTM Q I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DDUCFI D WFI,WFE W "is not a pointer to file ",DDUCFI D:DDUCFIX PTM Q PTM K ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE) D M1 W """PT"",",DDUCRFI,",",DDUCRFE D M2 Q AC F DDUCFE=0:0 S DDUCFE=$O(^DD("ACOMP",DDUCFI,DDUCFE)) Q:DDUCFE'>0 D AC1 Q AC1 F DDUCRFI=0:0 S DDUCRFI=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D AC2 Q AC2 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D:DDUCFIX ACM Q S DDUCX=^(0) I $P(DDUCX,U,2)'["C" D:DDUCFIX ACM Q I $P(DDUCX,U,2)["C" S DDUCX1=$S($D(^(9.01)):^(9.01),1:""),DDUCF=0 D AC3 Q AC3 F DDUCZ=1:1 S DDUCX2=$P(DDUCX1,";",DDUCZ) Q:DDUCX2="" I DDUCX2=DDUCFI_U_DDUCFE S DDUCF=1 Q I 'DDUCF D:DDUCFIX ACM Q ACM K ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE) Q NM S DDUCRFI(1)=$S($D(^DIC(DDUCFI,0))#2:$P(^(0),U),1:$P(^DD(DDUCFI,0)," SUB-FIELD")) Q:DDUCRFI(1)']"" K ^DD(DDUCFI,0,"NM") S ^DD(DDUCFI,0,"NM",DDUCRFI(1))="" W !?10,"Duplicate ""NM"" node was deleted." Q WHO W !?5,"Field: ",DDUCFE," (",$P(DDUCX,U),") " Q WFI W !?5,"File: ",DDUCRFI," " Q WFE W ?5,"Field: ",DDUCRFE," " Q WMS W "is missing." Q M1 W !?10,"^DD(",DDUCFI,",0," Q M2 W ") was killed." Q Q ; IXDUP ;Check for duplicate fields for same xref ;22*130 N DDUCRFE,DDUCRFEP S (DDUCRFE,DDUCRFEP)=0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCRFI,DDUCRFE)) ;HUH?? D . F S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:'DDUCRFE D .. I 'DDUCRFEP S DDUCRFEP=DDUCRFE Q .. I DDUCRFE'=DDUCRFEP D MN ...N I F I=0:0 S I=$O(^DD(DDUCRFI,DDUCRFE,1,I)) Q:'I I +$G(^(I,0))=DDUCFI,$P(^(0),U,2)=DDUCXREF,$P(^(0),U,3)="MNEMONIC" K I Q ...Q:'$D(I) ... W !?5,"*File: ",DDUCRFI," Index: """_DDUCXREF_""" has duplicate Fields." ... W !?21,"Field: ",DDUCRFEP," Field: ",DDUCRFE .. S DDUCRFEP=DDUCRFE .. Q . S DDUCRFEP=0 . Q DDUCHK2 DDUCHK2 ;SFISC/RWF/SO-CHECK DD (FIELDS) ;11:46 AM 5 Mar 2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CHK6 ;W !?5,"Checking FIELDs" F DDUCFE=0:0 S DDUCFE=+$O(^DD(DDUCFI,DDUCFE)) Q:DDUCFE'>0 D FIELD Q:$D(DIRUT) D FIVE,DXREF^DDUCHK3,XREF^DDUCHK3,COMP^DDUCHK3 ;D CHKSB,CHKGL Q FIELD ;W "." I $D(^DD(DDUCFI,DDUCFE,0))[0 W !?5,"*Field: ",DDUCFE," is missing its zero node." Q ;22*100,22*130 S DDUCX=^DD(DDUCFI,DDUCFE,0),DDUCX2=$P(DDUCX,U,2),DDUCX4=$P(DDUCX,U,4),DDUCXN=$P(DDUCX,U) I $P(DDUCX,U,5,999)["$N(",$P(DDUCX,U,5,999)'["$$N(" W !?5,"*Field: ",DDUCFE,"'s Input Transform contains $Next." ;I DDUCX2["F",DDUCX4[";E1",$S($D(^DD(DDUCFI,DDUCFE,9)):^(9),1:"")'="@" D WHO W "doesn't have the correct protection for a field with executable code." I DDUCFIX S ^DD(DDUCFI,DDUCFE,9)="@" W !?10,"^DD(",DDUCFI,",",DDUCFE,",9) = ""@"" was set." D @$S(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q") Q Q FIVE K DDUCXX F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,5,DDUCY)) Q:DDUCY'>0 S DDUCX=^(DDUCY,0) I $D(^DD(+DDUCX,+$P(DDUCX,U,2),1,+$P(DDUCX,U,3),0))#2 S DDUCXX(DDUCX)="" Q:'DDUCFIX K ^DD(DDUCFI,DDUCFE,5) S DDUCX="" F DDUCY=1:1 S DDUCX=$O(DDUCXX(DDUCX)) Q:DDUCX="" S ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX Q VP F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,"V",DDUCY)) Q:DDUCY'>0 S DDUCRFI=$S($D(^DD(DDUCFI,DDUCFE,"V",DDUCY,0)):^(0),1:"") I DDUCRFI D PT1 Q PT N DDUERR S DDUCRFI=+$P(DDUCX2,"P",2),DDUERR=0 D Q:DDUERR . I $D(^DD(DDUCRFI,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to missing file: ",DDUCRFI S DDUERR=1 Q . N DDUCGL,DDUCNA,DDUCHDR . S DDUCGL=$G(^DIC(DDUCRFI,0,"GL")) . I DDUCGL="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", is missing file's ""GL"" (Global Location) node." S DDUERR=1 Q . S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR) . I DDUCHDR="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", missing File header node." S DDUERR=1 . Q PT1 I $D(^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE))[0 D WHO W "is missing its 'PT' node in the pointed-to-file." I DDUCFIX S ^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE)="" W !?10,"^DD(",+DDUCRFI,",0,""PT"",",DDUCFI,",",DDUCFE,") = """" was set." Q Q ;QUIT TAG MULT ;Work subfile D PAGE^DDUCHK Q:$D(DIRUT) I $D(^DD(+DDUCX2,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") missing subfile: ",+DDUCX2 Q S DDUCUP=$S($D(^DD(+DDUCX2,0,"UP")):^("UP"),1:"") I DDUCUP'=DDUCFI D WHO W "Bad 'UP' pointer in subfile #",+DDUCX2 I DDUCFIX S ^DD(+DDUCX2,0,"UP")=DDUCFI W !?10,"^DD(",+DDUCX2,",0,""UP"") = ",DDUCFI," was set." D PUSH S DDUCFI=+DDUCX2 W !?3,"Checking subfile ",DDUCFI D CHK^DDUCHK,POP W !?3,"Returning to ",$S('DDUCSTK:"main ",1:"sub"),"file",$S('DDUCSTK:" "_DDUCFILE_".",1:" "_DDUCFI) Q PUSH S DDUCSTK=DDUCSTK+1,DDUCSTK(DDUCSTK,1)=DDUCFI,DDUCSTK(DDUCSTK,2)=DDUCFE Q POP S DDUCFI=DDUCSTK(DDUCSTK,1),DDUCFE=DDUCSTK(DDUCSTK,2),DDUCSTK=DDUCSTK-1 Q WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q ; CHKSB ;Check for duplicate "SB" x-refs ;22*130 N DDUCSB S DDUCSB=0 F S DDUCSB=+$O(^DD(DDUCFI,"SB",DDUCSB)) Q:'DDUCSB D . N DDUCFE,DDUCSAV,DDUNFE . S DDUCFE=0 . F S DDUCFE=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) Q:'DDUCFE D CHKSBA I '$D(DDUNFE),$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) D .. N DDUCFE1,DDUCX .. ;Is the TYPE "WP"? .. S DDUCX=$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) I $D(^DD(DDUCFI,DDUCX,0)),$P(^DD(DDUCFI,DDUCX,0),U,4)["WP" Q .. S DDUCSAV(DDUCFE)="" .. S DDUCFE1=DDUCFE .. F S DDUCFE1=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE1)) Q:'DDUCFE1 S DDUCSAV(DDUCFE1)="" . N X1,X2 . S X1=0 . F S X1=$O(DDUCSAV(X1)) Q:'X1 D .. I '$D(X2) W !?5,"*Duplicate Fields represent Sub-file: "_DDUCSB,!?7 S X2=1 .. W "field: "_X1_"; " Q ; CHKSBA ;Check if Feidl exists I '$D(^DD(DDUCFI,DDUCFE,0))#2 W !?7,"*Field: "_DDUCFE_", File: "_DDUCFI_", ""SB"" subscript for subfile: "_DDUCSB_" is missing." S DDUNFE=1 Q Q ; CHKGL ;Check for duplicate "GL" nodes ;22*130 N DDUCN S DDUCN="" F S DDUCN=$O(^DD(DDUCFI,"GL",DDUCN)) Q:DDUCN="" D . N DDUCP . S DDUCP=0 . F S DDUCP=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP)) Q:'DDUCP D .. N DDUCFE2,DDUCSAV .. S DDUCFE2=0 .. F S DDUCFE2=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'DDUCFE2 I $O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) D ... S DDUCSAV(DDUCN_";"_DDUCP,DDUCFE2)="" ... N X ... S X=0 ... S X=$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'X S DDUCSAV(DDUCN_";"_DDUCP,X)="" .. N X1,X2 .. S X1="" ;Global Location .. F S X1=$O(DDUCSAV(X1)) Q:X1="" D ... I '$D(X2) W !?5,"*Duplication at global location subscript: "_$P(X1,";")_", piece: "_$P(X1,";",2),!?9 S X2=1 ... N X3 ... S X3=0 ;Field # ... F S X3=$O(DDUCSAV(X1,X3)) Q:'X3 W "field: "_X3_"; " Q DDUCHK3 DDUCHK3 ;SFISC/RWF-CHECK DD (XREF,COMPUTED) ;12:40 PM 4 Mar 2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. XREF F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,1,DDUCY)) Q:DDUCY'>0 S DDUCX=^(DDUCY,0),DDUCRFI=+DDUCX,DDUCX1=$P(DDUCX,U,2) D XREF1 Q XREF1 ; I DDUCRFI,$D(^DD(DDUCRFI,0)),$D(^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE))[0 D WHO,WFI W "missing 'IX' node." D:DDUCFIX XREFM Q I DDUCX["TRIGGER" S DDUCRFI=+$P(DDUCX,U,4),DDUCRFE=+$P(DDUCX,U,5),DDUC5=DDUCFI_U_DDUCFE_U_DDUCY D TRIG Q XREFM S ^DD(DDUCRFI,0,"IX",DDUCX1,DDUCFI,DDUCFE)="" W !?10,"^DD(",DDUCRFI,",0,""IX"",""",DDUCX1,""",",DDUCFI,",",DDUCFE,") = """" was set." Q TRIG I $D(^DD(DDUCRFI,0))[0 W !?5,"Field: ",DDUCFE," (",DDUCXN,") triggers missing file ",DDUCRFI Q I $D(^DD(DDUCRFI,DDUCRFE,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") triggers missing field ",DDUCRFE," in file ",DDUCRFI Q I '$D(^DD(DDUCRFI,DDUCRFE,5)) D WHO,WFI,WFE W " 5 node is missing." I DDUCFIX S ^DD(DDUCRFI,DDUCRFE,5,1,0)=DDUC5 W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,1,0) = ",DDUC5," was set." Q Q:'DDUCFIX S (DDUCYY1,DDUCOK)=0 F DDUCYY=0:0 S DDUCYY=$O(^DD(DDUCRFI,DDUCRFE,5,DDUCYY)) Q:DDUCYY'>0 S DDUCYY1=DDUCYY,DDUCYYX=^(DDUCYY,0) I DDUCYYX=DDUC5 S DDUCOK=1 Q I 'DDUCOK D WHO,WFI,WFE W " 5 node is missing." D:DDUCFIX TRIGM Q Q TRIGM S ^DD(DDUCRFI,DDUCRFE,5,(DDUCYY1+1),0)=DDUC5 I DDUCRFI'=DDUCFE W !?10,"^DD(",DDUCRFI,",",DDUCRFE,",5,",DDUCYY1+1,",0) = ",DDUC5," was set." Q COMP Q:DDUCX2'["C" S DDUCX=$S($D(^DD(DDUCFI,DDUCFE,9.01)):^(9.01),1:"") F DDUCX1=1:1 Q:$P(DDUCX,";",DDUCX1)="" S DDUCRFI=+$P(DDUCX,";",DDUCX1),DDUCRFE=+$P($P(DDUCX,";",DDUCX1),U,2) I $D(^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE))[0 S:DDUCFIX ^DD("ACOMP",DDUCRFI,DDUCRFE,DDUCFI,DDUCFE)="" Q WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q WFI W !?8,"File: ",DDUCRFI," " Q WFE W ?8,"Field: ",DDUCRFE," " Q ; DXREF ; Check for $Next usage; 22*130 ; DDUCFI = File # ; DDUCFE = Field # ; XRN = Cross Reference # N XRN S XRN=0 F S XRN=$O(^DD(DDUCFI,DDUCFE,1,XRN)) Q:'XRN D . ; XRN1 = Cross Reference Node Data . N XRN1 S XRN1="" . ; XRNW = 0 Have Not written warning, 1 have written warning . N XRNW S XRNW=0 . F S XRN1=$O(^DD(DDUCFI,DDUCFE,1,XRN,XRN1)) Q:XRN1="" D .. N GMSG S GMSG=0 ;1 equals use general message .. I XRN1="%D" Q .. I XRN1="DT" Q .. ; Check for $Next any cross reference code .. I ^DD(DDUCFI,DDUCFE,1,XRN,XRN1)["$N(",^DD(DDUCFI,DDUCFE,1,XRN,XRN1)'["$$N(" D I GMSG W !?5,"*Field: ",DDUCFE,", Cross Reference #: ",XRN,", Sub-Script: ",XRN1,", contains $Next." ... I $P(^DD(DDUCFI,DDUCFE,1,XRN,0),U,3)'="TRIGGER" S GMSG=1 Q ... ; Display/Fix known old FileMan TRIGGER Code: ... ; "D ^DICR:$N(^DD(DIH,DIG,1,0))>0" ... N DICRVAL ... S DICRVAL=$G(^DD(DDUCFI,DDUCFE,1,XRN,XRN1)) ... I DICRVAL'["D ^DICR:$N(^DD(DIH,DIG,1,0))>0" S GMSG=1 Q ... I 'XRNW D .... W !?5,"*File: "_DDUCFI_", Field: "_DDUCFE_", XREF: "_XRN_" contains $Next in TRIGGER code." .... S ^TMP("DDUCHK",$J,DDUCFI,DDUCFE,XRN)="" .... S XRNW=1 Q DDUCHK4 DDUCHK4 ;SFISC/MKO-CHECK INDEXES ON FILE ;6:36 AM 28 Dec 2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; INDEX(DDUCFI,DDUCFIX) ;Check and optionally fix structure of Index file entry N DDUCIX Q:'$G(DDUCFI) S DDUCFIX=$G(DDUCFIX) ; ;Loop through "B" index to find INDEXes that reside on this file D WCHK S DDUCIX="" F S DDUCIX=$O(^DD("IX","B",DDUCFI,DDUCIX)) Q:DDUCIX="" D CHKIX ; ;Check "AC","BB", and "F" indexes D CHKAC,CHKBB,CHKF Q ; CHKIX ;Check Index DDUCIX found in "B" index ;In: ; DDUCIX = index # ; DDUCFI = file # ; DDUCFIX = flag to fix N DDUCIX0,DDUCIXID,DDUCNM,DDUCRF,DDUCRV S DDUCIXID=$$IXID(DDUCIX,"") ; ;Check that Index exists I '$D(^DD("IX",DDUCIX)) D Q . D WNOIX . D:DDUCFIX KILL($NA(^DD("IX","B",DDUCFI,DDUCIX))) ; ;Check that index has a FILE S DDUCIX0=$G(^DD("IX",DDUCIX,0)) I $P(DDUCIX0,U)="" D . D WMS("FILE (#.01) for "_DDUCIXID) . D:DDUCFIX FFILE ; ;Get Name S DDUCNM=$P(DDUCIX0,U,2) I DDUCNM]"" S DDUCIXID=$$IXID(DDUCIX,DDUCNM) E D WMS("NAME for "_DDUCIXID) ; ;Check Root File not null, and "AC" index exists S DDUCRF=$P(DDUCIX0,U,9) I 'DDUCRF D . D WMS("ROOT FILE for "_DDUCIXID) . D:DDUCFIX FRF ; ;Check Cross-Reference Values multiple S DDUCRV=0 F S DDUCRV=$O(^DD("IX",DDUCIX,11.1,DDUCRV)) Q:'DDUCRV D CRV ; ;Reindex Index file entry I DDUCFIX D . N DIC,DIK,DA,X . S DIK="^DD(""IX"",",DA=DDUCIX . D IX^DIK Q ; CRV ;Check a Cross-Reference Value ;In: ; DDUCIX = Index # ; DDUCRV = CRV # ; DDUCFIX = Flag to fix ; DDUCRF = Root file # ; DDUCIXID = String that identifies Index N DDUCFIL,DDUCFLD,DDUCGL,DDUCOID,DDUCORD,DDUCRV0 ; S DDUCRV0=$G(^DD("IX",DDUCIX,11.1,DDUCRV,0)) Q:$P(DDUCRV0,U,2)="C" S DDUCORD=$P(DDUCRV0,U),DDUCFIL=$P(DDUCRV0,U,3),DDUCFLD=$P(DDUCRV0,U,4) ; ;Check .01 of CRV I DDUCORD="" D . D WMS("ORDER NUMBER of Cross-Reference Value #"_DDUCRV_" of "_DDUCIXID) . D:DDUCFIX FON S DDUCOID=$$OID(DDUCORD,"","",DDUCIXID) ; ;Make sure FILE is not null I 'DDUCFIL D . D WMS("FILE for "_DDUCOID,1) ; ;If there's a File, make sure it is equal to Root File ;and that referenced field exists. E D . D:DDUCFIL'=DDUCRF WNE . D:$D(^DD(DDUCFIL,DDUCFLD,0))[0 WFMS . I $D(^DD("IX","F",DDUCFIL,DDUCFLD,DDUCIX,DDUCRV))[0 S DDUCGL=$NA(^(DDUCRV)) D .. D WMS(DDUCGL) .. D:DDUCFIX SET(DDUCGL) Q ; CHKAC ;Check "AC index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCIX S DDUCIX=0 F S DDUCIX=$O(^DD("IX","AC",DDUCFI,DDUCIX)) Q:'DDUCIX D . I $P($G(^DD("IX",DDUCIX,0)),U,9)]"",$P(^(0),U,9)'=DDUCFI D .. S DDUCGL=$NA(^DD("IX","AC",DDUCFI,DDUCIX)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKBB ;Check "BB" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCIX,DDUCIX0,DDUCIXID,DDUCNM,DDUCNML S DDUCNM="" F S DDUCNM=$O(^DD("IX","BB",DDUCFI,DDUCNM)) Q:DDUCNM="" D . S DDUCIX=0 . F DDUCIX=$O(^DD("IX","BB",DDUCFI,DDUCNM,DDUCIX)) Q:'DDUCIX D .. S DDUCIX0=$G(^DD("IX",DDUCIX,0)) .. I $D(^DD("IX",DDUCIX)),$P(DDUCIX0,U,2)="" S DDUCNML(DDUCIX,DDUCNM)="" .. E I $P(DDUCIX0,U)'=DDUCFI!($P(DDUCIX0,U,2)'=DDUCNM) D ... S DDUCGL=$NA(^DD("IX","BB",DDUCFI,DDUCNM,DDUCIX)) ... D WEN(DDUCGL) ... D:DDUCFIX KILL(DDUCGL) ; ;If any of the Indexes have null Names, check whether a single name ;for it was found in the "BB" index. I $D(DDUCNML) S DDUCIX=0 F S DDUCIX=$O(DDUCNML(DDUCIX)) Q:'DDUCIX D . S DDUCNM=$O(DDUCNML(DDUCIX,"")) . I $O(DDUCNML(DDUCIX,DDUCNM))="" D .. S DDUCIXID=$$IXID(DDUCIX,"") .. D WNM .. D:DDUCFIX FNM . E F D S DDUCNM=$O(DDUCNML(DDUCIX,DDUCNM)) Q:DDUCNM="" .. S DDUCGL=$NA(^DD("IX","BB",DDUCFI,DDUCNM,DDUCIX)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKF ;Check "F" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCFLD,DDUCGL,DDUCIX,DDUCRV S DDUCFLD=0 F S DDUCFLD=$O(^DD("IX","F",DDUCFI,DDUCFLD)) Q:'DDUCFLD D . S DDUCIX=0 . F S DDUCIX=$O(^DD("IX","F",DDUCFI,DDUCFLD,DDUCIX)) Q:'DDUCIX D .. S DDUCRV=0 .. F S DDUCRV=$O(^DD("IX","F",DDUCFI,DDUCFLD,DDUCIX,DDUCRV)) Q:'DDUCRV D ... I $P($G(^DD("IX",DDUCIX,11.1,DDUCRV,0)),U,3)'=DDUCFI!($P($G(^(0)),U,4)'=DDUCFLD) D .... S DDUCGL=$NA(^DD("IX","F",DDUCFI,DDUCFLD,DDUCIX,DDUCRV)) .... D WEN(DDUCGL) .... D:DDUCFIX KILL(DDUCGL) Q ; ;--------------- FFILE ;Set the .01 of index to DDUCFI S $P(^DD("IX",DDUCIX,0),U)=DDUCFI D WRITE("FILE (#.01) for "_DDUCIXID_" set to "_DDUCFI_".",10) Q ; FRF ;Set Root File equal to File and Root Type to 'INDEX FILE' S $P(^DD("IX",DDUCIX,0),U,8)="I" S $P(^DD("IX",DDUCIX,0),U,9)=DDUCFI S DDUCRF=DDUCFI D WRITE("ROOT FILE for "_DDUCIXID_" set to "_DDUCFI_".",10) D WRITE("ROOT TYPE for "_DDUCIXID_" set to 'INDEX FILE'.",10) Q ; FON ;Determine Order Number N DDUCI,DDUCO ; ;Look for Order Number in "B" index S DDUCORD=0 F S DDUCORD=$O(^DD("IX",DDUCIX,11.1,"B",DDUCORD)) Q:'DDUCORD Q:$O(^DD("IX",DDUCIX,11.1,"B",DDUCORD,0))=DDUCRV ; ;If not found, just pick an unused Order Number I 'DDUCORD D . S DDUCI=0 . F S DDUCI=$O(^DD("IX",DDUCIX,11.1,DDUCI)) Q:'DDUCI S:$P($G(^(DDUCI,0)),U)]"" DDUCO($P(^(0),U))="" . S DDUCORD=$O(DDUCO(""),-1) . S:'DDUCORD DDUCORD=1 ; S $P(^DD("IX",DDUCIX,11.1,DDUCRV,0),U)=DDUCORD D WRITE("ORDER NUMBER for Cross-Reference Value #"_DDUCRV_" of "_DDUCIXID_" set to "_DDUCORD_".",10) Q ; FNM ;Set the NAME for the Index S $P(^DD("IX",DDUCIX,0),U,2)=DDUCNM D WRITE("NAME for "_DDUCIXID_" set to '"_DDUCNM_"'.",10) Q ; KILL(GL) ;Kill a global and print a message Q:'$D(@GL) K @GL W !?10,GL_" was killed." Q ; SET(GL,VAL) ;Set a global and print a message Q:$D(@GL) S VAL=$G(VAL),@GL=VAL W !?10,GL_" was set"_$S(VAL]"":" to "_VAL,1:"")_"." Q ; ;Write messages WCHK Q ;D WRITE("Checking Indexes.",5) Q WNOIX D WRITE(DDUCIXID_" does not exist.",7) Q WMS(S,N) D WRITE("*"_S_" is missing."_$S($G(N):" ",1:""),7) Q WNE D WRITE("*FILE does not equal ROOT FILE in "_DDUCOID_".",7) Q ;22*130 WFMS D WRITE("*File/Sub-file #"_$S($G(FIL)'="":FIL,1:DDUCFIL)_", Field #"_$S($G(FLD)'="":FLD,1:DDUCFLD)_" referenced in "_DDUCOID_" is missing.",7) Q ;22*130 WEN(GL) D WRITE("Erroneous node "_GL_" is set.",7) Q WNM D WRITE("NAME for "_DDUCIXID_" looks like it should be '"_DDUCNM_"'.",7) Q ; WRITE(TXT,TAB) ;Write text, wrap at word boundaries. N I D WRAP^DIKCU2(.TXT,-TAB-2,-TAB) W !?TAB,$G(TXT,$G(TXT(0))) F I=1:1 Q:'$D(TXT(I)) W !?TAB+2,TXT(I) Q ; IXID(IX,NM) ;Return string that identifies an Index S:'$D(NM) NM=$P($G(^DD("IX",IX,0)),U,2) Q $S(NM]"":"'"_NM_"' Index (#"_IX_")",1:"Index #"_IX) ; OID(ORD,IX,NM,IXID) ;Return string that identifies Cross-Reference Value I '$D(IXID),$G(IX) S IXID=$S($D(NM)#2:$$IXID(IX,NM),1:$$IXID(IX)) Q "Order #"_ORD_" of "_$S($G(IXID)]"":IXID,1:"") DDUCHK5 DDUCHK5 ;SFISC/MKO-CHECK KEYS ON FILE ;8/8/03 06:26 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; KEY(DDUCFI,DDUCFIX) ;Check and optionally fix structure of Key file entry N DDUCKEY Q:'$G(DDUCFI) S DDUCFIX=$G(DDUCFIX) ; ;Loop through "B" index to find KEYs that reside on this file D WCHK S DDUCKEY="" F S DDUCKEY=$O(^DD("KEY","B",DDUCFI,DDUCKEY)) Q:DDUCKEY="" D CHKKEY ; ;Check "AP","BB", and "F" indexes D CHKAP,CHKBB,CHKF Q ; CHKKEY ;Check Key DDUCKEY found in "B" index ;In: ; DDUCKEY = Key # ; DDUCFI = File # ; DDUCFIX = Flag to fix N DDUCIEN,DDUCKEY0,DDUCKID,DDUCNM,DDUCUI S DDUCKID=$$KEYID(DDUCKEY,"") ; ;Check that Key exists I '$D(^DD("KEY",DDUCKEY)) D Q . D WNOKEY . D:DDUCFIX KILL($NA(^DD("KEY","B",DDUCFI,DDUCKEY))) ; ;Check that Key has a FILE S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0)) I $P(DDUCKEY0,U)="" D . D WMS("FILE (#.01) for "_DDUCKID) . D:DDUCFIX FFILE ; ;Get Name S DDUCNM=$P(DDUCKEY0,U,2) I DDUCNM]"" S DDUCKID=$$KEYID(DDUCKEY,DDUCNM) E D WMS("NAME for "_DDUCKID) ; ;Check Priority S DDUCPRI=$P(DDUCKEY0,U,3) D:DDUCPRI="" WMS("PRIORITY for "_DDUCKID) ; ;Check Uniqueness Index S DDUCUI=$P(DDUCKEY0,U,4) I 'DDUCUI D . D WMS("Uniqueness Index for "_DDUCKID,1) E D . I '$D(^DD("IX",DDUCUI,0)) D Q .. D WMS("Dangling pointer. Uniqueness Index #"_DDUCUI_" pointed to by "_DDUCKID,1) . D GETFLD^DIKKUTL2(DDUCKEY,DDUCUI,.DDUCKFLD,.DDUCUFLD) . D:'$$GCMP^DIKCU2("DDUCKFLD","DDUCUFLD") WNE ; ;Check Field multiple S DDUCIEN=0 F S DDUCIEN=$O(^DD("KEY",DDUCKEY,2,DDUCIEN)) Q:'DDUCIEN D FLD ; ;Reindex Key file entry I DDUCFIX D . N DIC,DIK,DA,X . S DIK="^DD(""KEY"",",DA=DDUCKEY . D IX^DIK Q ; FLD ;Check a Cross-Reference Value ;In: ; DDUCKEY = Key # ; DDUCIEN = IEN in FIELD multiple ; DDUCFIX = Flag to fix ; DDUCKID = String that identifies Key ; DDUCUI = Uniqueness index # N DDUCFIL,DDUCFLD,DDUCFLD0,DDUCKFLD,DDUCSEQ,DDUCUFLD ; S DDUCFLD0=$G(^DD("KEY",DDUCKEY,2,DDUCIEN,0)) S DDUCFLD=$P(DDUCFLD0,U),DDUCFIL=$P(DDUCFLD0,U,2) S DDUCSEQ=$P(DDUCFLD0,U,3) ; ;Check that field, file, and sequence are filled in D:'DDUCFLD!'DDUCFIL!'DDUCSEQ WINC ; ;Make sure file/field exists and is in the "F" index I DDUCFLD,DDUCFIL D . D:$D(^DD(DDUCFIL,DDUCFLD,0))[0 WFMS . I $D(^DD("KEY","F",DDUCFIL,DDUCFLD,DDUCKEY,DDUCIEN))[0 S DDUCGL=$NA(^(DDUCIEN)) D .. D WMS(DDUCGL) .. D:DDUCFIX SET(DDUCGL) Q ; CHKAP ;Check "AP" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCKEY,DDUCKEY0,DDUCPRI,DDUCPRIL ; S DDUCPRI="" F S DDUCPRI=$O(^DD("KEY","AP",DDUCFI,DDUCPRI)) Q:DDUCPRI="" D . S DDUCKEY=0 . F S DDUCKEY=$O(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY)) Q:'DDUCKEY D .. S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0)) .. I $D(^DD("KEY",DDUCKEY)),$P(DDUCKEY0,U,3)="" S DDUCPRIL(DDUCKEY,DDUCPRI)="" .. E I $P(DDUCKEY0,U)'=DDUCFI!($P(DDUCKEY0,U,3)'=DDUCPRI) D ... S DDUCGL=$NA(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY)) ... D WEN(DDUCGL) ... D:DDUCFIX KILL(DDUCGL) ; ;If any of the Keys have null Priorities, check whether a single ;priority for it was found in the "AP" index. I $D(DDUCPRIL) S DDUCKEY=0 F S DDUCKEY=$O(DDUCPRIL(DDUCKEY)) Q:'DDUCKEY D . S DDUCPRI=$O(DDUCPRIL(DDUCKEY,"")) . I $O(DDUCPRIL(DDUCKEY,DDUCPRI))="" D .. S DDUCKID=$$KEYID(DDUCKEY) .. D WPRI .. D:DDUCFIX FPRI . E F D S DDUCPRI=$O(DDUCPRIL(DDUCKEY,DDUCPRI)) Q:DDUCPRI="" .. S DDUCGL=$NA(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKBB ;Check "BB" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCGL,DDUCKEY,DDUCKEY0,DDUCKID,DDUCNM,DDUCNML S DDUCNM="" F S DDUCNM=$O(^DD("KEY","BB",DDUCFI,DDUCNM)) Q:DDUCNM="" D . S DDUCKEY=0 . F DDUCKEY=$O(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY)) Q:'DDUCKEY D .. S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0)) .. I $D(^DD("KEY",DDUCKEY)),$P(DDUCKEY0,U,2)="" S DDUCNML(DDUCKEY,DDUCNM)="" .. E I $P(DDUCKEY0,U)'=DDUCFI!($P(DDUCKEY0,U,2)'=DDUCNM) D ... S DDUCGL=$NA(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY)) ... D WEN(DDUCGL) ... D:DDUCFIX KILL(DDUCGL) ; ;If any of the Keys have null Names, check whether a single name ;for it was found in the "BB" index. I $D(DDUCNML) S DDUCKEY=0 F S DDUCKEY=$O(DDUCNML(DDUCKEY)) Q:'DDUCKEY D . S DDUCNM=$O(DDUCNML(DDUCKEY,"")) . I $O(DDUCNML(DDUCKEY,DDUCNM))="" D .. S DDUCKID=$$KEYID(DDUCKEY,"") .. D WNM .. D:DDUCFIX FNM . E F D S DDUCNM=$O(DDUCNML(DDUCKEY,DDUCNM)) Q:DDUCNM="" .. S DDUCGL=$NA(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY)) .. D WEN(DDUCGL) .. D:DDUCFIX KILL(DDUCGL) Q ; CHKF ;Check "F" index (In: DDUCFI = file; DDUCFIX = flag to fix) N DDUCFLD,DDUCGL,DDUCKEY,DDUCIEN S DDUCFLD=0 F S DDUCFLD=$O(^DD("KEY","F",DDUCFI,DDUCFLD)) Q:'DDUCFLD D . S DDUCKEY=0 . F S DDUCKEY=$O(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY)) Q:'DDUCKEY D .. S DDUCIEN=0 .. F S DDUCIEN=$O(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY,DDUCIEN)) Q:'DDUCIEN D ... I $P($G(^DD("KEY",DDUCKEY,2,DDUCIEN,0)),U,2)'=DDUCFI!($P($G(^(0)),U)'=DDUCFLD) D .... S DDUCGL=$NA(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY,DDUCIEN)) .... D WEN(DDUCGL) .... D:DDUCFIX KILL(DDUCGL) Q ; ;--------------- FFILE ;Set the .01 of Key to DDUCFI S $P(^DD("KEY",DDUCKEY,0),U)=DDUCFI D WRITE("FILE (#.01) for "_DDUCKID_" set to "_DDUCFI_".",10) Q ; FNM ;Set the NAME for the Key S $P(^DD("KEY",DDUCKEY,0),U,2)=DDUCNM D WRITE("NAME for "_DDUCKID_" set to '"_DDUCNM_"'.",10) Q ; FPRI ;Set the PRIORITY for the Key S $P(^DD("KEY",DDUCKEY,0),U,3)=DDUCPRI D WRITE("PRIORITY for "_DDUCKID_" set to '"_DDUCPRI_"'.",10) Q ; KILL(GL) ;Kill a global and print a message Q:'$D(@GL) K @GL W !?10,GL_" was killed." Q ; SET(GL,VAL) ;Set a global and print a message Q:$D(@GL) S VAL=$G(VAL),@GL=VAL W !?10,GL_" was set"_$S(VAL]"":" to "_VAL,1:"")_"." Q ; ;Write messages WCHK Q ;D WRITE("Checking Keys.",5) Q WNOKEY D WRITE(DDUCKID_" does not exist.",7) Q WMS(S,N) D WRITE(S_" is missing."_$S($G(N):" Nothing done.",1:""),7) Q WINC D WRITE("Field information in "_DDUCKEY_" is incomplete. Nothing done.",7) Q WFMS D WRITE("*File #"_DDUCFIL_", Field #"_DDUCFLD_" referenced in "_DDUCKEY_" is missing.",7) Q ;22*130 WNE D WRITE("*Fields in "_DDUCKID_" don't match fields in Uniqueness Index.",7) Q ;22*130 WEN(GL) D WRITE("Erroneous node "_GL_" is set.",7) Q WNM D WRITE("NAME for "_DDUCKID_" looks like it should be '"_DDUCNM_"'.",7) Q WPRI D WRITE("PRIORITY for "_DDUCKID_" looks like it should be '"_DDUCPRI_"'.",7) Q ; WRITE(TXT,TAB) ;Write text, wrap at word boundaries. N I D WRAP^DIKCU2(.TXT,-TAB-2,-TAB) W !?TAB,$G(TXT,$G(TXT(0))) F I=1:1 Q:'$D(TXT(I)) W !?TAB+2,TXT(I) Q ; KEYID(KEY,NM) ;Return string that identifies a Key S:'$D(NM) NM=$P($G(^DD("KEY",KEY,0)),U,2) Q $S(NM]"":"Key '"_NM_"' (#"_KEY_")",1:"Key #"_KEY) DDW DDW ;SFISC/PD KELTZ-SCREEN EDITOR MAIN ROUTINE ;24MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. MAIN N DX,DY,IOTM,IOBM I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; D INIT I $G(DDWERR) K DDWERR Q D ^DDWT1,END Q ; EDIT(DIC,DDWFLAGS,DIWETXT,DIWESUB,DDWRW,DDWC,DDWTM,DDWBM,DDWLMAR,DDWRMAR,DDWAUTO,DDWTAB) ;DDWRW=ROW # N DWHD,DWLC,DDWEDIT,DDWRWSET S DDWEDIT=1,DDWRWSET=1 ;WE MEAN IT G MAIN ; MSG(DDWX) ;Write message S DY=$G(DDWBM,IOSL)-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$G(DDWX) I $G(DDWX)="",$D(DDWMARK) D IND^DDW7(1) Q ; INIT ;Setup, initialize variables N X,DDWI K DIERR D INIT^DDGLIB0() G:$G(DIERR) ERR I $P(DDGLED,DDGLDEL,2)_$P(DDGLED,DDGLDEL,3)_$P(DDGLED,DDGLDEL,4)="" D TRMERR^DDGLIB0("Set Top and Bottom Margins, Delete Line, and Insert Line") G ERR ; G:'$D(DIC) FERR S DDWDIC=$$CREF^DILF(DIC) S X="S X="_DDWDIC D ^DIM G:'$D(X) FERR G:'$D(@DDWDIC) FERR S DDWDIC=$NA(@DDWDIC) S DIC=$$OREF^DILF(DDWDIC) ; I IOSL>100 S DDWIOSL=IOSL,IOSL=24 S IOTM=$G(DDWTM,1)+2,IOBM=$G(DDWBM,IOSL)-3 MAR I IOBM-IOTM<3 D BLD^DIALOG(202,$$EZBLD^DIALOG(831)) G ERR ;**'TOP & BOTTOM' ; S:'$G(DDWLMAR) DDWLMAR=1 S:'$G(DDWRMAR) DDWRMAR=74 I DDWRMAR'>DDWLMAR!(DDWLMAR>231)!(DDWRMAR>245) D BLD^DIALOG(202,"Left and/or Right Margin") G ERR ; D:$D(DDW("IN"))[0 GETKEY^DDWK ; D CLR W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2) X DDGLZOSF("EOFF"),DDGLZOSF("TRMON") ; K DDWL,^TMP("DDW",$J),^TMP("DDW1",$J) S (DDWA,DDWSTB,DDWSTAT)=0,DDWBF="0010" ; S DDWREP=$G(DDWFLAGS)["R" S DDWRAP=$G(DDWFLAGS)'["M" I 'DDWRAP D . S DDWLMAR(1)=DDWLMAR,DDWLMAR=1 . S DDWRMAR(1)=DDWRMAR,DDWRMAR=245 ; I '$G(DDWRW),$G(DDWRW)'="B" S DDWRW=1 I '$G(DDWC),$G(DDWC)'="E" S DDWC=1 ; S DDWTO=DTIME S DDWOFS="0^20^^1",$P(DDWOFS,U,3)=IOM-$P(DDWOFS,U,2) S DDWMR=IOBM-IOTM+1 ; S:$G(DDWTAB)="" DDWTAB="+8" S DDWRUL=$$RULER^DDW2(DDWTAB) ; I $G(DDWAUTO) D . N DDWX,DDWERR . S (DDWAUTO,DDWX)=$E(DDWAUTO,1,15) . D AUTOVAL^DDW1 . I $D(DDWERR)#2!($G(DDWAUTO)'>0) K DDWAUTO Q . S DDWAUTO("H")=$H . S DDWAUTO("S")=DDWAUTO*60 E K DDWAUTO Q ; RESET ;Reset terminal and cleanup K DIERR D INIT^DDGLIB0() D:$G(DIERR) MSG^DIALOG("BW") W $P($G(DDGLVID),DDGLDEL,10) ; END ;Cleanup S:$D(DDWIOSL)#2 IOSL=DDWIOSL I $P(DDGLED,DDGLDEL,2)]"" D . S IOTM=1,IOBM=$S($D(IOSL)#2:IOSL,1:24) W @$P(DDGLED,DDGLDEL,2) D CLR ; K DDW,DDWA,DDWBF,DDWC,DDWCHG,DDWCNT,DDWDIC,DDWED,DDWFIN,DDWFIND,DDWHLOG K DDWIOSL,DDWL,DDWMARK,DDWMR,DDWN,DDWOFS,DDWQ,DDWRAP,DDWREP K DDWRUL,DDWRW,DDWSTAT,DDWSTB,DDWTC,DDWTO K ^TMP("DDW",$J),^TMP("DDW1",$J),^TMP("DDWH",$J) I $$ROUEXIST^DILIBF("XPDUTL"),$$VERSION^XPDUTL("XU")>7.1 E K ^TMP("DDWB",$J) ; ;D:'$D(DIWE) X^DIWE I $D(DDS) D . D:$D(DIWESW) KILL^DDGLIB0("K") E D KILL^DDGLIB0($G(DDWFLAGS)) Q ; CLR ;Clear screen I $G(DDWTM,1)=1,$G(DDWBM,IOSL)=IOSL W $P(DDGLCLR,DDGLDEL,2) E D . S DX=0 . F DY=$G(DDWTM,1)-1:1:$G(DDWBM,IOSL)-1 X IOXY W $P(DDGLCLR,DDGLDEL) Q ; FERR ;File input parameter error D BLD^DIALOG(202,"File") D ERR Q ; ERR ;Error during setup W $C(7),! D MSG^DIALOG("BW") W ! D KILL^DDGLIB0() S DDWERR=1 Q DDW1 DDW1 ;SFISC/PD KELTZ-LOAD, SAVE ;06:11 PM 25 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; LOAD ;Put up "box" and load document N DDWI,DDWX D BOX ; I $D(DWLC)[0 D . S DWLC=$S($D(@DDWDIC@(0))#2:+$P(@DDWDIC@(0),U,4),1:$O(@DDWDIC@(""),-1)) . S:$D(@DDWDIC@(1))#2 $E(DDWBF,4)=1 S DDWCNT=$S(DWLC:DWLC,1:1) ;HOW MANY LINES WE HAVE TOTAL ; D:DDWCNT>1 MSG^DDW("...") F DDWI=DDWCNT:-1:DDWMR+1 D ;PUT HIDDEN LINES INTO ^TMP . S DDWSTB=DDWSTB+1 . S DDWX=$S('$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI))) . D:DDWX?.E1C.E CTRL . S ^TMP("DDW1",$J,DDWSTB)=DDWX ; F DDWI=1:1:DDWMR D ;start writing from line 1 (!) . S DDWX=$S(DDWI>DDWCNT:"",'$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI))) . D:DDWX?.E1C.E CTRL . S DDWL(DDWI)=DDWX . I DDWC'>IOM,DDWRW'>DDWMR,DDWI'>DDWCNT,DDWX'?." " D .. D CUP(DDWI,1) W $E(DDWX,1,IOM) ;HERE'S WHERE A LINE IS WRITTEN OUT ; I DDWCNT=1,DDWL(1)?1." " S DDWL(1)="" D:DDWCNT>1 MSG^DDW() ; CTRLREM D:$G(DDWED) MSG^DDW($C(7)_$P(DDGLVID,DDGLDEL,6)_$$EZBLD^DIALOG(8128)_$P(DDGLVID,DDGLDEL,10)) ;**'CONTROL CHARACTERS REPLACED' ; I DDWRW="B" D . D BOT^DDW3 E D LINE^DDWG(DDWRW,DDWC) Q ; CTRL ;Strip control characters from DDWX N I S DDWED=1 F I=1:1:$L(DDWX) S:$E(DDWX,I)?1C $E(DDWX,I)=" " Q ; BOX ;Draw box N DDWX ; I $D(DIWETXT) D . D CUP(-1,1) . W $P(DDGLVID,DDGLDEL)_$E(DIWETXT,1,IOM)_$P(DDGLVID,DDGLDEL,10) ; I $D(DIWESUB) S DDWX=DIWESUB E I $D(DH)#2,$D(DIE) S DDWX=DH S DDWX=$E($G(DDWX),1,30) ; D CUP(0,1) W $TR($J("",IOM)," ","=") I DDWRAP S DX=2 X IOXY W "[ WRAP ]" S DX=12 X IOXY W "["_$$UP^DILIBF($P($$EZBLD^DIALOG(7002),U,$S(DDWREP:2,1:1)))_"]" ;**INSERT/REPLACE S DX=40-($L(DDWX)\2) X IOXY W "< "_$E(DDWX,1,30)_" >" N DDWH S DDWH="["_$$EZBLD^DIALOG(8074)_"]",DX=76-$L(DDWH) X IOXY W DDWH ;** ; D CUP(DDWMR+1,1) W $E(DDWRUL,1,IOM) I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D . S DX=DDWLMAR-DDWOFS-1 X IOXY W "<" I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D . S DX=DDWRMAR-DDWOFS-1 X IOXY W ">" Q ; AUTOTM ;Prompt for autosave time N DDWHLP,DDWANS,DDWCOD S DDWHLP(1)=" Enter the interval in MINUTES you wish to have the Screen Editor" S DDWHLP(2)=" automatically save the text. Enter a number between 0 and 120." S DDWHLP(3)=" A value of 0 means text is NOT automatically saved." D ASK^DDWG(5,"Interval in MINUTES to automatically save text: ",15,+$G(DDWAUTO),"D AUTOVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD) ; Q:DDWCOD="TO"!(DDWANS=U) I $G(DDWANS) D . S DDWAUTO=DDWANS . S DDWAUTO("H")=$H . S DDWAUTO("S")=DDWAUTO*60 E K DDWAUTO Q ; AUTOVAL ;Validate autosave time K DDWERR I DDWX?."^"!($P($G(DDWCOD),U)="TO") S DDWX=U Q I $L(DDWX)>15 D . S DDWERR=" Response must not be more than 15 characters in length." I DDWX'=+$P(DDWX,"E") D . S DDWERR=" Response must be numeric." I DDWX>120!(DDWX<0) D . S DDWERR=" Response must be between 0 and 120." Q ; AUTOSV ;Autosave I $D(DDWED) K DDWED D SV S DDWAUTO("H")=$H Q ; SV ;Called from DDWT1 and AUTOSV D SAVE S:DDWCNT<1 DDWCNT=1 I DDWRW+DDWA>DDWCNT D . D POS(DDWCNT-DDWA,"E","RN") E D POS(DDWRW,DDWC) Q ; SAVE ;Save document N DDWI,DDWLMEM,DDWLSTB,DDWX D MSG^DDW($$EZBLD^DIALOG(8075.5)) H .5 ;**'SAVING CHANGES' S DDWCNT=0 K @DDWDIC ; F DDWI=1:1:DDWA D . S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW",$J,DDWI)) . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX . E S @DDWDIC@(DDWCNT)=DDWX ; S DDWLMEM=999 F DDWI=1:1:DDWSTB+1 Q:DDWI>DDWSTB Q:^TMP("DDW1",$J,DDWI)'?." " I DDWI'>DDWSTB S DDWLSTB=DDWI E D . F DDWI=DDWMR:-1:0 Q:'DDWI Q:DDWL(DDWI)'?." " . S DDWLMEM=DDWI ; F DDWI=1:1:$$MIN(DDWLMEM,DDWMR) D . S DDWCNT=DDWCNT+1,DDWX=$$NTS(DDWL(DDWI)) . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX . E S @DDWDIC@(DDWCNT)=DDWX ; I $D(DDWLSTB) F DDWI=DDWSTB:-1:DDWLSTB D . S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW1",$J,DDWI)) . I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX . E S @DDWDIC@(DDWCNT)=DDWX ; S DWLC=DDWCNT,DWHD=U I DDWCNT,'$E(DDWBF,4) S @DDWDIC@(0)=U_U_DWLC_U_DWLC_U_DT_U D MSG^DDW() Q ; QUIT ;If any edits were made, issue confirmation prompt. S DDWFIN="" Q:$G(DDWFLAGS)["Q"!'$D(DDWED) ; N DDWHLP,DDWANS,DDWCOD S DDWHLP(1)=" Enter 'Yes' to save changes and quit." S DDWHLP(2)=" Enter 'No' to discard changes and quit." S DDWHLP(3)=" Enter '^' to return to the editor without saving or quitting." ; D ASK^DDWG(5,$$EZBLD^DIALOG(8075.1),3,"","D QUITVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD) ;**'DO YOU WANT TO SAVE CHANGES? ' ; I DDWCOD="TO"!(DDWANS=U) K DDWFIN E I DDWANS="Y" D SAVE K DUOUT ;GFT Q ; QUITVAL ;Validate responses to the confirmation prompt K DDWERR I DDWX[U!($P(DDWCOD,U)="TO") S DDWX=U Q I DDWX="" S DDWERR=$$EZBLD^DIALOG(8041) Q ;**'REQUIRED' ; S:DDWX?.E1L.E DDWX=$$UP^DILIBF(DDWX) ;** ; I $P("YES",DDWX)]"",$P("NO",DDWX)]"" D Q . S DDWERR=$$EZBLD^DIALOG(1401) ;**'NOT VALID' ; S DDWX=$E(DDWX) Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; MIN(X,Y) ;Return the minimum of X and Y Q $S(X231 D ERR($$EZBLD^DIALOG(8138.2)) Q I DDWC'IOM D . D CUP(DDWMR+1,DDWLMAR-DDWOFS) W $E(DDWRUL,DDWLMAR) D CUP(DDWMR+1,DDWC-DDWOFS) W "<" D POS(DDWRW,DDWC) S DDWLMAR=DDWC Q ; RSET I 'DDWRAP D ERR($$EZBLD^DIALOG(8138.1)) Q I DDWC>245 D ERR($$EZBLD^DIALOG(8138.4)) Q I DDWC'>DDWLMAR D ERR($$EZBLD^DIALOG(8138.5)) Q I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D . D CUP(DDWMR+1,DDWRMAR-DDWOFS) W $E(DDWRUL,DDWRMAR) D CUP(DDWMR+1,DDWC-DDWOFS) W ">" D POS(DDWRW,DDWC) S DDWRMAR=DDWC Q ; WRAPM S DDWRAP=DDWRAP+1#2 D CUP(0,3) W $S(DDWRAP:"[ WRAP ]",1:"========") I 'DDWRAP D . S DDWLMAR(1)=DDWLMAR,DDWLMAR=1 . S DDWRMAR(1)=DDWRMAR,DDWRMAR=245 E D . S DDWLMAR=DDWLMAR(1) K DDWLMAR(1) . S DDWRMAR=DDWRMAR(1) K DDWRMAR(1) D RULER^DDW3,POS(DDWRW,DDWC) Q ; REPLM S DDWREP=DDWREP+1#2 D CUP(0,13) W "[",$$UP^DILIBF($P($$EZBLD^DIALOG(7002),U,$S(DDWREP:2,1:1))),"]" ;** D POS(DDWRW,DDWC) Q ; STAT S DDWSTAT=DDWSTAT+1#2 I DDWSTAT S DDWTO=1 E D . D CUP(DDWMR+2,1) . W $P(DDGLCLR,DDGLDEL) D POS(DDWRW,DDWC) . S DDWTO=DTIME . K DDWTC Q ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ;Return screen number Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; ERR(DDWX) ;Error W $C(7) D MSG^DDW(DDWX) H 2 D MSG^DDW() F R *DDWX:0 E Q D POS(DDWRW,DDWC) Q DDW3 DDW3 ;SFISC/MKO-TOP, BOTTOM, SCROLL ;11:57 AM 24 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; TOP N DDWI I DDWA=0 D POS(1,1,"RN") Q D SHFTUP(1),POS(1,1,"RN") Q ; SHFTUP(DDWFL) ; N DDWSH,DDWI S DDWSH=DDWA+1-DDWFL D:DDWSH>DDWMR MSG^DDW(" ...") ;** ; F DDWI=DDWMR:-1:$$MAX(1,DDWMR-DDWSH+1) D:DDWI+DDWA'>DDWCNT . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI) . S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI) ; I $E(DDWBF,2) F DDWI=DDWA:-1:DDWFL+DDWMR D . S DDWSTB=DDWSTB+1 . S ^TMP("DDW1",$J,DDWSTB)=^TMP("DDW",$J,DDWI) E S DDWSTB=$$MAX(DDWCNT-DDWFL+1-DDWMR,0) ; S DDWA=DDWFL-1 I DDWSH>DDWMR D . F DDWI=1:1:DDWMR S DDWL(DDWI)=^TMP("DDW",$J,DDWFL+DDWI-1) . I $P(DDWOFS,U,4)=1 D .. D CUP(1,1) .. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWIDDWMR MSG^DDW(" ...") ;** ; F DDWI=1:1:$$MIN(DDWSH,DDWMR) D . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI) . S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI) . ; I $E(DDWBF,3) F DDWI=DDWSTB:-1:DDWNSTB+1 D . S DDWA=DDWA+1 . S ^TMP("DDW",$J,DDWA)=^TMP("DDW1",$J,DDWI) E S DDWA=DDWFL-1 ; I DDWSH>DDWMR D . F DDWI=1:1:DDWMR S DDWL(DDWI)=$S(DDWNSTB-DDWI+1>0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"") . I $P(DDWOFS,U,4)=$$SCR($S($D(DDWCOL):DDWCOL,1:$L(DDWL(DDWMR))+1)) D .. D CUP(1,1) .. F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI0:^TMP("DDW1",$J,DDWNSTB-DDWI+1),1:"") . D:$P(DDWOFS,U,4)=$$SCR($L(DDWL(DDWMR))+1) SCRUP(DDWSH) ; S DDWSTB=$$MAX(0,DDWNSTB-DDWMR) S:'DDWSTB $E(DDWBF,3)=0 Q ; MVFWD(DDWNUM) ; N DDWI F DDWI=1:1:DDWNUM D . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(DDWI) . S ^TMP("DDW1",$J,DDWSTB+DDWMR-DDWI+1)=DDWL(DDWI) F DDWI=1:1:DDWMR-DDWNUM S DDWL(DDWI)=DDWL(DDWI+DDWNUM) F DDWI=DDWMR-DDWNUM+1:1:DDWMR D . S DDWL(DDWI)=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1 D SCRUP(DDWNUM) Q ; SCRUP(DDWNUM) ; N DDWI D CUP(DDWMR,1) F DDWI=DDWMR-DDWNUM+1:1:DDWMR D . I $P(DDGLED,DDGLDEL,2)]"" W $C(10) . E D .. D CUP(1,1) W $P(DDGLED,DDGLDEL,4) .. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3) . I DDWL(DDWI)'?." " D .. D CUP(DDWMR,1) .. W $$LINE(DDWI,$G(DDWMARK)) D POS(DDWMR,DDWC,"RN") Q ; MVBCK(DDWNUM) ; N DDWI F DDWI=DDWMR:-1:DDWMR-DDWNUM+1 D:DDWI+DDWA'>DDWCNT . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI) . S ^TMP("DDW",$J,DDWA+DDWI)=DDWL(DDWI) F DDWI=DDWMR:-1:DDWNUM+1 S DDWL(DDWI)=DDWL(DDWI-DDWNUM) F DDWI=DDWNUM:-1:1 S DDWL(DDWI)=^TMP("DDW",$J,DDWA),DDWA=DDWA-1 D SCRDN(DDWNUM) Q ; SCRDN(DDWNUM) ; N DDWI D CUP(1,1) F DDWI=DDWNUM:-1:1 D . I $P(DDGLED,DDGLDEL,2)]"" W $P(DDGLED,DDGLDEL) . E D .. D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4) .. D CUP(1,1) W $P(DDGLED,DDGLDEL,3) . I DDWL(DDWI)'?." " D .. D CUP(1,1) .. W $$LINE(DDWI,$G(DDWMARK)) D POS(1,DDWC,"RN") Q ; ERR ; W $C(7) Q ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SHIFT(C,DDWOFS) ; N DDWI,N,M,S S N=$P(DDWOFS,U,2),M=$P(DDWOFS,U,3) S S=$$SCR(C) S DDWOFS=S-1*M_U_N_U_M_U_S D RULER F DDWI=1:1:$$MIN(DDWMR,DDWCNT) D . S DY=IOTM+DDWI-2,DX=0 X IOXY . W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK)) Q ; RULER ;Write ruler D CUP(DDWMR+1,1) W $P(DDGLCLR,DDGLDEL)_$E(DDWRUL,1+DDWOFS,IOM+DDWOFS) I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D . D CUP(DDWMR+1,DDWLMAR-DDWOFS) W "<" I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D . D CUP(DDWMR+1,DDWRMAR-DDWOFS) W ">" Q ; LINE(DDWI,DDWMARK) ; N DDWX S DDWX=$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) Q:$G(DDWMARK)="" DDWX ; N DDWR1,DDWC1,DDWR2,DDWC2 S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2) S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4) ; I DDWI'<(DDWR1-DDWA),DDWI'>(DDWR2-DDWA) D . N DDWX1,DDWX2 . S DDWX1=$S(DDWI=(DDWR1-DDWA):DDWC1,1:1) . S DDWX2=$S(DDWI=(DDWR2-DDWA):DDWC2,1:999) . S DDWX=$E(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$P(DDGLVID,DDGLDEL,6)_$E(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$P(DDGLVID,DDGLDEL,10)_$E(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS) Q DDWX ; SCR(C) ; Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW4 DDW4 ;SFISC/PD KELTZ-OTHER NAVIGATION, DEL ;2:54 PM 23 Aug 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; TAB N DDWX S DDWX=$F(DDWRUL,"T",DDWC+1) G:'DDWX ERR D POS(DDWRW,DDWX-1,"R") Q ; DEOL S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1) W $P(DDGLCLR,DDGLDEL) Q ; DELW N DDWI,DDWW I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 I DDWC>$L(DDWN) D Q . I DDWN?." " D .. D XLINE^DDW5() . E D .. N DDWY,DDWX .. S DDWY=DDWRW+DDWA,DDWX=DDWC .. D JOIN^DDW6 .. D POS(DDWY-DDWA,DDWX,"RN") ; S DDWI=$$WRPOS(DDWN) S DDWW=$E(DDWN,DDWC,DDWI-1) S $E(DDWN,DDWC,DDWI-1)="",DDWL(DDWRW)=DDWN I $P(DDGLED,DDGLDEL,6)]"" D . F DDWI=1:1:$L(DDWW) W $P(DDGLED,DDGLDEL,6) . S DDWI=$E(DDWN,IOM-$L(DDWW)+1+DDWOFS,IOM+DDWOFS) . I DDWI]"" D CUP(DDWRW,IOM-$L(DDWW)+1) W DDWI D CUP(DDWRW,DDWC-DDWOFS) E D . W $E(DDWN_$J("",$L(DDWW)),DDWC,IOM+DDWOFS) . D CUP(DDWRW,DDWC-DDWOFS) Q ; WORDR N DDWI S DDWI=$$WRPOS(DDWN) D POS(DDWRW,DDWI,"R") Q ; WRPOS(DDWT) ; N DDWP,DDWS S DDWT=$$PUNC(DDWT) S DDWS=$F(DDWT," ",DDWC+1),DDWP=$F(DDWT,"!",DDWC+1) S:'DDWS DDWS=999 S:'DDWP DDWP=999 ; I DDWC>$L(DDWT) D . I DDWRW+DDWA'1 D . D POS(1,DDWC,"RN") E D . S DDWX=$$MIN(DDWA,DDWMR) . D:DDWX MVBCK^DDW3(DDWX) Q ; JLEFT I DDWC=1,'DDWOFS Q N DDWX I DDWN?." " S DDWX=1 E F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" " I DDWC-DDWOFS=1,DDWC>1 D POS(DDWRW,DDWC-1,"R") Q:DDWC=DDWX S DDWC=$$MAX($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:0),1+DDWOFS) D POS(DDWRW,DDWC,"R") Q JRIGHT N DDWX S DDWX=$L(DDWN)+1 I DDWC-DDWOFS=IOM,DDWC<246 D POS(DDWRW,DDWC+1,"R") Q:DDWC=DDWX S DDWC=$$MIN($S($$SCR(DDWX)=$$SCR(DDWC)&(DDWC'=DDWX):DDWX,1:999),$$MIN(IOM+DDWOFS,246)) D POS(DDWRW,DDWC,"R") Q ; LBEG N DDWX I DDWN?." " D POS(DDWRW,1,"R") Q I $E(DDWN,1,DDWC-1)?." ",$E(DDWN,DDWC)'=" " D POS(DDWRW,1,"R") Q F DDWX=1:1:$L(DDWN) Q:$E(DDWN,DDWX)'=" " D POS(DDWRW,DDWX,"R") Q LEND D POS(DDWRW,"E","R") Q ; ERR ;Beep W $C(7) Q ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ;Screen # Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) PUNC(X) ; Q $TR(X,"`~!@#$%^&*()-_=+\|[{]};:'"",<.>/?",$TR($J("",32)," ","!")) DDW5 DDW5 ;SFISC/PD KELTZ-WRAP, BREAK, ILINE, XLINE ;01:23 PM 21 Dec 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; WRAP ;Wrap at word boundary S:$E(DDWN,DDWC,999)?1." " (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1) I DDWC'>$L(DDWN) D WRAPI Q I 'DDWRAP D POS(DDWRW,DDWRMAR+1,"R"),BREAK(1) Q D WRAPW Q ; WRAPI ;Cursor in middle I $E(DDWN,DDWLMAR,999)'[" "!'DDWRAP D BREAK(-1),POS(DDWRW-1,"E","RN") Q N DDWCSV,DDWI,DDWLST,DDWRMSV S DDWI=$F(DDWN," ",DDWC) I DDWI,DDWI-2'>DDWRMAR D . S DDWCSV=DDWC . S (DDWN,DDWL(DDWRW))=$$TR(DDWN) . D POS(DDWRW,DDWI,"R"),BREAK(-1),POS(DDWRW-1,DDWCSV,"RN") . S (DDWN,DDWL(DDWRW))=$$TR(DDWN) E I DDWC=2 D . D POS(DDWRW,DDWRMAR+1,"R"),BREAK(-1),POS(DDWRW-1,2,"RN") E D . S DDWLST=$$TR($E(DDWN,DDWC,999)) . S (DDWL(DDWRW),DDWN)=$E(DDWN,1,DDWC-1) . S DDWRMSV=DDWRMAR,DDWRMAR=$$MIN(DDWRMAR,DDWC-2) . D WRAPW . W $E(DDWLST,1,IOM+DDWOFS-DDWC) . S DDWL(DDWRW)=DDWN_DDWLST,DDWRMAR=DDWRMSV . D POS(DDWRW,DDWC,"RN") Q ; WRAPW ;Cursor at end N DDWI,DDWS1,DDWS2,DDWTXT S DDWTXT(1)=DDWN D ADJMAR^DDW6(.DDWTXT,"","I") ; S DDWS1=$$SCR($L(DDWTXT(1))+1),DDWS2=$$SCR($L(DDWTXT(DDWTXT))+1) I DDWS1=$P(DDWOFS,U,4),DDWS2=$P(DDWOFS,U,4),DDWTXT=2 D . S (DDWN,DDWL(DDWRW))=DDWTXT(1)_DDWTXT(2) . S DDWC=$L(DDWTXT(1))+1 . D POS(DDWRW,DDWC),BREAK(1) ; E D . F DDWI=1:1:DDWTXT-1 D .. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI) .. D ILINE .. S (DDWN,DDWL(DDWRW))=DDWTXT(DDWI+1) .. I DDWS2=$P(DDWOFS,U,4) D ... D CUP(DDWRW-1,1) ... W $P(DDGLCLR,DDGLDEL)_$E(DDWTXT(DDWI),1+DDWOFS,IOM+DDWOFS) ... D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS) . D POS(DDWRW,"E","R") Q ; BREAK(DDWFLAG) ;Break line, make new line current ;Final cursor position: ; 0:lmar of new line (used by ) ; 1:end of new line (used by Wrap) ;-1:doesn't matter (used by Wrap) N DDWRST I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 S DDWRST=$E(DDWN,DDWC,999) I DDWLMAR>1,DDWRST'?@(DDWLMAR-1_""" "".E") D . S DDWRST=$J("",DDWLMAR-1)_$$LD(DDWRST) S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1) W $P(DDGLCLR,DDGLDEL) D ILINE S (DDWN,DDWL(DDWRW))=DDWRST ; I $G(DDWFLAG)=1 D . I $$SCR($L(DDWN)+1)=$P(DDWOFS,U,4) D .. D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS) . D POS(DDWRW,"E","R") ; E I '$G(DDWFLAG) D . I $P(DDWOFS,U,4)=1 D CUP(DDWRW,1) W $E(DDWN,1,IOM) . D POS(DDWRW,DDWLMAR,"R") ; E D CUP(DDWRW,1) W $E(DDWN,1+DDWOFS,IOM+DDWOFS) Q ; ILINE ;Insert line below current line, make that current ;Column is unchanged N DDWI,DDWX I DDWRWDDWCNT D .. S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWMR) . F DDWI=DDWMR:-1:DDWRW+2 S DDWL(DDWI)=DDWL(DDWI-1) . S DDWL(DDWRW+1)="" . D CUP(DDWRW+1,1) . ; . I $P(DDGLED,DDGLDEL,3)]"" D .. I $P(DDGLED,DDGLDEL,2)="" D ... D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,4) D CUP(DDWRW+1,1) .. W $P(DDGLED,DDGLDEL,3) . E D .. S DDWX=IOTM .. S IOTM=IOTM+DDWRW W @$P(DDGLED,DDGLDEL,2) S IOTM=DDWX .. D CUP(DDWRW+1,1) W $P(DDGLED,DDGLDEL) .. W @$P(DDGLED,DDGLDEL,2) . D POS(DDWRW+1,DDWC,"RN") ; E D . S DDWA=DDWA+1,^TMP("DDW",$J,DDWA)=DDWL(1) . F DDWI=1:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1) . S DDWL(DDWMR)="" . D SCRUP^DDW3(1) S DDWCNT=DDWCNT+1 S $E(DDWBF,1,3)=111 Q ; XLINE(DDWFLAG,DDWNP) ;Delete current line ;DDWFLAG: ; 1:leave cursor on deleted line (used by Join) ; 0:move cursor up one line if deleted line is last line ; (used by PF1-D and DELBLK) ; DDWNP = 1:don't bother printing, used by DELBLK N DDWI,DDWX I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 F DDWI=DDWRW:1:DDWMR-1 S DDWL(DDWI)=DDWL(DDWI+1) S DDWX="" S:DDWSTB DDWX=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1 S DDWL(DDWMR)=DDWX ; D:'$G(DDWNP) XLINEP ; S DDWCNT=DDWCNT-1 I 'DDWCNT D . S DDWCNT=1 D POS(1,DDWLMAR,"RN") E I DDWA+DDWRW>DDWCNT,'$G(DDWFLAG) D . D UP^DDWT1 E D POS(DDWRW,DDWC,"N") S $E(DDWBF,1,3)=111 Q ; XLINEP ;Redisplay screen I $P(DDGLED,DDGLDEL,4)]"" D . W $P(DDGLED,DDGLDEL,4) . I $P(DDGLED,DDGLDEL,2)="" D CUP(DDWMR,1) W $P(DDGLED,DDGLDEL,3) E I DDWRWIOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ; Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(X$P(DDWMARK,U,3) D UNMARK^DDW7 D POS(DDWRW,DDWLMAR,"R") S DDWRFMT=0 F D JOIN Q:DDWRFMT Q ; JOIN ;Join N DDWI,DDWSCR,DDWNSV,DDWLL,DDWTXT,DDWTXT0 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 ; ;Get current line S (DDWTXT(1),DDWNSV)=DDWN ; ;Get next line I DDWRW=DDWMR S:DDWSTB DDWTXT(2)=^TMP("DDW1",$J,DDWSTB) E S:DDWA+DDWRWDDWRMAR S:$D(DDWTXT(2))#2 DDWLL=DDWTXT(2) . E I $D(DDWRFMT) S DDWRFMT=1 ; ;Adjust S DDWTXT0=$O(DDWTXT(""),-1) D ADJMAR(.DDWTXT,"","I") S:$D(DDWLL) DDWTXT=DDWTXT+1,DDWTXT(DDWTXT)=DDWLL S (DDWN,DDWL(DDWRW))=DDWTXT(1) ; ;Delete next line I DDWTXT0>1,DDWTXT=1 D . I DDWRW=DDWMR S DDWSTB=DDWSTB-1,DDWCNT=DDWCNT-1,$E(DDWBF,1,3)=111 . E D POS(DDWRW+1,DDWC,"RN"),XLINE^DDW5(1),POS(DDWRW-1,DDWC,"RN") ; ;DDWSCR: curr scr = final scr I DDWTXT=1,'$D(DDWRFMT) S DDWSCR=$L(DDWTXT(1))+1-DDWOFS E S DDWSCR=DDWLMAR-DDWOFS S DDWSCR=DDWSCR'<1&(DDWSCR'>IOM) ; I DDWSCR,DDWNSV'=DDWN D . I DDWNSV]"",$P(DDWNSV,DDWN)="" D .. D CUP(DDWRW,$$MAX($L(DDWN)+1-DDWOFS,1)) .. W $P(DDGLCLR,DDGLDEL) . E I DDWN]"",$P(DDWN,DDWNSV)="" D .. D CUP(DDWRW,$$MAX($L(DDWNSV)+1-DDWOFS,1)) .. W $E(DDWN,$$MAX($L(DDWNSV),DDWOFS)+1,IOM+DDWOFS) . E D .. D CUP(DDWRW,DDWOFS+1) .. W $P(DDGLCLR,DDGLDEL)_$E(DDWN,DDWOFS+1,IOM+DDWOFS) ; I DDWTXT=1 D . I '$D(DDWRFMT) D .. D POS(DDWRW,"E","RN") . E D POS(DDWRW,DDWLMAR,"RN") E D JOIN2 Q ; JOIN2 ;Join produced >1 lines D POS(DDWRW,DDWLMAR,"R") ; I DDWTXT0=2 D . I DDWRW1 F DDWJ=$G(DDWFLG)["I"+1:1:DDWT D . S DDWT(DDWJ)=$J("",DDWLMAR-1)_DDWT(DDWJ) Q ; AMLOOP ;Process DDWT(DDWJ) I $E(DDWT(DDWJ),1,DDWW)=$J("",DDWW) S DDWT(DDWJ)=$$LD(DDWT(DDWJ)) ; E I $L(DDWT(DDWJ))>DDWW F D Q:$L(DDWT(DDWJ))'>DDWW . N DDWK,DDWFST,DDWLST . F DDWK=$O(DDWT(""),-1)+1:-1:DDWJ+2 S DDWT(DDWK)=DDWT(DDWK-1) . D SLICE(DDWT(DDWJ),DDWW,.DDWFST,.DDWLST) . S DDWT(DDWJ)=DDWFST,DDWT(DDWJ+1)=DDWLST . D AMINCJ ; E I $L(DDWT(DDWJ))=DDWW!'$D(DDWT(DDWJ+1)) D . I DDWRAP,$D(DDWT(DDWJ+1)) S DDWT(DDWJ+1)=$$LD(DDWT(DDWJ+1)) . D AMINCJ ; E I 'DDWRAP D . N DDWK S DDWK=DDWW-$L(DDWT(DDWJ)) . S DDWT(DDWJ)=DDWT(DDWJ)_$E(DDWT(DDWJ+1),1,DDWK) . S DDWT(DDWJ+1)=$E(DDWT(DDWJ+1),DDWK+1,999) . D:DDWT(DDWJ+1)="" AMSHIFT(.DDWT,DDWJ+1) ; E D . N DDWD,DDWI,DDWNXT,DDWSP,DDWX1,DDWX2 . S DDWD=0 F D Q:DDWD .. S DDWX1=DDWT(DDWJ),(DDWX2,DDWT(DDWJ+1))=$$LD(DDWT(DDWJ+1)) .. I DDWX2="" S DDWD=1 Q .. S DDWNXT=$P(DDWX2," "),DDWI=$L(DDWNXT) .. I $E(DDWX2,DDWI+2)=" ",$E(DDWX2,DDWI+3,999)'?." " D ... F DDWI=DDWI+2:1 Q:$E(DDWX2,DDWI+1)'=" " .. S DDWSP=DDWX1'?.E1" " .. I $L(DDWX1)+DDWSP+$L($E(DDWX2,1,DDWI))>DDWW S DDWD=1 Q .. S DDWT(DDWJ)=DDWX1_$E(" ",DDWSP)_$E(DDWX2,1,DDWI) .. S DDWT(DDWJ+1)=$$LD($E(DDWX2,DDWI+1,999)) . ; . I DDWT(DDWJ+1)="" D .. D AMSHIFT(.DDWT,DDWJ+1) . E D AMINCJ Q ; AMSHIFT(DDWT,DDWJ) ;Delete DDWT(DDWJ) and shift up N DDWI F DDWI=DDWJ:1:$O(DDWT(""),-1)-1 S DDWT(DDWI)=DDWT(DDWI+1) K DDWT($O(DDWT(""),-1)) Q ; AMINCJ ;Incr DDWJ I DDWJ=1,$G(DDWFLG)["I" S DDWW=DDWRMAR-DDWLMAR+1 S DDWJ=DDWJ+1 Q ; SLICE(DDWN,DDWW,DDWFST,DDWRST) ; ;Out: DDWFST=first part of text, $L<=DDWRMAR ; DDWRST=remaining part (lead blanks removed) N DDWI,DDWP,DDWX S:'$G(DDWW) DDWW=DDWRMAR I 'DDWRAP S DDWFST=$E(DDWN,1,DDWW),DDWLST=$E(DDWN,DDWW+1,999) Q ; ;Set DDWI to column # at which to break S DDWX=$E(DDWN,1,DDWW),DDWI=DDWW I DDWX'[" " E I DDWX?." " E I $E(DDWX,DDWW)=" ",$E(DDWN,DDWW+1)'=" " E D . F DDWP=$L(DDWX," "):-1:0 Q:$P(DDWX," ",DDWP)]"" . Q:DDWP=1 . S DDWI=$L($P(DDWX," ",1,DDWP-1))+1 . S:DDWI'>$S(DDWW=DDWRMAR:DDWLMAR,1:1) DDWI=DDWW ; S DDWFST=$E(DDWN,1,DDWI),DDWRST=$$LD($E(DDWN,DDWI+1,999)) Q ; TR(X) Q:$G(X)="" X N I F I=$L(X):-1:0 Q:$E(X,I)'=" " Q $E(X,1,I) ; LD(X) Q:$G(X)="" X N I F I=1:1:$L(X)+1 Q:$E(X,I)'=" " Q $E(X,I,999) ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; SCR(C) ;Screen number Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW7 DDW7 ;SFISC/MKO-MARK TEXT ;2:30 PM 27 Jul 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; MARK ;Mark the text I $D(DDWMARK) D . D BOUND E D . S DDWMARK=DDWA+DDWRW_U_DDWC_U_(DDWA+DDWRW)_U_$$MAX(DDWC,$L(DDWN)) . D PAINT(DDWMARK,1),IND(1) Q ; BOUND ;Mark ending boundary, highlight selected text N DDWI,DDWX,DDWY ; S DDWI=DDWA+DDWRW_U_DDWC S DDWX=$P(DDWMARK,U,1,2) S DDWY=$P(DDWMARK,U,3,4) ; I $$ISLESS(DDWI,DDWX) D . D PAINT(DDWX_U_DDWY) . D PAINT(DDWI_U_DDWX,1) . S DDWMARK=DDWI_U_DDWX E D . I $$ISLESS(DDWI,DDWY) D .. D PAINT(DDWI_U_DDWY),PAINT(DDWI_U_DDWI,1) . E D PAINT(DDWY_U_DDWI,1) . S DDWMARK=DDWX_U_DDWI D CUP(DDWRW,DDWC-DDWOFS) Q ; UNMARK ;Unmark the text D:$D(DDWMARK) PAINT(DDWMARK),IND() K DDWMARK Q ; PAINT(DDWMARK,DDWREV) ;Paint selected text N DDWI,DDWE1,DDWE2,DDWL1,DDWL2,DDWR1,DDWC1,DDWR2,DDWC2 S DDWR1=$P(DDWMARK,U,1),DDWC1=$P(DDWMARK,U,2) S DDWR2=$P(DDWMARK,U,3),DDWC2=$P(DDWMARK,U,4) S DDWL1=$$MAX(DDWR1-DDWA,1),DDWL2=$$MIN(DDWR2-DDWA,DDWMR) Q:DDWL1>DDWL2 ; W:$G(DDWREV) $P(DDGLVID,DDGLDEL,6) F DDWI=DDWL1:1:DDWL2 D . S DDWE1=$$MAX($S(DDWI+DDWA=DDWR1:DDWC1,1:1),DDWOFS+1) . S DDWE2=$$MIN($S(DDWI+DDWA=DDWR2:DDWC2,1:999),IOM+DDWOFS) . Q:DDWE1>DDWE2 . D CUP(DDWI,DDWE1-DDWOFS) . W $E(DDWL(DDWI),DDWE1,DDWE2) W:$G(DDWREV) $P(DDGLVID,DDGLDEL,10) Q ; IND(DDWX) ;Paint indicator S DY=$G(DDWBM,IOSL)-1,DX=IOM-7 X IOXY W $S($G(DDWX):$P(DDGLVID,DDGLDEL,6)_"Select"_$P(DDGLVID,DDGLDEL,10),1:$P(DDGLCLR,DDGLDEL)) D CUP(DDWRW,DDWC-DDWOFS) Q ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; ISLESS(X,Y) ;Is coordinate X less than coordinate Y N R1,C1,R2,C2 S R1=$P(X,U),C1=$P(X,U,2) S R2=$P(Y,U),C2=$P(Y,U,2) ; Q:R1>R2 0 Q:R1C2 0 Q 1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW8 DDW8 ;SFISC/MKO-COPY, CUT, PASTE ;12:09 PM 24 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CUT() ;Cut selected text N DDWADJ,DDWC1,DDWC2,DDWCSV,DDWISIN,DDWNDEL,DDWR1,DDWR2,DDWRSV I '$D(DDWMARK) D ERR($$EZBLD^DIALOG(1404)) Q ;**'NO TEXT' ; S DDWED=1 S DDWISIN=$$ISINSEL() D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) D COPYBUF ; S DDWRSV=DDWRW,DDWCSV=DDWC I DDWR2>DDWA,DDWR2-DDWADDWMR,DDWR1-DDWA>DDWRW S DDWADJ=0 ; D DELBLK^DDW9(.DDWNDEL) D:$D(DDWADJ) POS(DDWRSV-(DDWADJ*DDWNDEL),DDWCSV,"RN") D:'DDWISIN PASTE() Q ; COPY() ;Copy selected text N DDWC1,DDWC2,DDWISIN,DDWR1,DDWR2 I '$D(DDWMARK) D ERR($$EZBLD^DIALOG(1404)) Q ;**'NO TEXT' ; S DDWISIN=$$ISINSEL() D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) D COPYBUF D UNMARK^DDW7 D:'DDWISIN PASTE() Q ; COPYBUF ;Copy selected text to buffer N DDWND,DDWI,DDWX,DDWX1,DDWX2 K ^TMP("DDWB",$J) S DDWND=0 ; D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;** ; F DDWI=DDWR1:1:$$MIN(DDWA,DDWR2) D . S DDWND=DDWND+1 . S DDWX=^TMP("DDW",$J,DDWI) . S DDWX=$E(DDWX,$S(DDWI=DDWR1:DDWC1,1:1),$S(DDWI=DDWR2:DDWC2,1:999)) . S ^TMP("DDWB",$J,DDWND)=DDWX ; F DDWI=$$MAX(DDWR1-DDWA,1):1:$$MIN(DDWR2-DDWA,DDWMR) D . S DDWX=$E(DDWL(DDWI),$S(DDWI+DDWA=DDWR1:DDWC1,1:1),$S(DDWI+DDWA=DDWR2:DDWC2,1:999)) . S DDWND=DDWND+1 . S ^TMP("DDWB",$J,DDWND)=DDWX ; S DDWX1=$$RTOSTB(DDWR1),DDWX2=$$RTOSTB(DDWR2) F DDWI=$$MIN(DDWSTB,DDWX1):-1:DDWX2 D . S DDWND=DDWND+1 . S DDWX=^TMP("DDW1",$J,DDWI) . S DDWX=$E(DDWX,$S(DDWI=DDWX1:DDWC1,1:1),$S(DDWI=DDWX2:DDWC2,1:999)) . S ^TMP("DDWB",$J,DDWND)=DDWX ; D:DDWR2-DDWR1>50 MSG^DDW() Q ; PASTE() ;Paste text I $D(DDWMARK) D ERR("You curently have text selected.") Q I '$D(^TMP("DDWB",$J)) D ERR($$EZBLD^DIALOG(1404)) Q ;** ; S DDWED=1 N DDWBSIZ,DDWFC,DDWI,DDWLST,DDWNSV,DDWTXT,DDWX S DDWBSIZ=$O(^TMP("DDWB",$J,""),-1) ; S DDWTXT=1 S:$L(DDWN)+1IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; ISINSEL() ;Is the cursor within the selected text N DDWI,DDWY S DDWI=DDWRW+DDWA,DDWY=0 I DDWI<$P(DDWMARK,U) E I DDWI>$P(DDWMARK,U,3) E I DDWI=$P(DDWMARK,U),DDWC<$P(DDWMARK,U,2) E I DDWI=$P(DDWMARK,U,3),DDWC-1>$P(DDWMARK,U,4) E S DDWY=1 Q DDWY ; PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK) S R1=$P(M,U),C1=$P(M,U,2) S R2=$P(M,U,3),C2=$P(M,U,4) Q ; ERR(DDWX) ; D MSG^DDW($C(7)_DDWX) H 2 D MSG^DDW() D CUP(DDWRW,DDWC-DDWOFS) F R *DDWX:0 E Q Q ; TR(X) ;Strip trailing blanks Q:$G(X)="" X N I F I=$L(X):-1:0 Q:$E(X,I)'=" " Q $E(X,1,I) ; LD(X) ;Strip leading blanks Q:$G(X)="" X N I F I=1:1:$L(X)+1 Q:$E(X,I)'=" " Q $E(X,I,999) ; RTOSTB(R) ;Return node in STB given line # Q DDWSTB+DDWA+DDWMR+1-R ; SCR(C) ;Return screen number Q C-$P(DDWOFS,U,2)-1\$P(DDWOFS,U,3)+1 ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDW9 DDW9 ;SFISC/MKO-MARK TEXT ;12:20 PM 24 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CHKDEL(DDWY) ;Check that cursor is on block and delete N DDWI N DDWC1,DDWC2,DDWR1,DDWR2,DDWI D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) S DDWY=0,DDWI=DDWRW+DDWA Q:DDWIDDWR2 I DDWI=DDWR1,DDWCDDWC2 D UNMARK^DDW7 Q ; D DELBLK() S DDWY=1 Q ; DELBLK(DDWNDEL) ;Delete block ;Returns: DDWNDEL=# lines deleted from the screen N DDWNP,DDWI,DDWX I '$D(DDWR1) N DDWR1,DDWR2,DDWC1,DDWC2 D . D PMARK(DDWMARK,.DDWR1,.DDWC1,.DDWR2,.DDWC2) ; S DDWNDEL=0,$E(DDWBF,1,3)=111 K DDWMARK ; I DDWR2-DDWA<1 D . D DELABV E I DDWR1-DDWA>DDWMR D . D DELBEL E D DELMID ; D IND^DDW7() Q ; DELABV ;All of the block is above the screen I DDWR1=DDWR2 D Q . N DDWX . S DDWX=^TMP("DDW",$J,DDWR1),$E(DDWX,DDWC1,DDWC2)="" . I DDWX]"" S ^TMP("DDW",$J,DDWR1)=DDWX . E D SHIFTA(DDWR1,DDWR1) ; D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;** N DDWFST,DDWLST S DDWFST=$E(^TMP("DDW",$J,DDWR1),1,DDWC1-1) S DDWLST=$E(^TMP("DDW",$J,DDWR2),DDWC2+1,999) I DDWFST]"" S ^TMP("DDW",$J,DDWR1)=DDWFST,DDWFST=DDWR1+1 E S DDWFST=DDWR1 I DDWLST]"" S ^TMP("DDW",$J,DDWR2)=DDWLST,DDWLST=DDWR2-1 E S DDWLST=DDWR2 D SHIFTA(DDWFST,DDWLST) D:DDWR2-DDWR1>50 MSG^DDW() Q ; SHIFTA(DDWA1,DDWA2) ; N DDWNL S DDWNL=DDWA2-DDWA1+1 I DDWA2=DDWA S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; N DDWI F DDWI=DDWA1:1:DDWA-DDWNL S ^TMP("DDW",$J,DDWI)=^TMP("DDW",$J,DDWI+DDWNL) S DDWA=DDWA-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; DELBEL ;All of the block is below the screen N DDWS1,DDWS2 S DDWS1=DDWA+DDWMR+DDWSTB-DDWR1+1,DDWS2=DDWA+DDWMR+DDWSTB-DDWR2+1 I DDWS1=DDWS2 D Q . N DDWX . S DDWX=^TMP("DDW1",$J,DDWS1),$E(DDWX,DDWC1,DDWC2)="" . I DDWX]"" S ^TMP("DDW1",$J,DDWS1)=DDWX . E D SHIFTB(DDWS1,DDWS1) ; D:DDWR2-DDWR1>50 MSG^DDW(" ...") ;** N DDWFST,DDWLST S DDWFST=$E(^TMP("DDW1",$J,DDWS1),1,DDWC1-1) S DDWLST=$E(^TMP("DDW1",$J,DDWS2),DDWC2+1,999) I DDWFST]"" S ^TMP("DDW1",$J,DDWS1)=DDWFST,DDWFST=DDWS1-1 E S DDWFST=DDWS1 I DDWLST]"" S ^TMP("DDW1",$J,DDWS2)=DDWLST,DDWLST=DDWS2+1 E S DDWLST=DDWS2 D SHIFTB(DDWFST,DDWLST) D:DDWR2-DDWR1>50 MSG^DDW() Q ; SHIFTB(DDWS1,DDWS2) ; N DDWNL S DDWNL=DDWS1-DDWS2+1 I DDWS1=DDWSTB S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; N DDWI F DDWI=DDWS2:1:DDWSTB-DDWNL S ^TMP("DDW1",$J,DDWI)=^TMP("DDW1",$J,DDWI+DDWNL) S DDWSTB=DDWSTB-DDWNL,DDWCNT=DDWCNT-DDWNL Q ; DELMID ;A portion of the block appears on the screen I DDWR2-1-DDWA>DDWMR D . S DDWX=DDWR2-(DDWA+DDWMR+1) . S DDWSTB=DDWSTB-DDWX,DDWCNT=DDWCNT-DDWX ; I DDWR2-DDWA>DDWMR D . S DDWX=$E(^TMP("DDW1",$J,DDWSTB),DDWC2+1,999) . I DDWX="" S DDWSTB=DDWSTB-1,DDWCNT=DDWCNT-1 . E S ^TMP("DDW1",$J,DDWSTB)=DDWX ; D POS($$MAX(DDWR1-DDWA,1),$S(DDWR1=DDWR2:DDWC1,1:1),"RN") ; S DDWNP=DDWR2-DDWA'DDWA D . S DDWX=DDWA-DDWR1 . S DDWA=DDWA-DDWX,DDWCNT=DDWCNT-DDWX ; I DDWR1'>DDWA D . S DDWX=$E(^TMP("DDW",$J,DDWA),1,DDWC1-1) . I DDWX="" S DDWA=DDWA-1,DDWCNT=DDWCNT-1 . E S ^TMP("DDW",$J,DDWA)=DDWX ; S:DDWCNT<1 DDWCNT=1 D:DDWRW+DDWA>DDWCNT UP^DDWT1 Q ; PMARK(M,R1,C1,R2,C2) ;Parse M (DDWMARK) S R1=$P(M,U),C1=$P(M,U,2) S R2=$P(M,U,3),C2=$P(M,U,4) Q ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDWC DDWC ;SFISC/MKO-CHANGE (REPLACE) ;02:24 PM 14 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CHG ;Change N DDWOPT D SETUP^DDWC1 F D PROC Q:DDWOPT=-1 D RESTORE^DDWC1 K DDWCHG(1) Q ; PROC ;Main procedure N DDWCOD,DDWT ; D:$D(DDWMARK) UNMARK^DDW7 D EN^DIR0(IOTM+DDWMR,14,30,"",$G(DDWFIND),100,"","","AKTW",.DDWT,.DDWCOD) I DDWT=""!($P(DDWCOD,U)="TO") S DDWOPT=-1 Q S DDWFIND=DDWT,DDWT=$$UC(DDWT) ; K DDWCHG(1) D EN^DIR0(IOTM+DDWMR+1,14,30,"",$G(DDWCHG),100,"","","AKTW",.DDWCHG,.DDWCOD) I $P(DDWCOD,U)="TO" S DDWOPT=-1 Q S:DDWCHG?1L.E DDWCHG(1)=$$UC($E(DDWCHG))_$E(DDWCHG,2,999) ; F D OPT Q:DDWOPT]"" Q ; OPT ;Prompt for and process option W $P(DDGLVID,DDGLDEL,6) F D Q:DDWOPT]"" . D CUP(DDWMR+4,15) W " "_$C(8) . R DDWOPT#1:DTIME E S DDWOPT="Q" Q . I DDWOPT=U S DDWOPT="Q" . I DDWOPT="" S DDWOPT="E" Q . I DDWOPT="?" S DDWOPT="H" Q . S DDWOPT=$$UC(DDWOPT) . I "^F^R^A^Q^"'[(U_DDWOPT_U) W $C(7) S DDWOPT="" D CUP(DDWMR+4,15) W $P(DDGLVID,DDGLDEL,10)_" " D @DDWOPT Q ; F ;Find next D FINDT^DDWF(DDWFIND) S DDWOPT="" Q ; R ;Replace N DDWE I '$D(DDWMARK) D CERR Q D RS(.DDWE) Q:$G(DDWE) D F Q ; RS(DDWE) ;Change selected text N DDWDIF S DDWDIF=$L(DDWCHG)-$P(DDWMARK,U,4)+$P(DDWMARK,U,2)-1 I $L(DDWN)+DDWDIF>245 D Q . S DDWE=1,DDWOPT="" . D MSG($C(7)_$$EZBLD^DIALOG(347)) ;**TOO LONG ; S DDWE=0,DDWED=1 S $E(DDWN,$P(DDWMARK,U,2),$P(DDWMARK,U,4))=$S($E(DDWN,$P(DDWMARK,U,2))?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG) S DDWL(DDWRW)=DDWN D CUP(DDWRW,1) W $P(DDGLCLR,DDGLDEL)_$E(DDWN,1+DDWOFS,IOM+DDWOFS) K DDWMARK D IND^DDW7() D POS(DDWRW,DDWC+DDWDIF,"R") Q ; A ;Change all N DDWE,DDWF,DDWI,DDWND,DDWX D MSG^DDW("...") ;**'CHANGING TEXT' I $D(DDWMARK) D RS(.DDWE) G:$G(DDWE) AEND ; S DDWX=$F($$UC(DDWL(DDWRW)),DDWT,DDWC) I DDWX D . S DDWL(DDWRW)=$$REP(DDWL(DDWRW),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1 . S:$G(DDWE) DDWE=DDWRW+DDWA_U_DDWE ; I '$G(DDWE) F DDWI=DDWRW+1:1:DDWMR D Q:$G(DDWE) . S DDWX=$F($$UC(DDWL(DDWI)),DDWT) . S:DDWX DDWL(DDWI)=$$REP(DDWL(DDWI),DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1 . S:$G(DDWE) DDWE=DDWI+DDWA_U_DDWE ; I '$G(DDWE) F DDWI=DDWSTB:-1:1 D Q:$G(DDWE) . S DDWND=^TMP("DDW1",$J,DDWI) . S DDWX=$F($$UC(DDWND),DDWT) . S:DDWX ^TMP("DDW1",$J,DDWI)=$$REP(DDWND,DDWFIND,.DDWCHG,DDWX,.DDWE),DDWF=1 . S:$G(DDWE) DDWE=DDWA+DDWMR+DDWSTB-DDWI+1_U_DDWE ; I $G(DDWF) D TOOLONG . D:$G(DDWE) MSG^DDW($C(7)_$$EZBLD^DIALOG(347)) H 2 ;** . F DDWI=1:1:$$MIN(DDWMR,DDWCNT-DDWA) D .. D CUP(DDWI,1) .. W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) . D:$G(DDWE) LINE^DDWG(+DDWE,1),POS(DDWRW,$P(DDWE,U,2),"R") E D MSG^DDW("Text not found.") H 2 D FLUSH ; AEND D MSG^DDW(),CUP(DDWRW,DDWC) S DDWOPT=$S($G(DDWE):-1,1:"") Q ; REP(DDWND,DDWFIND,DDWCHG,DDWX,DDWE) ;String replacement of DDWND N DDWDIF,DDWFST,DDWSV S DDWDIF=$L(DDWCHG)-$L(DDWFIND) F D Q:'DDWX!$G(DDWE) . S DDWSV=DDWND,DDWFST=DDWX-$L(DDWFIND) . I $L(DDWND)+DDWDIF>245 S DDWE=DDWFST Q . S $E(DDWND,DDWFST,DDWX-1)=$S($E(DDWND,DDWFST)?1U:$G(DDWCHG(1),DDWCHG),1:DDWCHG) . S DDWX=DDWX+DDWDIF . S DDWX=$F($$UC(DDWND),DDWFIND,DDWX) Q $S($G(DDWE):DDWSV,1:DDWND) ; E ;Edit Find D FLUSH Q ; Q ;Quit option D FLUSH S DDWOPT=-1 Q ; H ;Help D MSG("Press the highlighted letter of one of the Options.") S DDWOPT="" Q ; CERR ;The Change options are disabled D MSG($C(7)_"You must Find the text before you can Change it.") S DDWOPT="" Q ; MSG(DDWX) ; D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL)_$G(DDWX) H 2 D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL) D FLUSH Q ; FLUSH ;Flush read buffer N DDWX F R *DDWX:0 E Q Q ; UC(X) ;Return uppercase of X Q $$UP^DILIBF(X) ;** ; MIN(X,Y) ; Q $S(XIOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWC1 DDWC1 ;SFISC/MKO-CHANGE ;04:37 PM 24 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SETUP ;Setup new scrolling region N DDWI F DDWI=$$MIN(DDWMR,DDWCNT-DDWA):-1:DDWMR-4 D . S DDWSTB=DDWSTB+1,^TMP("DDW1",$J,DDWSTB)=DDWL(DDWI) S IOBM=IOBM-5,DDWMR=DDWMR-5 W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2) ; ;Print dialog box N DDWR0,DDWR1 S DDWR1=$P(DDGLVID,DDGLDEL,6),DDWR0=$P(DDGLVID,DDGLDEL,10) ; D CUP(DDWMR+1,1) W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2),! FIND D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_" "_$$EZBLD^DIALOG(8126) ;**'FIND WHAT:' D CUP(DDWMR+3,1) W $P(DDGLCLR,DDGLDEL)_$$EZBLD^DIALOG(8126.1)_$G(DDWCHG) ;**'REPLACE WITH:' D CUP(DDWMR+4,1) W $P(DDGLCLR,DDGLDEL)_" Option:"_$P(DDGLCLR,DDGLDEL)_$J("",20)_DDWR1_"F"_DDWR0_"ind Next "_DDWR1_"R"_DDWR0_"eplace Replace "_DDWR1_"A"_DDWR0_"ll "_DDWR1_"Q"_DDWR0_"uit" D CUP(DDWMR+5,1) W $P(DDGLCLR,DDGLDEL) Q ; RESTORE ;Restore original scrolling region N DDWI S IOBM=IOBM+5,DDWMR=DDWMR+5 W:$P(DDGLED,DDGLDEL,2)]"" @$P(DDGLED,DDGLDEL,2) F DDWI=DDWMR-4:1:DDWMR D . I DDWI+DDWA'>DDWCNT D .. S DDWL(DDWI)=^TMP("DDW1",$J,DDWSTB),DDWSTB=DDWSTB-1 . E S DDWL(DDWI)="" . D CUP(DDWI,1) . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) . D POS(DDWRW,DDWC,"RN") Q ; MIN(X,Y) ; Q $S(XIOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWF DDWF ;SFISC/MKO-FIND, REPLACE ;02:43 PM 24 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; NEXT ;Find next occurrence of same text N DDWT G:$G(DDWFIND)="" FIND S DDWT=DDWFIND D FINDT(DDWT,$G(DDWFIND(1))) Q ; FIND ;Prompt and find text N DDWCOD,DDWF,DDWT D ASK^DDWG(3,$$EZBLD^DIALOG(8126),30,$G(DDWFIND),"","",.DDWT,.DDWCOD) ;**'FIND WHAT: ' Q:DDWT="" D FINDT(DDWT,$P($G(DDWCOD),U)="U") Q ; FINDT(DDWT,DDWBACK) ;Find DDWT D:$D(DDWMARK) UNMARK^DDW7 S DDWFIND=DDWT,DDWT=$$UC(DDWT) I $G(DDWBACK) D . S DDWFIND(1)=1 D LOOKB E K DDWFIND(1) D LOOK Q ; LOOK ;Look in arrays N DDWF,DDWI,DDWX S DDWF=$F($$UC(DDWL(DDWRW)),DDWT,DDWC) I DDWF D REPOS(DDWRW+DDWA,DDWF,DDWT) Q ; F DDWI=DDWRW+1:1:DDWMR D Q:DDWF . S DDWX=$F($$UC(DDWL(DDWI)),DDWT) . I DDWX D REPOS(DDWI+DDWA,DDWX,DDWT) S DDWF=1 Q:DDWF ; D MSG^DDW(" ...") ;** F DDWI=DDWSTB:-1:1 D Q:DDWF . S DDWX=$F($$UC(^TMP("DDW1",$J,DDWI)),DDWT) . I DDWX D .. D MSG^DDW() .. D REPOS(DDWA+DDWMR+DDWSTB-DDWI+1,DDWX,DDWT) .. S DDWF=1 Q:DDWF ; D MSG^DDW($$EZBLD^DIALOG(8127)) H 2 ;**'TEXT NOT FOUND' D MSG^DDW(),CUP(DDWRW,DDWC) F R *DDWX:0 E Q Q ; LOOKB ;Look backward in arrays N DDWF,DDWI,DDWX S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-1),DDWT) I DDWF=DDWC S DDWF=$$RF($E($$UC(DDWL(DDWRW)),1,DDWC-$L(DDWT)-1),DDWT) I DDWF D REPOS(DDWRW+DDWA,DDWF,DDWT) Q ; F DDWI=DDWRW-1:-1:1 D Q:DDWF . S DDWX=$$RF($$UC(DDWL(DDWI)),DDWT) . I DDWX D REPOS(DDWI+DDWA,DDWX,DDWT) S DDWF=1 Q:DDWF ; D MSG^DDW(" ...") ;** F DDWI=DDWA:-1:1 D Q:DDWF . S DDWX=$$RF($$UC(^TMP("DDW",$J,DDWI)),DDWT) . I DDWX D .. D MSG^DDW() .. D REPOS(DDWI,DDWX,DDWT) .. S DDWF=1 Q:DDWF ; D MSG^DDW($$EZBLD^DIALOG(8127)) H 2 ;**'TEXT NOT FOUND' D MSG^DDW(),CUP(DDWRW,DDWC) F R *DDWX:0 E Q Q ; REPOS(DDWY,DDWX,DDWT) ;Define DDWMARK, paint if on screen S DDWMARK=DDWY_U_(DDWX-$L(DDWT))_U_DDWY_U_(DDWX-1) I DDWY-DDWA>0,DDWY-DDWA'>DDWMR,DDWX-DDWOFS>0,DDWX-DDWOFS'>IOM D . D PAINT^DDW7(DDWMARK,1) . D POS(DDWY-DDWA,DDWX,"RN") E D LINE^DDWG(DDWY,DDWX) D IND^DDW7(1) Q ; UC(X) ;Return uppercase of X Q $$UP^DILIBF(X) ;** ; RF(X,T) ;Find last occurrence of T in X N Y Q:X'[T 0 S Y=1 F S Y=$F(X,T,Y) Q:'$F(X,T,Y) Q Y ; CUP(Y,X) ;Cursor positioning S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWG DDWG ;SFISC/MKO-GOTO ;05:49 PM 24 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. GOTO ;Go to a specific location N DDWANS,DDWI,DDWHLP D BLD^DIALOG(8140,,,"DDWHLP") ;** D ASK(4,$$EZBLD^DIALOG(7069)_": ",17,"","D VALGTO",.DDWHLP,.DDWANS) ;** I U[DDWANS E I "Ss"[$E(DDWANS)!(DDWANS'?1A.E) D . D GOTOS E I "Ll"[$E(DDWANS) D . D GOTOL E I "Cc"[$E(DDWANS) D . D GOTOC Q ; GOTOS ;Go to a page N DDWS S DDWS=DDWANS S:DDWS?1A.E DDWS=$E(DDWS,2,999) S:DDWS?1P.E DDWS=$E(DDWS,2,999) I DDWANS["+" S DDWS=$$SCREEN+DDWS E I DDWANS["-" S DDWS=$$SCREEN-DDWS I DDWS<1 S DDWS=1 E I DDWS>$$LTOSC(DDWCNT) S DDWS=$$LTOSC(DDWCNT) D LINE(DDWS-1*DDWMR+1) Q ; GOTOL ;Go to a line N DDWLN S DDWLN=DDWANS S:DDWLN?1A.E DDWLN=$E(DDWLN,2,999) S:DDWLN?1P.E DDWLN=$E(DDWLN,2,999) I DDWANS["+" S DDWLN=DDWA+DDWRW+DDWLN E I DDWANS["-" S DDWLN=DDWA+DDWRW-DDWLN I DDWLN<1 S DDWLN=1 E I DDWLN>DDWCNT S DDWLN=DDWCNT D LINE(DDWLN) Q ; GOTOC ;Go to a column N DDWCOL S DDWCOL=DDWANS S:DDWCOL?1A.E DDWCOL=$E(DDWCOL,2,999) S:DDWCOL?1P.E DDWCOL=$E(DDWCOL,2,999) I DDWANS["+" S DDWCOL=DDWC+DDWCOL E I DDWANS["-" S DDWCOL=DDWC-DDWCOL I DDWCOL<1 S DDWCOL=1 E I DDWCOL>246 S DDWCOL=246 D POS(DDWRW,DDWCOL,"R") Q ; LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN I $G(DDWCOL)'="E",'$G(DDWCOL) S DDWCOL=1 S:DDWLN>DDWCNT DDWLN=DDWCNT I DDWLN>DDWA,DDWLN'>(DDWA+DDWMR-1) D . D POS(DDWLN-DDWA,DDWCOL,"RN") E I DDWLN>DDWA D . D SHFTDN^DDW3(DDWLN,DDWCOL),POS(DDWLN-DDWA,DDWCOL,"RN") E D . D SHFTUP^DDW3(DDWLN),POS(1,DDWCOL,"RN") Q ; ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user N DDWI D CUP(DDWMR-DDWLC,1) W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2) F DDWI=DDWMR-DDWLC+1:1:DDWMR D CUP(DDWI,1) W $P(DDGLCLR,DDGLDEL) K DDWANS F D PROMPT Q:$D(DDWANS) ; F DDWI=DDWMR-DDWLC:1:DDWMR D . D CUP(DDWI,1) . W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS) D POS(DDWRW,DDWC,"RN") Q ; PROMPT ;Issue read N DDWERR,DDWX D CUP(DDWMR-DDWLC+1,1) W DDWS_$P(DDGLCLR,DDGLDEL) D EN^DIR0(IOTM+DDWMR-DDWLC-1,$L(DDWS),DDWLEN,1,$G(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD) ; I DDWX?1."?",$D(DDWHLP)>9!($G(DDWHLP)]"") D HELP(.DDWHLP) Q I $G(DDWVAL)]"" X DDWVAL I $D(DDWERR) W $C(7) D HELP(.DDWERR) Q S DDWANS=DDWX Q ; VALGTO ;Validate DDWX N DDWCH Q:U[DDWX S DDWERR=$$EZBLD^DIALOG(1401) ;** Q:DDWX'?.1A.1P1.15N I DDWX?1A.E S DDWCH=$E(DDWX) Q:"SsLlCc"'[DDWCH I DDWX?.E1P.E I DDWX'["+",DDWX'["-" Q K DDWERR Q ; HELP(DDWMSG) ;Print message N DDWI,DDWEC S:$D(DDWMSG)<9 DDWMSG(1)=DDWMSG S DDWEC=$O(DDWMSG(""),-1) F DDWI=2:1:DDWLC D . D CUP(DDWMR-DDWLC+DDWI,1) . W $P(DDGLCLR,DDGLDEL)_$G(DDWMSG(DDWI-DDWLC+DDWEC)) Q ; SCREEN() ;Return current screen Q DDWA+DDWRW-1\DDWMR+1 ; LTOSC(L) ;Convert line number to page number Q L-1\DDWMR+1 ; CUP(Y,X) ;Pos cursor S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q DDWH DDWH ;SFISC/MKO-SCREEN EDITOR HELP ;08:38 AM 23 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. HLP ; N DX,DY,DDWI ; D HLP^DDGLIBH(9211,9214,"DDWH",IOBM+2) D BOX^DDW1 ; S DY=IOTM-1,DX=0 X IOXY F DDWI=1:1:DDWMR W $P(DDGLCLR,DDGLDEL)_$$LINE(DDWI,$G(DDWMARK))_$S(DDWI(DDWR2-DDWA) D . N DDWX1,DDWX2 . S DDWX1=$S(DDWI=(DDWR1-DDWA):DDWC1,1:1) . S DDWX2=$S(DDWI=(DDWR2-DDWA):DDWC2,1:999) . S DDWX=$E(DDWL(DDWI),1+DDWOFS,DDWX1-1)_$P(DDGLVID,DDGLDEL,6)_$E(DDWL(DDWI),$$MAX(DDWX1,1+DDWOFS),$$MIN(DDWX2,IOM+DDWOFS))_$P(DDGLVID,DDGLDEL,10)_$E(DDWL(DDWI),$$MAX(DDWX2+1,1+DDWOFS),IOM+DDWOFS) Q DDWX ; MIN(X,Y) ; Q $S(XY:X,1:Y) DDWK DDWK ;SFISC/MKO-SCREEN EDITOR MAIN ROUTINE ;11:32 AM 25 Aug 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; GETKEY ;Get key sequences and defaults N AU,AD,AR,AL,F1,F2,F3,F4 N FIND,SELECT,INSERT,REMOVE,PREVSC,NEXTSC N A1,A2,A3,I,K,N,T S AU=$P(DDGLKEY,U,2) S AD=$P(DDGLKEY,U,3) S AR=$P(DDGLKEY,U,4) S AL=$P(DDGLKEY,U,5) S F1=$P(DDGLKEY,U,6) S F2=$P(DDGLKEY,U,7) S F3=$P(DDGLKEY,U,8) S F4=$P(DDGLKEY,U,9) S FIND=$P(DDGLKEY,U,10) S SELECT=$P(DDGLKEY,U,11) S INSERT=$P(DDGLKEY,U,12) S REMOVE=$P(DDGLKEY,U,13) S PREVSC=$P(DDGLKEY,U,14) S NEXTSC=$P(DDGLKEY,U,15) ; S A1="DDW(""IN"")",A2="DDW(""OT"")",A3=0 S (DDW("IN"),DDW("OT"))="" F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T="" D . S @("K="_$P(T,";",2)),T=$P(T,";") . I K]"",@A1'[(U_K) D .. I $L(@A1)+$L(K)+2>255!($L(@A2)+$L(T)+1>255) D ... S @A1=@A1_U,$E(@A2,$L(@A2))="" ... S A3=A3+1,A1=$NA(@A1@(A3)),A2=$NA(@A2@(A3)) ... S (@A1,@A2)="" .. S @A1=@A1_U_K .. S @A2=@A2_T_U S @A1=@A1_U,$E(@A2,$L(@A2))="" Q ; MAP ;Keys for main screen ;;UP;AU ;;DN;AD ;;RT;AR ;;LT;AL ;;TAB;$C(9) ;;PUP;F1_AU ;;PUP;PREVSC ;;PDN;F1_AD ;;PDN;NEXTSC ;;JLT;F1_AL ;;JRT;F1_AR ;;LB;FIND ;;LB;F1_F1_AL ;;LE;SELECT ;;LE;F1_F1_AR ;;TOP;F1_"T" ;;BOT;F1_"B" ;;WRT;F1_" " ;;WRT;$C(12) ;;WLT;$C(10) ;;RUB;$C(127) ;;RUB;$C(8) ;;DEL;REMOVE ;;DEL;F4 ;;DEOL;F1_F2 ;;BRK;$C(13) ;;JN;F1_"J" ;;RFT;F1_"R" ;;ST;F1_"?" ;;XLN;F1_"D" ;;TST;F1_$C(9) ;;TSALL;F1_F1_$C(9) ;;LST;F1_"," ;;RST;F1_"." ;;WRM;F2 ;;RPM;INSERT ;;RPM;F3 ;;SV;F1_"S" ;;SW;F1_"A" ;;EX;F1_"E" ;;QT;F1_"Q" ;;QT;$C(5) ;;HLP;F1_"H" ;;DLW;$C(23) ;;MRK;F1_"M" ;;UMK;F1_F1_"M" ;;CUT;F1_"X" ;;CPY;F1_"C" ;;PST;F1_"V" ;;FND;F1_"F" ;;NXT;F1_"N" ;;GTO;F1_"G" ;;CHG;F1_"P" ;;AUT;F1_F1_"S" ;;';$C(27)_"Q" ;;';$C(27)_"R" ;;";$C(27)_"S" ;;";$C(27)_"T" ;; DDWT1 DDWT1 ;SFISC/PD KELTZ,MKO-READ AND PROCESS ;12AUG2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D LOAD^DDW1 K DUOUT I '$G(DDWRWSET) D BOT^DDW3 I $L(DDWN) D BREAK^DDW5() ;GFT -- GO TO BOTTOM OF TEXT F D GETIN Q:$D(DDWFIN) Q ; GETIN ;Get input I DDWC'>DDWRMAR,DDWC-DDWOFS$L(DDWN)!DDWREP,'$D(DDWMARK) D . N DDWANS . D PREAD($$MIN(DDWRMAR,IOM-1+DDWOFS)-DDWC+1,DDWTO,.DDWANS,.DDWQ) . I DDWANS]"" D .. S DDWED=1 .. I DDWSTAT,DDWQ="TO",DDWTO1 D @DDWQ D:DDWSTAT STATUS Q ; DISPL ;Display char I DDWC>245 W $C(7) Q ; S DDWED=1 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7 S:DDWC-1>$L(DDWN) DDWN=DDWN_$J("",DDWC-$L(DDWN)-1) S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)_DDWQ_$E(DDWN,DDWC+DDWREP,999) S DDWC=DDWC+1 ; I DDWREP W DDWQ E D IC . I 0 ;$P(DDGLED,DDGLDEL,5)]"" W $P(DDGLED,DDGLDEL,5)_DDWQ GFT -- DON'T USE "INSERT CHARACTER" IT SEEMS NOT TO WORK . E W DDWQ_$E(DDWN,DDWC,IOM+DDWOFS) D POS(DDWRW,DDWC,"R") D:$L(DDWN)>DDWRMAR WRAP^DDW5 Q ; RUB N DDWX S DDWED=1 I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX ; I DDWC=1 D . I DDWRW=1 D .. I 'DDWA W $C(7) .. E D MVBCK^DDW3(1),POS(1,"E","R") . E D POS(DDWRW-1,"E","RN") E D . S DDWC=DDWC-1,$E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN . S DDWX=$E(DDWN,IOM+DDWOFS) . I DDWC-DDWOFS>0 D .. D CUP(DDWRW,DDWC-DDWOFS) .. I $P(DDGLED,DDGLDEL,6)]"" D ... W $P(DDGLED,DDGLDEL,6) ... I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS) .. E W $E(DDWN_" ",DDWC,IOM+DDWOFS) D CUP(DDWRW,DDWC-DDWOFS) . E D POS(DDWRW,DDWC) Q ; DEL N DDWX S DDWED=1 I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX ; I DDWC>$L(DDWN) D Q . I DDWN?." " D .. N DDWLAST .. S DDWLAST=DDWRW+DDWA=DDWCNT .. D XLINE^DDW5() .. D:DDWLAST POS(DDWRW,"E","R") . E D .. N DDWY,DDWX .. S DDWY=DDWRW+DDWA,DDWX=DDWC .. D JOIN^DDW6 .. D POS(DDWY-DDWA,DDWX,"RN") ; S $E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN,DDWX=$E(DDWN,IOM+DDWOFS) I $P(DDGLED,DDGLDEL,6)]"" D . W $P(DDGLED,DDGLDEL,6) . I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS) E D . W $E(DDWN_" ",DDWC,IOM+DDWOFS) . D CUP(DDWRW,DDWC-DDWOFS) Q ; STATUS N DDWX,DDWS S DDWS="Scr "_(DDWA+DDWRW-1\DDWMR+1)_" of "_(DDWCNT-1\DDWMR+1) S DDWX="Ln "_(DDWA+DDWRW)_" of "_DDWCNT S $E(DDWS,IOM\2+1-($L(DDWX)\2),999)=DDWX S DDWX="Col "_DDWC S $E(DDWS,IOM-$L(DDWX),999)=DDWX D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_DDWS D POS(DDWRW,DDWC) Q ; UP I DDWRW>1 D . D POS(DDWRW-1,DDWC,"RN") E I DDWA D . D MVBCK^DDW3(1) E W $C(7) I DDWC>246,$L(DDWN)<246 D POS(DDWRW,246,"R") Q DN I DDWN="",DDWA+DDWRW>DDWCNT W $C(7) Q ;**GFT DOWN-ARROW: ALLOW GOING TO ENDING BLANK LINE I DDWRW246,$L(DDWN)<246 D POS(DDWRW,246,"R") Q RT I DDWC>245,DDWC>$L(DDWN) W $C(7) E D POS(DDWRW,DDWC+1,"R") Q LT I DDWC=1 D . I DDWRW=1,'DDWA W $C(7) . E D UP,POS(DDWRW,"E","R") E D POS(DDWRW,DDWC-1,"R") Q ; SV K DDWED G SV^DDW1 SW D SAVE^DDW1 S DDWFIN="",DIWESW=1 Q EX D SAVE^DDW1 S DDWFIN="" Q QT S DUOUT=1 G QUIT^DDW1 ;GFT TO D SAVE^DDW1 S DTOUT=1,DDWFIN="" W $C(7) Q HLP D HLP^DDWH,POS(DDWRW,DDWC) Q AUT G AUTOTM^DDW1 ; TST G TSET^DDW2 TSALL G TSALL^DDW2 LST G LSET^DDW2 RST G RSET^DDW2 WRM G WRAPM^DDW2 RPM G REPLM^DDW2 ST G STAT^DDW2 ; TOP G TOP^DDW3 BOT G BOT^DDW3 ; PDN G PGDN^DDW4 PUP G PGUP^DDW4 TAB G TAB^DDW4 JLT G JLEFT^DDW4 JRT G JRIGHT^DDW4 LB G LBEG^DDW4 LE G LEND^DDW4 WRT G WORDR^DDW4 WLT G WORDL^DDW4 DLW S DDWED=1 G DELW^DDW4 DEOL S DDWED=1 G DEOL^DDW4 ; BRK I $G(DDWCNT)>1,$G(DDWN)="",$G(DDWL(DDWRW-1))="",DDWA+DDWRW'127 D HS(.Y) . I Y>31,Y<127 S Y=$C(Y) Q . I Y<0 S Y="TO" Q . D MNE(.Y) Q ; PREAD(DDWLEN,DDWTO,DDWST,Y) ; ;In: DDWLEN = # chars to read ;Out: DDWST = String ; Y = Mnemonic, Null if DDWLEN chars read or invalid X DDGLZOSF("EON") R DDWST#DDWLEN:DDWTO E S Y="TO" Q X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD") ; D:DDWST?.E1.C.E H(.DDWST) ; I $C(Y)?1C,Y D . D MNE(.Y) . I Y=-1 S Y="" . E I $L(Y)=1 W Y S DDWST=DDWST_Y,Y="" E S Y="" Q ; MNE(Y) ;In: Y = Ascii value of first character ;Out: Y = Mnemonic, or -1 if invalid N S,F,T I Y=13 S DDWHLOG=$P($H,",",2) E I Y=10,$D(DDWHLOG)#2,$P($H,",",2)-DDWHLOG<1 K DDWHLOG S Y=-1 Q E K DDWHLOG S S="",F=0,T="DDW(""IN"")" F D MNELOOP(.S,.Y,.T,.F) Q:F Q ; MNELOOP(S,Y,T,F) ;Read more ;In/Out: ; S = string of input chars ; Y = ascii of current char ; T = table under consideration ;Out: ; Y = mnemonic, or -1 ; F = 1 : done ; N E S S=S_$C(Y) I @T'[(U_S) D . I $C(Y)?1L D .. S $E(S,$L(S))=$C(Y-32) .. S:@T'[(U_S_U) E=1 . E S E=1 I $T,$G(E) D Q . S T=$Q(@T) . I T]"" S $E(S,$L(S))="" . E D FLUSH S F=1,Y=-1 ; I @T[(U_S_U),S'=$C(27) D Q . S Y=$P(@$TR(T,"IN","OT"),U,$L($P(@T,U_S_U),U)),F=1 ; R *Y:5 I Y=-1 D FLUSH S F=1 Q ; H(DDWST) ; S DDWST=$TR(DDWST,$C(145,146,147,148),"''""""") I DDWST?.E1.C.E D . N DDWCON,DDWI . S DDWCON="" . F DDWI=128:1:255 S DDWCON=DDWCON_$C(DDWI) . S DDWST=$TR(DDWST,DDWCON,$J(" ",128)) D POS(DDWRW,DDWC) W DDWST Q ; HS(Y) ; I Y>144,Y<149 S Y=$A($E("''""""",Y-144)) E S Y=32 Q ; FLUSH ; N DDWX W $C(7) F R *DDWX:0 E Q Q ; CUP(Y,X) ; S DY=IOTM+Y-2,DX=X-1 X IOXY Q ; POS(R,C,F) ;Pos cursor based on char pos C N DDWX S:$G(C)="E" C=$L($G(DDWL(R)))+1 S:$G(F)["N" DDWN=$G(DDWL(R)) S:$G(F)["R" DDWRW=R,DDWC=C ; S DDWX=C-DDWOFS I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS) S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY Q ; MIN(X,Y) ; Q $S(X" ; DDXPXTNM = Export Template Name ; DDXPTMDL = 0=Export Template SHOULD NOT Be Deleted ; 1=Export Template SHOULD Be Deleted ; DDXPBY = Sort Template Name ; [.]FR = FROM Values as Documentated in DIP ; [.]TO = TO Values as Documentated in DIP ; .DIS = DIS array as Documentated in DIP ; [.]DISTOP = DISTOP array as Documentated in DIP ; IOP = IOP as Documentated in DIP ; DQTIME = DQTIME as Documentated in DIP G EN2^DDXP4 DDXP1 DDXP1 ;SFISC/DPC-CREATE/EDIT FOREIGN FORMAT ;1/8/93 09:09 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN1 ; K DA S DLAYGO=0 GETFF ; W ! S DIC="^DIST(.44,",DIC(0)="QEALMZ" D ^DIC K DIC G:Y=-1 QUIT S DDXPFMNM=$P(Y,U,2),DDXPFMNO=+Y I $P(Y(0),U,9) D USEDFF G:'($D(DA)#2) GETFF EDITFF ; S:'($D(DA)#2) DA=DDXPFMNO S DDSFILE="^DIST(.44,",DR="[DDXP FF FORM1]" D ^DDS QUIT ; K DDXPFMNM,DDXPFMNO,DA,DR,DDSFILE,Y,DLAYGO,X Q USEDFF ; W !!,DDXPFMNM_" foreign format has been used to create an Export Template." W !,"Therefore, its definition cannot be changed.",! S DIR(0)="YA",DIR("A")="Do you want to see the contents of "_DDXPFMNM_" format? ",DIR("B")="NO" D ^DIR K DIR Q:$D(DIRUT) I Y W !! S DIC="^DIST(.44,",DA=DDXPFMNO D EN^DIQ K DIC,DA S DIR(0)="YA",DIR("A")="Do you want to use "_DDXPFMNM_" as the basis for a new format? ",DIR("B")="NO" D ^DIR K DIR Q:$D(DIRUT)!('Y) NEWFF S DIC="^DIST(.44,",DIC(0)="QEAL",DIC("A")="Name for new FOREIGN FORMAT: " W ! D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT))!(X="") I '$P(Y,U,3) W !,$C(7),$P(Y,U,2)_" is already being used.",!,"Please enter a new name for the format.",! G NEWFF S DDXPFMNM=$P(Y,U,2),(DIT("F"),DIT("T"))="^DIST(.44,",DA("F")=DDXPFMNO,(DA("T"),DDXPFMNO)=+Y D EN^DIT0 S DIE="^DIST(.44,",DA=DDXPFMNO,DR="40///0" D ^DIE K DIT,DIE,DR,Y Q ; FORMVAL ; N FLDLM,FIXREC,MSGCNT,ERRMSG,USEQT,MAXLEN,SUBNULL S DDSERROR=0,MSGCNT=1 S FLDLM=$$GET^DDSVAL(DIE,DA,1),FIXREC=$$GET^DDSVAL(DIE,DA,5),USEQT=$$GET^DDSVAL(DIE,DA,8),MAXLEN=$$GET^DDSVAL(DIE,DA,7),SUBNULL=$$GET^DDSVAL(DIE,DA,11) I FIXREC D . I FLDLM]"" D . . S DDSERROR=DDSERROR+1 . . S ERRMSG(MSGCNT)="You cannot specify a record delimiter and",MSGCNT=MSGCNT+1 . . S ERRMSG(MSGCNT)="indicate that record lengths are fixed",MSGCNT=MSGCNT+1 . . S ERRMSG(MSGCNT)="for the same foreign format.",MSGCNT=MSGCNT+1 . . Q . I USEQT D . . S DDSERROR=DDSERROR+1 . . S ERRMSG(MSGCNT)="You cannot choose to have non-numeric fields quoted",MSGCNT=MSGCNT+1 . . S ERRMSG(MSGCNT)="when you are exporting fixed length records.",MSGCNT=MSGCNT+1 . . Q . I MAXLEN>255 D . . S DDSERROR=DDSERROR+1 . . S ERRMSG(MSGCNT)="You cannot set the Maximum Record Length larger than 255 characters ",MSGCNT=MSGCNT+1 . . S ERRMSG(MSGCNT)="when you are defining a fixed record length format.",MSGCNT=MSGCNT+1 . . Q . I SUBNULL]"" D . . S DDSERROR=DDSERROR+1 . . S ERRMSG(MSGCNT)="During fixed length exports, null values will always be exported as nothing.",MSGCNT=MSGCNT+1 . . S ERRMSG(MSGCNT)="So, you cannot specify characters to be substituted for null numeric values.",MSGCNT=MSGCNT+1 . . Q . Q I DDSERROR D . S ERRMSG(MSGCNT)=" ",MSGCNT=MSGCNT+1 . S ERRMSG(MSGCNT)="Please correct "_$S(DDSERROR>1:"these discrepancies.",1:"this discrepancy."),MSGCNT=MSGCNT+1 . S ERRMSG(MSGCNT)="You CANNOT save the form until you correct it!" . Q D:DDSERROR MSG^DDSUTL(.ERRMSG) K:'DDSERROR DDSERROR Q DDXP2 DDXP2 ;SFISC/DPC-SELECTED FIELDS FOR EXPORT ;10/11/94 14:34 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN1 ; N Y,D,DICS D ^DICRW I Y=-1 G QUIT S Q="""",C=",",DC=0,L=1,DI=DIC,DALL(1)=1 W ! D ^DIP2 I $D(DDXPFDTM) S DIE="^DIPT(",DA=DDXPFDTM,DR="8///7" D ^DIE QUIT ; K C,DA,DALL,DC,DI,DIE,DIC,DR,DTOUT,DUOUT,L,Q Q VALALL ; W !,$C(7),"SORRY. When choosing export fields, you cannot use ALL to select all fields.",! S Y=0 K X Q VAL1 ;validates raw user input -- X contains user input S DDXPNG=0 F DDXPCK=";C",";D",";L",";N",";R",";S",";T",";W",";X" D . I X[DDXPCK S DDXPNG=1 W !!,$C(7),"SORRY. You cannot add "_DDXPCK_" to the export field specifications.",! . Q F DDXPCK="+","#","*","&","!" D . I $E(X)=DDXPCK S DDXPNG=1 W !!,$C(7),"SORRY. You cannot choose the "_DDXPCK_" statistical operator when selecting fields for export.",! . Q I $E(X,$L(X))=":" S DDXPNG=1 W !!,$C(7),"SORRY. You cannot jump to another file when selecting fields for export.",! I X[";""" S DDXPNG=1 W !!,$C(7),"SORRY. You cannot enter a custom heading when selecting fields for export." K:DDXPNG X K DDXPNG,DDXPCK Q VAL2 ;validates found field -- Y(0) contains 0-node of field DD S DDXPNG=0 S %=+$P(Y(0),U,2) I '% G VAL2OUT I $P($G(^DD(%,.01,0)),U,2)["W" S DDXPNG=1 W !!,$C(7),"SORRY. You cannot choose a word processing field for export.",! VAL2OUT K:DDXPNG Y(0) K %,DDXPNG Q VAL3 ;validates expression returned from DICOMP -- S contains expression S DDXPNG=0 I S[";W"!(S[";m") S DDXPNG=1 W !!,$C(7),"SORRY. That response is not acceptable when selecting fields for export.",! K:DDXPNG S K DDXPNG Q DDXP3 DDXP3 ;SFISC/DPC-CREATE EXPORT TEMPLATE ;10/14/94 14:56 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN1 ; N DDXPNOUT N T,Q S T="~",Q="""" K ^TMP($J,"DIP") N Y,D,DICS D ^DICRW I Y=-1 G QUIT S DDXPFINO=+Y FLDT ; D FLDTEMP^DDXP33 G:DDXPOUT QUIT FRMT ; S DIC="^DIST(.44,",DIC(0)="QEAMZ" D ^DIC K DIC G:Y=-1 QUIT S DDXPFMNO=+Y,DDXPFMZO=Y(0) XPTEMP ; D XPT^DDXP31 G:DDXPOUT QUIT D FLOAD,CAPDT^DDXP32 G:DDXPOUT QUIT I $P(DDXPFMZO,U,6) D LENGTH^DDXP31 G:DDXPOUT QUIT I $P(DDXPFMZO,U,7) D FLDNAME^DDXP31 G:DDXPOUT QUIT I $P(DDXPFMZO,U,11) D DTYPE^DDXP31 G:DDXPOUT QUIT D SETFLD^DDXP32 I '$P(DDXPFMZO,U,8) D IOM^DDXP31 G:DDXPOUT QUIT S ^DIPT(DDXPXTNO,"IOM")=$G(DDXPIOM) D SETEMP^DDXP32 SETDELM ; I $TR($P(DDXPFMZO,U,2),"ask","ASK")="ASK" D ASKDELM^DDXP31 G:DDXPOUT QUIT S:'$D(DDXPDELM) DDXPDELM=$P(DDXPFMZO,U,2) I DDXPDELM]"" S DDXPDELM=$$BLDELIM(DDXPDELM) TPROC ; S DDXPFONO=1,DDXPFOUT="",DDXPXPOS=1 F DDXPFLD=1:1:DDXPTOTF D . S (DDXPNPC,DDXPRNPC)=^TMP($J,"TIN",DDXPFLD) . I $P(DDXPFMZO,U,10),'DDXPNOUT(DDXPFLD) D QUOT^DDXP32 . I $P(DDXPFMZO,U,6) D FIXLEN . I '$P(DDXPFMZO,U,6),((DDXPFLD'=1)!(DDXPNPC'=DDXPRNPC)) D RUNON . I $P(DDXPFMZO,U,10),'DDXPNOUT(DDXPFLD) D QUOT^DDXP32 . I DDXPDELM]"",'DDXPNOUT(DDXPFLD) D DELIM . D FPROC . Q RECPROC ; I '$P(DDXPFMZO,U,12),DDXPDELM]"" S DDXPFOUT=$P(DDXPFOUT,T,1,($L(DDXPFOUT,T)-2))_T I $TR($P(DDXPFMZO,U,3),"ask","ASK")="ASK" D ASKRDLM^DDXP31 G:DDXPOUT QUIT S:'$D(DDXPRDLM) DDXPRDLM=$P(DDXPFMZO,U,3) I DDXPRDLM]"" S DDXPRDLM=$$BLDELIM(DDXPRDLM) D RECDELIM D FPROC FINISH ; I DDXPFOUT]"" S ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT S DIE="^DIST(.44,",DA=DDXPFMNO,DR="40///1" D ^DIE S DIE="^DIPT(",DA=DDXPFDTM,DR="110///1" D ^DIE K DIE,DA,DR W !!,?10,"Export Template created.",! I $G(DDXPTMDL) D . S DIK="^DIPT(",DA=DDXPFDTM D ^DIK K DIK,DA . W ?10,"Selected Fields template "_DDXPFDNM_" deleted.",! . Q G DONE QUIT ; W !!,?10,"Export Template NOT created!!" I $G(DDXPTMDL) W !,?10,"Selected Fields template "_DDXPFDNM_" not deleted." I $D(DDXPXTNO) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA DONE ; K X,Y,DDXPDELM,DDXPDT,DDXPFDTM,DDXPFCAP,DDXPFFNM,DDXPFIN,DDXPFINO,DDXPFLD,DDXPIOM,DDXPFLEN,DDXPFMNO,DDXPFMZO,DDXPFONO,DDXPTLEN,DDXPTMDL K DDXPFDNM,DDXPFOUT,DDXPLNMX,DDXPRNPC,DDXPNPC,DDXPOUT,DDXPTIN,DDXPATH,DDXPTOTF,DDXPXPOS,DDXPXTNM,DDXPXTNO,DDXPRDLM,Q,T,DTOUT,DUOUT,DIRUT K ^TMP($J,"DIP") Q FLOAD ; S DDXPFLD=0 F FIN=0:0 S FIN=$O(^DIPT(DDXPFDTM,"F",FIN)) Q:FIN="" S DDXPFIN=^(FIN) D . F TCNT=1:1 S DDXPTIN=$P(DDXPFIN,T,TCNT) Q:DDXPTIN="" D . . S DDXPFLD=DDXPFLD+1 . . S ^TMP($J,"TIN",DDXPFLD)=DDXPTIN . . S DDXPNOUT(DDXPFLD)=$$NOUT(DDXPTIN) . . Q . Q S DDXPTOTF=DDXPFLD K FIN,TCNT Q FIXLEN ; S DDXPLNMX=$S(+$P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(DDXPIOM):DDXPIOM,1:80) I DDXPXPOS+DDXPFLEN(DDXPFLD)>(DDXPLNMX+1) S DDXPXPOS=1 S DDXPNPC=DDXPNPC_";L"_DDXPFLEN(DDXPFLD)_";C"_DDXPXPOS S DDXPXPOS=DDXPXPOS+DDXPFLEN(DDXPFLD) Q RUNON ; S DDXPNPC=DDXPNPC_";X" Q DELIM ; S DDXPNPC=DDXPNPC_T_"W $C("_DDXPDELM_")" I '$P(DDXPFMZO,U,6) D RUNON Q RECDELIM ; S DDXPNPC="W $C("_DDXPRDLM_")" I '$P(DDXPFMZO,U,6) D RUNON Q BLDELIM(%) ; N CHAR,DELM I +% S DELM=% G BLDOUT S DELM=$A(%) F CHAR=2:1 Q:$E(%,CHAR)="" S DELM=DELM_","_$A($E(%,CHAR)) BLDOUT Q DELM FPROC ; I $L(DDXPFOUT)+$L(DDXPNPC)<220 S DDXPFOUT=DDXPFOUT_DDXPNPC_T Q S ^DIPT(DDXPXTNO,"F",DDXPFONO)=DDXPFOUT S DDXPFOUT=DDXPNPC_T,DDXPFONO=DDXPFONO+1 Q ; NOUT(DDXPTIN) ; I DDXPTIN["SETDATA"!(DDXPTIN["SETPARAM") Q 1 Q 0 DDXP31 DDXP31 ;SFISC/DPC-CREATE EXPORT TEMPLATE ;30SEP2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. XPT ; N DIC,DIR,DLAYGO W ! S DDXPOUT=0 ;S DIR(0)="F^2:30",DIR("A")="Enter name for EXPORT Template" ;S DIR("?",1)="Enter the name of the Export Template to be produced.",DIR("?",2)="The name must be from 2 to 30 characters." ;,DIR("?")="The new Export Template cannot overwrite an existing Print Template file entry." ;D ^DIR ;I $D(DIRUT) S DDXPOUT=1 Q S DIC("S")="I $P(^(0),U,8)=3,$P(^(0),U,4)=DDXPFINO,$P(^(0),U,5)=DUZ!'$P(^(0),U,5)" ;**GFT Let them pick one of their own existing EXPORT TEMPLATES for this FILE S DIC="^DIPT(",DIC(0)="AOVELZ",DLAYGO=0 W ! D ^DIC I Y<0 S DDXPOUT=1 Q I '$P(Y,U,3) S $P(^(0),U,4)="",X=0 F S X=$O(^(X)) Q:X="" K ^(X) ;Throw away FILE so it can be stuffed back. throw away rest of Template ;'$P(Y,U,3) W !,$C(7),$P(Y,U,2)_" entry in the Print Template file already exists.",!,"Please enter the name of a new template.",!! G XPT S DDXPXTNO=+Y Q ; LENGTH ; W !!,"This template will produce fixed length records." W !,"Enter the length of each field below." W !,"The specified number should be the length in the TARGET file.",!! D GETOUT Q:DDXPOUT S DDXPTLEN=0 S DIR(0)="N^1:255:0",DIR("?")="Enter a number from 1 to 255 as the length of this field in the TARGET file" F DDXPFLD=1:1:DDXPTOTF D I DDXPOUT Q G LENGTH . I DDXPNOUT(DDXPFLD) S DDXPFLEN(DDXPFLD)=0 Q . S DIR("A")=DDXPFCAP(DDXPFLD),DDXPOUT=0 D ^DIR . I $D(DIRUT) S DDXPOUT=1 Q . S DDXPFLEN(DDXPFLD)=Y,DDXPTLEN=DDXPTLEN+Y . Q K DIR,X,Y Q FLDNAME ; W !!,"Enter the name of the fields below in the TARGET file." W !,"If you press , no name will be used.",!! D GETOUT Q:DDXPOUT S DIR(0)="FO^0:30" S DIR("?")="Enter up to 30 characters as the name of this field in the TARGET file" F DDXPFLD=1:1:DDXPTOTF D I DDXPOUT=1 Q G FLDNAME . I DDXPNOUT(DDXPFLD) Q . S DIR("A")=DDXPFCAP(DDXPFLD),DDXPOUT=0 D ^DIR . I $D(DTOUT)!$D(DUOUT) S DDXPOUT=1 Q . S DDXPFFNM(DDXPFLD)=Y . Q K DIR,X,Y Q DTYPE ; W !!,"Enter the data types of the fields being exported below.",!! D GETOUT Q:DDXPOUT S DIR(0)=".42,1" F DDXPFLD=1:1:DDXPTOTF D I DDXPOUT=1 Q G DTYPE . I DDXPNOUT(DDXPFLD) Q . S DIR("A")=DDXPFCAP(DDXPFLD),DIR("B")=$P(^DI(.81,DDXPDT(DDXPFLD),0),U,1),DDXPOUT=0 D ^DIR . I $D(DIRUT) S DDXPOUT=1 Q . S DDXPDT(DDXPFLD)=+Y . Q K DIR,X,Y Q IOM ; S DDXPOUT=0 W !!,"Enter the maximum length of a physical record that can be exported.",!,"Enter '^' to stop the creation of an EXPORT template.",! I $D(DDXPTLEN) D . W "The default shown is based on the total lengths of the fields being exported.",! . S DIR("B")=DDXPTLEN+1 . Q RIOM S DIR(0)=".44,7" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S DDXPOUT=1 Q I Y>255,$P(DDXPFMZO,U,6) W !!,$C(7),"The length cannot be greater than 255 when sending fixed length records.",! G RIOM S DDXPIOM=Y Q ; ASKDELM ; S DDXPOUT=0 W !!,"You can choose a delimiter to be placed between output fields.",!,"Enter to use no delimiter.",!,"Enter '^' to stop the creation of an EXPORT template.",! S DIR(0)=".44,1" D ^DIR K DIR I $D(DUOUT)!$D(DTOUT) S DDXPOUT=1 Q S:X="@" Y=X S DDXPDELM=Y Q ASKRDLM ; S DDXPOUT=0 W !!,"You can choose a delimiter to be placed between output records.",!,"Enter to use no delimiter",!,"Enter '^' to stop the creation of an EXPORT template.",! S DIR(0)=".44,2" D ^DIR K DIR I $D(DUOUT)!$D(DTOUT) S DDXPOUT=1 Q S:X="@" Y=X S DDXPRDLM=Y Q GETOUT ;To see if user wants to continue. S DDXPOUT=0 W "Do you want to continue?" S DIR(0)="Y",DIR("B")="YES" S DIR("?")="If you do not give this information, an EXPORT template will NOT be created." D ^DIR K DIR I $D(DIRUT)!'Y S DDXPOUT=1 Q W !! Q DDXP32 DDXP32 ;SFISC/DPC-CREATE EXPORT TEMPLATE (CONT) ;12:44 PM 7 Jun 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CAPDT ; K DDXPFCAP,DDXPDT,DDXPATH N FCAP,NUMPC,C S C="," F DDXPCNDX=1:1:DDXPTOTF D . I DDXPNOUT(DDXPCNDX) Q . S DDXPX=^TMP($J,"TIN",DDXPCNDX),DDXPTGFL=DDXPFINO,NUMPC=0 K FCAP . D FLDFIND . S DDXPFCAP(DDXPCNDX)=FCAP(NUMPC) . F NUMPC=NUMPC-1:-1 Q:'$D(FCAP(NUMPC)) D . . S DDXPFCAP(DDXPCNDX)=DDXPFCAP(DDXPCNDX)_" in "_FCAP(NUMPC)_" subfile" . . Q . K FCAP,NUMPC . Q I $D(DDXPATH) D MULTVER K DDXPX,DDXPCNDX,DDXPTGFL,DDXPDD0 Q FLDFIND ; S NUMPC=NUMPC+1 I DDXPX=0 D Q . S FCAP(NUMPC)="NUMBER",DDXPDT(DDXPCNDX)=4 . Q I +DDXPX D . S DDXPDD0="^DD("_DDXPTGFL_","_+DDXPX_",0)" . Q I DDXPX=+DDXPX D Q . S FCAP(NUMPC)=$P(@DDXPDD0,U,1) . S %=$P(@DDXPDD0,U,2),DDXPDT(DDXPCNDX)=$S(%["D":1,%["N":2,1:4) K % . Q I '+DDXPX D Q . S DDXPDT(DDXPCNDX)=4 . I $E(DDXPX)=Q S FCAP(NUMPC)=DDXPX Q . S %=$P(DDXPX,";Z;",2),%=$P(%,Q,2,99),%=$P(%,";",1),FCAP(NUMPC)=$E(%,1,($L(%)-1)) K % . Q MULT ; S FCAP(NUMPC)=$P(@DDXPDD0,U,1) S DDXPTGFL=+$P(@DDXPDD0,U,2) I NUMPC=1 D . N %,I,DONE S %=$P(DDXPX,C,1,$L(DDXPX,C)-1),DONE=0 . F I=2:1:$L(DDXPX,C) Q:DONE D . . Q:+$P(%,C,I) . . S %=$P(%,C,1,I-1),DONE=1 . . Q . S DDXPATH(DDXPCNDX)=% . Q S DDXPX=$P(DDXPX,C,2,99) G FLDFIND SETFLD ; S %L=$S($D(DDXPFLEN):";2///^S X=DDXPFLEN(DDXPFLD)",1:"") S %F=$S($D(DDXPFFNM):";3///^S X=DDXPFFNM(DDXPFLD)",1:"") S (DIC,DIE)="^DIPT("_DDXPXTNO_",100,",DA(1)=DDXPXTNO,DIC("P")=$P(^DD(.4,100,0),U,2),DIC(0)="L" K DO F DDXPFLD=1:1:DDXPTOTF D . I DDXPNOUT(DDXPFLD) Q . S (DINUM,X)=DDXPFLD K DD D FILE^DICN . S DA=DDXPFLD,DR="1////^S X=DDXPDT(DDXPFLD)"_%L_%F D ^DIE . Q K DIE,DIC,X,Y,DA,DR,%L,%F Q SETEMP ; S DR="2///NOW;4///"_DDXPFINO_";5///"_DUZ_";8///3;105////"_DDXPFMNO S:$G(DDXPATH) DR=DR_";115///"_DDXPATH S DA=DDXPXTNO,DIE="^DIPT(" D ^DIE K DIE,DA,DR ; Hard Set ReadAccess and WriteAccess I $D(^DIPT(DDXPXTNO,0))#2,$D(DUZ(0))#2 D . S $P(^DIPT(DDXPXTNO,0),U,3)=DUZ(0) ; Read Access . S $P(^DIPT(DDXPXTNO,0),U,6)=DUZ(0) ; Write Access S %X="^DIPT("_DDXPFDTM_",""DXS"",",%Y="^DIPT("_DDXPXTNO_",""DXS""," D %XY^%RCR K %X,%Y S ^DIPT(DDXPXTNO,"SUB")=1 S ^DIPT(DDXPXTNO,"H")="@@" Q MULTVER ; N I,MP,LP,MPC,LPC,NOMATCH S LP="",NOMATCH=0 F I=1:1:DDXPTOTF D Q:NOMATCH . S MP=$G(DDXPATH(I)) Q:'MP . I LP=MP Q . I 'LP S LP=MP Q . S LPC=$L(LP,C),MPC=$L(MP,C) . I LPC=MPC S NOMATCH=1 Q . I LPC>MPC D Q . . I MP=$P(LP,C,1,MPC) Q . . S NOMATCH=1 . . Q . I LP=$P(MP,C,1,LPC) S LP=MP Q . S NOMATCH=1 . Q I 'NOMATCH S DDXPATH=LP Q W !!,$C(7),"The "_DDXPFDNM_" template has fields in more than one multiple path." W !,"Therefore, export of the data will not succeed." W !,"Refer to the VA FileMan User Manual for more details.",! S DDXPOUT=1 Q QUOT ; N QPC,Q1ST I DDXPDT(DDXPFLD)=2 Q S Q1ST=$S(DDXPNPC=DDXPRNPC:1,1:0) S QPC="W $C(34)"_$S(Q1ST&(DDXPFLD=1):"",1:";X") I Q1ST S DDXPNPC=QPC_T_DDXPNPC E S DDXPNPC=DDXPNPC_T_QPC Q DDXP33 DDXP33 ;SFISC/DPC - CREATE EXPORT TEMPLATE (CONT) ;12:45 PM 7 Jun 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FLDTEMP ; S DDXPOUT=0 S DIC="^DIPT(",DIC(0)="QEASZ",DIC("S")="I $P(^(0),U,8)=7",DIC("A")="Enter SELECTED EXPORT FIELDS Template: ",D="F"_DDXPFINO W ! D IX^DIC K DIC,D I Y=-1 S DDXPOUT=1 Q S DDXPFDTM=+Y,DDXPFDNM=$P(Y,U,2) N DDXPY S DDXPY=Y(0) D SHOWFLD G:DDXPOUT FLDTEMP Q SHOWFLD ; W !!,"Do you want to see the fields stored in the "_DDXPFDNM_" template?" S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT) S DDXPOUT=1 Q I Y D Q:DDXPOUT . W ! S D0=DDXPFDTM D ^DIPT K D0 . W !,"Do you want to use this template?" . S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR W ! . I 'Y!$D(DIRUT) S DDXPOUT=1 . Q S DDXPTMDL=0 I DUZ(0)[$E($P(DDXPY,U,6),1)!(DUZ(0)="@") D I $D(DIRUT) K DDXPY S DDXPOUT=1 Q . W !!,"Do you want to delete the "_DDXPFDNM_" template" . W !,"after the export template is created?" . S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W ! . S:Y DDXPTMDL=1 . K DDXPY Q DDXP4 DDXP4 ;SFISC/DPC,S0-EXPORT DATA ;7:37 AM 30 May 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN1 ; K ^UTILITY($J) D ^DICRW I Y=-1 G QUIT S DDXPFINO=+Y XTEM ; S DIC="^DIPT(",DIC(0)="QEASZ",DIC("A")="Choose an EXPORT template or '^' to Quit: ",DIC("S")="I $P(^(0),U,8)=3",D="F"_DDXPFINO W ! D IX^DIC K DIC,D I $D(DTOUT)!$D(DUOUT) G QUIT I Y=-1 G XTEM S DDXPXTNO=+Y,DDXPXTNM=$P(Y,U,2),FLDS="["_DDXPXTNM_"]" I DUZ(0)[$E($P(Y(0),U,6),1)!(DUZ(0)="@") D I $D(DIRUT) G QUIT . W !,"Do you want to delete the "_DDXPXTNM_" template",!,"after the data export is complete?",! . S DDXPTMDL=0,DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR W ! . S:Y DDXPTMDL=1 S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0)) I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1 S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY SORS ; W ! S DIR(0)="YA",DIR("B")="NO",DIR("A")="Do you want to SEARCH for entries to be exported? " S DIR("?",1)="To use VA FileMan's SEARCH option to choose entries, answer 'YES'." S:'$D(BY) DIR("?",2)="After the SEARCH, you can respond to VA FileMan's 'SORT BY:' prompt." S DIR("?")="If you answer 'NO', "_$S('$D(BY):"you can only SORT entries before export.",1:"the data export will begin.") D ^DIR K DIR I $D(DIRUT) G QUIT S DDXPSORS=Y,DIC=DDXPFINO,L=0 D DIOBEG,DIOEND I DDXPSORS D EN^DIS I $G(X)="^"!($G(POP)) G QUIT I 'DDXPSORS D EN1^DIP I $G(X)="^"!($G(POP)) G QUIT I $G(DDXPQ),$G(DDXPTMDL) W !,?5,"Export template "_DDXPXTNM_" will be deleted",!,?5,"when queued export is completed." G DONE I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA G DONE QUIT ; W !!,?10,"Export NOT completed!" DONE ; K DDXPFINO,DDXPSORS,DDXPIOM,DDXPIOSL,DDXPXTNO,DDXPXTNM,DDXPFFNO,DDXPFMZO,DDXPCUSR,DDXPDATE,DDXPTMDL,DDXPY,DDXPATH,L,Y,DTOUT,DUOUT,DIRUT,DIC,FLDS,BY,FR,DIOEND,DIOBEG,DDXPQ,X,POP Q ZIS ; S %ZIS="Q" S DDXPIOM=$S($P(DDXPFMZO,U,8):$P(DDXPFMZO,U,8),$G(^DIPT(DDXPXTNO,"IOM")):^("IOM"),1:80) S DDXPIOSL=99999 Q MULTBY ; N NUMPC,I,C S BY="",C=",",NUMPC=$L(DDXPATH,C) W !!,"Since you are exporting fields from multiples," W !,"a sort will be done automatically." W !,"You will NOT have the opportunity to sort the data before export.",! F I=1:1:NUMPC D . S BY=BY_DDXPATH_",NUMBER," . S DDXPATH=$P(DDXPATH,C,1,$L(DDXPATH,C)-1) . Q S BY=$E(BY,1,$L(BY)-1),FR="" Q DIOBEG ; S DDXPBEG=$G(^DIST(.44,DDXPFFNO,1)) I DDXPBEG']"" G QBEG I $E(DDXPBEG)="""" S DIOBEG="W "_DDXPBEG G QBEG S DIOBEG=DDXPBEG QBEG K DDXPBEG Q DIOEND ; S DDXPEND=$G(^DIST(.44,DDXPFFNO,2)) I DDXPEND']"" G QEND I $E(DDXPEND)="""" S DIOEND="W "_DDXPEND G QEND S DIOEND=DDXPEND QEND K DDXPEND Q DJTOPY(Y) ; N BJ,EJ,YOUT,NUMW,TYPEJ,DDXPXORY,SUB S YOUT=Y S BJ=$F(Y,"$J(") I BJ D . S DDXPXORY=$P($E(Y,BJ,999),",",1) . S NUMW=$L($E(Y,1,BJ),"W")-1 I NUMW'>0 Q . S EJ=$F(Y,") ",BJ) . S TYPEJ=$L($E(Y,BJ,$S(EJ:EJ-1,1:999)),",") . I TYPEJ'=2&(TYPEJ'=3) Q . I TYPEJ=3 S SUB="$S("_DDXPXORY_"]"""":+"_DDXPXORY_",1:"""_$P(DDXPFMZO,U,13)_""")" . I TYPEJ=2 S SUB=DDXPXORY . S YOUT=$P($E(Y,1,BJ),"W",1,NUMW)_"W "_SUB_$S(EJ:$E(Y,EJ-1,999),1:"") . Q Q YOUT DT ; N X I 'Y S DDXPY=Y Q S X=Y I $D(^DIST(.44,DDXPFFNO,6)) X ^(6) S DDXPY=$G(Y) Q EN2 ; Export API from EXPORT^DDXP N DDXP,DDXPXTNO,DDPXFFNO,DDXPFMZO,DDXPDATE,DDXPATH,DDXPOUT,ERROR,DIA K ^UTILITY($J) ; Check for valild file number I '$G(DDXPFINO) S ERROR="File Number Missing." D EN2ERR G DONE I DDXPFINO[U D I $D(DDXPOUT) K DDXPOUT G DONE . I $P(DDXPFINO,U)'=1.1 S DDXPOUT=1,ERROR="You can only use the "","" syntax if doing an Export of the Audit File(1.1)" D EN2ERR Q . I '$D(^DIC(+$P(DDXPFINO,U,2),0))#2 S DDXPOUT=1,ERROR="File Does Not Exist on This System." D EN2ERR Q I DDXPFINO'[U,'$D(^DIC(+DDXPFINO,0))#2 S ERROR="File Does Not Exist on This System." D EN2ERR G DONE N DIC,D,X S DIC="^DIPT(",DIC(0)="SZ",DIC("S")="I $P(^(0),U,8)=3",D="F"_+DDXPFINO,X=DDXPXTNM D IX^DIC K DIC I Y<0 S ERROR="The Template is Not an Export Template or Is Missing." D EN2ERR G DONE S DDXPXTNO=+Y S DDXPFFNO=+$G(^DIPT(DDXPXTNO,105)),DDXPFMZO=$G(^DIST(.44,DDXPFFNO,0)) I $G(^DIST(.44,DDXPFFNO,6))]"" S DDXPDATE=1 I $G(DDXPBY)="" S DDXPATH=$P($G(^DIPT(DDXPXTNO,105)),U,4) I DDXPATH]"" D MULTBY ; Setup For Sort Template If BY NOT Setup by MULTBY I '$D(BY) D I $D(DDXPOUT) K DDXPOUT S ERROR="Sort Template Invalid or Missing." D EN2ERR G DONE . I $G(DDXPBY)]"" D Q:$D(DDXPOUT) .. N DIC,X .. S DIC="^DIBT(",DIC(0)="Z",X=DDXPBY .. D ^DIC K DIC .. I Y<0 S DDXPOUT=1 Q .. D SORTCHK I $D(DDXPOUT) Q .. S BY="["_DDXPBY_"]" S DDXP=4 ; Tell other FileMan routines we are Exporting S DIC=$S(+DDXPFINO=1.1:"^DIA("_+$P(DDXPFINO,U,2)_",",1:+DDXPFINO) S L=0 S FLDS="["_DDXPXTNM_"]" D DIOBEG,DIOEND,EN1^DIP I $G(X)="^"!($G(POP)) K DDXP,DDXPBY,DDXPFR,DDXPTO G QUIT K:$D(DIA) DIA ; **Leaking Variable** I $G(DDXPTMDL) S DIK="^DIPT(",DA=DDXPXTNO D ^DIK K DIK,DA K DDXP,DDXPBY,DDXPFR,DDXPTO G DONE SORTCHK ; Check Sort For Illegal Qualifiers N D0,D1,DDXPX,I S D0=+Y S D1=0 F S D1=$O(^DIBT(D0,2,D1)) Q:D1<1!$D(DDXPOUT) D . S DDXPX=^DIBT(D0,2,D1,0) . F I="#","!","+","@" D Q:$D(DDXPOUT) .. I $P(DDXPX,U,4)[I,I'="@" S DDXPOUT=1,ERROR="You can not use the """_I_""" when exporting." D EN2ERR Q .. I I="@",$P(DDXPX,U,4)["@",$P(DDXPX,U,4)'["@B" S DDXPOUT=1,ERROR="You can not use the ""@"" when exporting." D EN2ERR Q . F I=";C",";S" D Q:$D(DDXPOUT) .. I $P(DDXPX,U,5)[I S DDXPOUT=1,ERROR="You can not use "_I_" when exporting." D EN2ERR Q .. I $P(DDXPX,U,5)[";""" S DDXPOUT=1,ERROR="You can Replace a Caption when exporting." D EN2ERR Q Q EN2ERR ; Error Processing I $D(IOST),$E(IOST,1,2)="C-" W $C(7) W "=>"_ERROR,! K DDXPBY,DDXPFR,DDXPTO,ERROR Q DDXP41 DDXP41 ;SFISC/DPC-EXPORT DATA (CONT) ;1/8/93 09:18 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SORTVAL ; N DDXPNG,CHK S DDXPNG=0 F CHK="#","!","+","@" D . I $E(X)=CHK S DDXPNG=1 W !!,$C(7),"SORRY. You cannot use the "_CHK_" sort qualifier when exporting data.",! . Q F CHK=";C",";S" D . I X[CHK S DDXPNG=1 W !!,$C(7),"SORRY. Using "_CHK_" will have no effect when exporting data.",! . Q I X[";""" S DDXPNG=1 W !!,$C(7),"SORRY. You cannot replace a caption with a literal when exporting data.",! K:DDXPNG X Q DDXP5 DDXP5 ;SFISC/DPC-PRINT FOREIGN FORMAT DOC ;12/17/92 10:15 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN1 ; N SEL,CHOICE,OUT,NOMORE K DIS S DIR(0)="SM^1:Only print selected foreign formats;2:Print all foreign formats" D ^DIR K DIR Q:$D(DIRUT) S SEL=Y,OUT=0 I SEL=1 D Q:$G(CHOICE)=1 . S DIC="^DIST(.44,",DIC(0)="QEAM",NOMORE=0 . F CHOICE=1:1 D Q:OUT . . W ! D ^DIC I Y=-1 S OUT=1 Q . . S DIS(CHOICE)="I D0="_+Y . . Q . K DIC . Q S DIC="^DIST(.44,",L=0,FLDS="[DDXP FORMAT DOC]",DHD="[DDXP FORMAT DOC HDR]",BY="NAME;S2;C1",FR="" W ! D EN1^DIP K Y,DIRUT Q DDXPLIB DDXPLIB ;SFISC/DPC-EXPORT LIBRARY ;1/25/93 13:05 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FLDNM(DDXPXTNO) ; N %D,%I,FLD,NAMELST,NAME S NAMELST="" S %D=$P($G(^DIST(.44,+$G(^DIPT(DDXPXTNO,105)),0)),U,2) S %D=$$BLDELIM^DDXP3(%D) S %D=$C(%D),FLD=0 F %I=0:1 S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1 D . S NAME=$P(^DIPT(DDXPXTNO,100,FLD,0),U,4) . S NAMELST=NAMELST_NAME_%D . Q S NAMELST=$P(NAMELST,%D,1,%I) Q NAMELST ; DP123(DDXPXTNO) ; N FLD,FLDZO,DPLN,I,DT,LEN,DTCHAR S DPLN="" F FLD=0:0 S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1 S FLDZO=^(FLD,0) D . S DT=$P(FLDZO,U,2) . S LEN=$P(FLDZO,U,3) . S DTCHAR=$S(DT=4:"L",DT=2:"V",DT=1:"D",1:"L") . S DPLN=DPLN_DTCHAR . F I=1:1:LEN-1 S DPLN=DPLN_">" . Q Q DPLN ; DPXCEL(DDXPXTNO) ; N DPLN,FLD,FLDZO,LEN,I S DPLN="" F FLD=0:0 S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1 S FLDZO=^(FLD,0) D . S LEN=$P(FLDZO,U,3) . S DPLN=DPLN_"|" . F I=1:1:LEN-1 S DPLN=DPLN_" " . Q Q DPLN ; SASCOL ; N INPUTLN,FLD,NAME,DTYPE,DTYPEFOR,START,END,LENGTH,FLD0 S INPUTLN="INPUT ",START=1,FLD=0 F S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1 S FLD0=^(FLD,0) D . S NAME=$P(FLD0,U,4)_" ",LENGTH=$P(FLD0,U,3),DTYPE=$P(FLD0,U,2) . S DTYPEFOR=$S(DTYPE=4:"$ ",DTYPE=1:"YYMMDD"_LENGTH_". ",1:"") . S END=START+LENGTH-1 . S INPUTLN=INPUTLN_NAME_DTYPEFOR_$S(DTYPE=1:"",1:START_"-"_END_" ") . S START=END+1 . Q S INPUTLN=$E(INPUTLN,1,$L(INPUTLN)-1)_";" W INPUTLN,!,"CARDS;" Q ; ORACTL ; N FLD,FLD0,DELIM,NAME,LENGTH,DTYPEFRM,END,START,POS S FLD=0,DELIM=$P(^DIST(.44,DDXPFFNO,0),U,2),START=1,POS="" W "LOAD DATA",! W "INFILE *",! W "APPEND",! W "INTO TABLE "_$TR($P(^DIPT(DDXPXTNO,0),U,1)," ","_"),! W:DELIM]"" "FIELDS TERMINATED BY '"_DELIM_"' OPTIONALLY ENCLOSED BY '""'",! W "(" F S FLD=$O(^DIPT(DDXPXTNO,100,FLD)) Q:FLD<1 W:FLD>1 ",",! S FLD0=^(FLD,0) D . S NAME=$P(FLD0,U,4)_" ",LENGTH=$P(FLD0,U,3) . S DTYPEFRM=$S($P(FLD0,U,2)=1:" DATE 'MON DD,YYYY'",1:"") . I LENGTH>0 D . . S END=START+LENGTH-1 . . S POS="POSITION ("_START_":"_END_")" . . S START=END+1 . . Q . W NAME_POS_DTYPEFRM W " )",! W "BEGINDATA",! Q DI DI ;SFISC/GFT-DIRECT ENTRY TO VA FILEMAN ;2OCT2012 V ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; G QQ:$G(^DI(.84,0))']"" C G QQ:$G(^DI(.84,0))']"" K (DTIME,DUZ) G ^DII D G QQ:$G(^DI(.84,0))']"" G ^DII P G QQ:$G(^DI(.84,0))']"" K (DTIME,DUZ) Q G QQ:$G(^DI(.84,0))']"" S DUZ(0)="@" G ^DII VERSION ; S VERSION=$P($T(V),";",3),X=$P($T(V),";",4)_" "_VERSION Q ; QQ ; W $C(7),!!,"You must run ^DINIT first." Q DIA DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;4JUNE2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D DICS 1 D F W !?F*3,"EDIT WHICH "_X I $S(DB:DIAT="",1:1) R ": ALL// ",X:DTIME S:'$T X=U,DTOUT=1 G ALL^DIA1:X=""!(X="ALL"),TEMP^DIA1:X?1"[".E&'F,L ED G NDB:DIAT="" GDB S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" D DB G GDB I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2) S %=$G(DI(DB,DIARTLVL-1,DI,DIAO)) I %]"" S Y=% E I Y?1"^"1N1"."1.2N S DB=DB+1 G GDB ;WPB-0804-30857 W ": "_Y D RW I X="" S X=Y I X="ALL" G ALL^DIA1 L S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q I $A(X)=64 G X:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2 K DIC,DIAB D DICS S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-",1)=+X,J>X S D(F)=J K DA D RANGE^DIA1 K D S Y=DA G X:Y="" D DB G 2 DIC ; EGP S DIC(0)="EZI",DIC="^DD(DI,",Y=-1 G X^DIA3:X[";" D DICW^DIALOGZ(DI),^DIC Q:$D(DTOUT) ;**CCO/NI I Y>0 D SET S Y=$P(Y(0),U,2) G 2:'Y S L=L+1,(DI,J(L))=+Y,I(L)=""""_$P($P(Y(0),U,4),";")_"""" G DOWN I $E(X)="]" S DRS=9,X=$E(X,2,999) G DIC:X]"",2 G DIA^DIQQQ:X?."?" I $D(^DD(DI,"GR")) K Y S Y=-1 D:$L(X)<31 . N I,DIGRP,DTOUT,DUOUT,DIRUT,DIROUT,DIYN S DIGRP=X,DIYN=0 . D:$D(^DD(DI,"GR",DIGRP)) Q:DIYN F S DIGRP=$O(^DD(DI,"GR",DIGRP)) Q:$E(DIGRP,1,$L(X))'=X D Q:DIYN .. N X,I .. F I=0:0 S I=$O(^DD(DI,"GR",DIGRP,I)) Q:'I I $G(^DD(DI,I,0))]"" S I(I)=I_U_$P(^(0),U) .. Q:'$O(I(0)) .. W !!,"Fields in Group: ",DIGRP F I=0:0 S I=$O(I(I)) Q:'I W !,?2,I,?10,$P(I(I),U,2) .. D Q:DIYN'=1 ... N X,Y S DIR(0)="Y",DIR("A")="Edit this GROUP of fields",DIR("B")="YES" D ^DIR S DIYN=$S(Y=1:1,$G(DIRUT):2,1:0) Q .. M Y=I S Y=0 Q . Q K DIYN G X^DIA3 ; F S X=$P(^DD(DI,0),U) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X Q ; X ; W $C(7),"??" D DICS 2 ; G 1:'$D(DR(F+1,DI)) D F W !?F*3,"THEN EDIT "_X G ED:DB R R ": ",X:DTIME E W $C(7) S X=U,DTOUT=1 I X]"" G L UP ; G ^DIA1:'F K I(L),J(L) S L=L-1 I '$D(J(L)) F L=L-99:1 Q:'$D(J(L+1)) I DB S DB=DB(F),DIARTLVL=DIARTLVL(F),DIAO=DIAO(F),DIAT=$S(DIAO<0:"",DIAO:$G(^DIE(DIAA,"DR",DIARTLVL,J(L),DIAO)),$D(^DIE(DIAA,"DR",DIARTLVL,J(L))):^(J(L)),1:"") S DIARLVL=DIARLVL(F),DIAP=DIAP(F),DI=J(L),F=F-1 G 2 ; NDB I DB,DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIAA,"DR",DIARLVL,DI,DIAO)) S DIAT=^(DIAO),DB=1 G GDB S DIAO=-1 G R ; ; ; EN ;Entry point from DIB routine N DIARTLVL,DIARLVL,DIAL,DIESP,DRR D OS^DII:'$D(DISYS) FILETOP D DICS ;Enter from DIA3 when there is a file jump DOWN S F=F+1,DIAL(F)=+$G(DIAL),DIARLVL(F)=+$G(DIARLVL) F %=F+1:.01 I '$D(DR(%,DI)) Q ;Find 2.01 if we have already gone down to DR(2,DI) -- WPB-0804-30857 S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIARLVL=% S DIAP(F)=DIAP,DIAP=0 I DB S DIARTLVL(F)=DIARTLVL D S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0,DIAT=$G(^DIE(DIAA,"DR",DIARTLVL,DI)),DIARTLVL(DIARTLVL,DI)="" .S %=$P(DIAT,";",DB) I %?1"^"1.NP S DIARTLVL=$P(%,U,2),DB=DB+1 Q .F DIARTLVL=F+1:.01 I '$D(DIARTLVL(DIARTLVL,DI)) Q G 1:$P(^DD(DI,.01,0),U,2)'["W",1:L#100=0,UP ; DICS ; S DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"""_$S(DUZ(0)="@":"",1:",$P(^(0),U,2)'[""K""")_" Q:'$D(^(9)) I ^(9)'=U"_$S(DUZ(0)'="@":" F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q",1:"") Q ; P ; S DRS=99,Y=X D DB G 2 ; SET S Y=+Y_DV DB ; I DB,'DSC S DB=DB+1 D ;takes 'Y' and puts it into 'DR' array -- Also called from DIA3 N %,B S (DRR,B)=$NA(DR(DIARLVL,DI)),%=$O(@DRR@(""),-1) I % S DRR=$NA(@DRR@(%)) I '$D(@DRR) S @DRR="",DIAP=0 E I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR="" S @DRR=@DRR_Y_";",DRS=$G(DRS)+1 S DIAP=DIAP+1 DIAB I $D(DIAB) S ^UTILITY($J,DIAP#1000,DIARLVL-1,DI,DIAP\1000)=DIAB K DIAB Q ; RW I $L(Y)>19 D RW^DIR2 Q W "// " R X:DTIME I '$T S X=U,DTOUT=1 W $C(7) DIA1 DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;20MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S D NOW^%DTC S DIADT=+$J(%,0,4) K %,DW G Q:DRS<5 R !,"STORE THESE FIELDS IN TEMPLATE: ",X:DTIME S:'$T DTOUT=1 G Q:X="" S DIC(0)="LZSEQ",DLAYGO=0 D T K DLAYGO,DIC I Y<0 G S:X'[U K DR G Q S X=$P(^(0),U,6) I DUZ(0)'["@",X]"" F %=1:1 I DUZ(0)[$E(X,%) Q:%'>$L(X) W !?7,$C(7),"YOU HAVE NO 'WRITE ACCESS' TO THIS TEMPLATE",! G S S DW=$S('$D(^("ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),%=0,X=$P(Y,U,2) I $O(^(0))]"" W $C(7),!,X_" TEMPLATE ALREADY EXISTS.... OK TO REPLACE" D YN^DICN W ! G S:%-1 L +^DIE(+Y) S %Y="" F %X=0:0 S %Y=$O(^DIE(+Y,%Y)) Q:%Y="" K:",%D,ROUOLD,W,"'[(","_%Y_",") ^(%Y) S ^DIE(+Y,0)=X_U_DIADT_U_$S('%:DUZ(0),1:$P(Y(0),U,3))_U_DI_U_DUZ_U_$S('%:DUZ(0),1:$P(Y(0),U,6))_U_DT,^DIE("F"_DI,X,+Y)=1 L -^DIE(+Y) M S %X="DR(",%Y="^DIE(+Y,""DR""," D %XY^%RCR M ^DIE(+Y,"DIAB")=^UTILITY($J) S X=DW,DP=DIA("P"),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ S DR(1,DIA("P"))=U_DNM Q K DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y Q ; ALL ;Called by DIETED, DIA S %=DI,^UTILITY($J,1,F,%,DIAP\1000)="ALL" K DA D G UP^DIA:F,S:$D(DRS) Q .N DIA1 S DIA1=DIARLVL D A ; RANGE ;called by DIA, DIE17, DIETED N DIA1 S DIA1=F+1 S %=DI I X>0 S Y=X-.000001 G B A S Y=0 B S DA="",X=0 G S DG=Y DR S Y=$O(^DD(%,Y)) S:Y="" Y=-1 I $D(D(F)),Y'>0!(Y>D(F)) D DG:X Q I Y'>0 D DG:X S:$D(DR(DIA1,%))[0 DR(DIA1,%)=DA Q I $D(^(Y,0)),X X DIC("S") G G:$T D DG G DR X DIC("S") E G DR S X=Y G G ; DG S DA=DA_$E(";",1,$L(DA))_X_$P(":"_DG,U,X'=DG) S DQ=0 F S DQ=$O(^DD(%,"SB",DQ)) Q:DQ="" S DP=$O(^(DQ,0)) I DP'DG S Y(F,DQ)="" S DQ=-1 Y S X=$O(Y(F,0)) I X>0 K Y(F,X) S DA(F)=DA,Y(F)=Y,%(F)=%,F=F+1,DIA1=DIA1+1,%=X D A S F=F-1,DIA1=DIA1-1,%=%(F),Y=Y(F),DA=DA(F) G Y S X="",DG=0 K DP Q ; TEMP ; S DIC(0)="ZSEQ" D T K DIC Q:$D(DTOUT) G DB:Y<0 S %=$P(Y(0),U,6) G ED:DUZ(0)="@"!'$L(%) F X=1:1:$L(%) I DUZ(0)[$E(%,X) G ED GT I $G(^("ROU"))[U S DR(1,DIA("P"))=^("ROU") E S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR S $P(^DIE(+Y,0),U,7)=DT Q ; T K DIC("W") S D="F"_DI,X=$P(X,"]",1),X=$P(X,"[",1)_$P(X,"[",2),DIC="^DIE(",DIC("S")="I $P(^(0),U,4)=DI"_$P(" S %=$P(^(0),U,3) F DW=1:1:$L(%) I DUZ(0)[$E(%,DW) Q",9,DUZ(0)'="@") G IX^DIC ; ED I Y<1 G GT S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' INPUT TEMPLATE" D YN^DICN G GT:%-1 S DIE="^DIE(",DA=+Y,DR=".01;3;6" D ^DIE K DR I '$D(DA) S DB=0 G DB S:$D(^DIE(DA,"DR"))#2 ^("DR",1,J(0))=^("DR") S DIAA=DA,DRS=9,DIAT=$S($D(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"") M DI=^DIE(DA,"DIAB") S F=0,(DIARTLVL,DB)=1,DIAO=0 F DXS=1:1 Q:'$D(DR(99,DXS)) DB S DI=J(0) G ^DIA DIA2 DIA2 ;SFISC/GFT-SELECT ENTRY TO EDIT, ^LOOP ;16MAY2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K ^UTILITY("DIT",$J),DA,DRS,DW,DIAP,DI I '$D(DR(1,J(0))) S DR(1,J(0))=".01:99999999" I $L(DR(1,J(0)))+$L(DIA)<216,+DR(1,J(0))=.01 S DR(1,J(0))="S:DIA(9) DQ=2,X=$P("_DIA_"DA,0),U,1);"_DR(1,J(0)) DIC W !! G Q^DIB:$D(DTOUT) D L S DIA(1)=+Y,DIA(9)=$P(Y,U,3) I Y>0 D DIE,^DIA3:'$D(DA) G DIC I X'["LOOP",X'["loop" D PTS^DITP:$O(^UTILITY("DIT",$J,0))>0 K ^UTILITY("DIT",$J) G Q^DIB S L="EDIT ENTRIES",DHD="@",IOP="HOME",FLDS="",DHIT="S DCC="""_$$CONVQQ^DILIBF(DIA)_""" D LOOP^DIA2 S:'$D(DCC) DN=0" D EN1^DIP W !!?4,"LOOP ENDED!" Q:$D(DTOUT) G DIC ; L K Y,I,J,F,DIC S (DIC,DIE)=DIA,DIC(0)="QEALM" D K DIE S DIE=DIA Q .N DIA,DR D ^DIC ;could go to a custom lookup that deranges these variables ; DIE S DP=DIA("P"),DA=+Y,DR=DR(1,DP) K DIC,Y,C,DB S DIC=DIE,DILK=DIE_DA_")" D LOCK^DILF(DILK) ;**147 E W $C(7),!,"ANOTHER TERMINAL IS EDITING THIS ENTRY!" K DILK Q I DR?1"^".AN D @DR L @("-"_DILK) K DILK Q E D GO^DIE L @("-"_DILK) K DILK Q ; LOOP ;DELETE OR REPLACE POINTERS G NUL:$D(@(DCC_D0_",-9)")) I '($G(DIFIXPT)=1) W !!,?3 S X=$P(@(DCC_"0)"),U,2) G NUL:'$D(^(D0,0)) S (DI,Y)=$P(^(0),U,1),C=$P(^DD(+X,.01,0),U,2) D . N X D Y^DIQ I $G(DIFIXPT)=1 D . I $D(DIFIXPTH) S ^TMP("DIFIXPT",$J,DIFIXPTC)=DIFIXPTH,DIFIXPTC=DIFIXPTC+1 K DIFIXPTH . S ^TMP("DIFIXPT",$J,DIFIXPTC)=" Entry:"_D0_"-"_$E(Y,1,20)_" " . Q I '($G(DIFIXPT)=1) W Y S Y=D0,(DIE,DIC)=DCC,%C=0 I X["I",'($G(DIFIXPT)=1) S %Y=0 F S %C=$O(^DD(+X,0,"ID",%C)) Q:%C="" S %=^(%C) D . N DIQUIET . W " ",$E(@(DCC_"Y,0)"),0) X % K DO S %C=-1,DO(2)=X,Y=Y_U_DI,DIC(0)=$P("E^",U,('($G(DIFIXPT)=1))) D ACT^DICM1 S DI=99 K DO,DIY Q:Y<0 S Y=D0 D DIE S:$G(DIFIXPT) DIFIXPTC=DIFIXPTC+1 I $D(DTOUT) K DCC,Y I $D(Y) K Y I '($G(DIFIXPT)=1) S %=1 W $C(7),!!,"WANT TO STOP LOOPING" D YN^DICN I %-2 K DCC NUL S DI=99,(^UTILITY($J,99,0),DX(0))="Q" K D1,D2,D3,D4,D5 Q DIA3 DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;19SEP2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S Y=DIA("P"),DH=1,DTO=DIA D PTS^DIT:'$D(^UTILITY("DIT",$J,0)) S ^UTILITY("DIT",$J,0)=0 Q:$D(^(0))<9 D ASK^DITP Q:%-1 S Y=0 I @("$O("_DIC_"0))'>0") G D C W !,"WHICH DO YOU WANT TO DO? --",!?4,"1) DELETE ALL SUCH POINTERS",!?4,"2) CHANGE ALL SUCH POINTERS TO POINT TO A DIFFERENT '"_$P(^(0),U,1)_"' ENTRY",!!,"CHOOSE 1) OR 2): " R %:DTIME G F:U[%,W:%=2,C:%'=1 D W !,"DELETE ALL POINTERS" D YN^DICN G F:%<0,C:%-1,DITP W W !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO" D L^DIA2 G DITP:Y>0 F W $C(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY" Q DITP S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=+Y_";"_$E(DIA,2,999) W !?4,"("_$P("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)" Q ; FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS ---never done?? ;In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to. ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future) N %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH D I $G(X)]"" D BLD^DIALOG(201,X) Q . S X="DIFLG" Q:$G(DIFLG)'="D" S X="DIDELIEN" Q:'$G(DIDELIEN) S X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))="" . S X="DIPTIEN" I $G(DIPTIEN) S Y=$G(^DD(DIFILE,0,"GL")) Q:Y="" I '$D(@(Y_DIPTIEN_",0)")) Q ;<<45&($A(D)<58)!(D[":") S DV=D_$C(126)_DV I Y[";" S X=$P(Y,";",1) S:'$D(DIAB) DIAB=Y G DIC^DIA F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF G BAD:Y'?.E1":" E K X S:'$D(DIAB) DIAB=Y S DICOMP=L_"WE?",DQI="Y(",DA="DR(99,"_DXS_",",X=Y,DICMX=1 D ^DICOMPW I '$D(X) K DIAB G BAD:'$D(DP),ACC L I $D(X)>1 S DXS=DXS+1,%=0 F S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)") S %=-1 S L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")",DRS=99 K X D DB^DIA S DI=+DP G FILETOP^DIA ; DEF S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X S DICMX="S DWLC=DWLC+1,"_DIA_X,DA="DR(99,"_DXS_",",DHIT=Y,X=DP,DQI="X(",DICOMP=L_"T?" D EN^DICOMP,DICS^DIA,XEC K X S X=$P(DHIT,DK,1),DV=DV_DK_DP G DIC^DIA:DV'[";" BAD Q:$D(DTOUT) G X^DIA ACC K DIAB W !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP G BAD Q ; XEC I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") S Y=-1 I $D(X) S %=1,Y="DO YOU MEAN '"_DP_"' AS A VARIABLE" W !?63-$L(Y),Y D YN^DICN Q:%-1 S Y="Q",DXS=DXS+1,DP=U_X,DRS=99 D D^DIA:$S(DIAP:$P(DR(F+1,DI),";",DIAP#1000)'="Q",1:1) S:'$D(DIAB) DIAB=DHIT Q:DP'="@" I DK="//" S DA=U_U Q W !,$C(7)," WARNING: THIS MEANS AUTOMATIC DELETION!!" DIAC DIAC ;SFISC/YJK-FILE ACCESS CHECK ;3/18/99 12:59 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; EN Q:'$D(DIAC)!'$D(DIFILE) I '$D(^DIC(DIFILE,0))#2 S (DIAC,%)=0 Q I DUZ(0)="@" S (DIAC,%)=1 Q S A1=$S(DIAC="DD":2,DIAC="DEL":3,DIAC="LAYGO":4,DIAC="RD":5,DIAC="WR":6,DIAC="AUDIT":7,1:0) D:A1 CK K A1 S %=DIAC Q ; CK I $S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) D FOF Q I '$D(^DIC(DIFILE,0,DIAC)) S DIAC=1 Q S %=^(DIAC) I %="" S DIAC=1 Q F A1=1:1:$L(%) I DUZ(0)[$E(%,A1) S DIAC=1 Q I 'DIAC S DIAC=0 Q ; FOF S DIAC=0 I $S($D(^VA(200,DUZ,"FOF",DIFILE,0)):1,1:$D(^DIC(3,DUZ,"FOF",DIFILE,0))),$P(^(0),U,A1) S DIAC=1 Q ; ;; DIALOG DIALOG ;SFISC/TKW - BUILD FILEMAN DIALOGUE ;24JAN2012 V ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN(DIANUM,DIPI) N DIERR,DIMSG,DIHELP,DIT Q:'$D(^DI(.84,DIANUM,0)) S DIT=$P(^(0),U,2) K ^TMP($S(DIT=1:"DIERR",DIT=2:"DIMSG",1:"DIHELP"),$J) S IOM=$G(IOM,80) D BLD(DIANUM,.DIPI),MSG("W"_$E("EMH",DIT),,IOM,1) Q ; BLD(D0,DIPI,DIPE,DIALOGO,DIFLAG) ;BUILD FILEMAN DIALOG ;1)DIALOG file IEN, 2)Internal params, 3)External params, 4)Output array name, 5)S=Suppress blank line between messages, F=Format output like ^TMP N DINAKED S DINAKED=$NA(^(0)) I $G(^DI(.84,+$G(D0),0))="" G Q1 N E,I,J,K,L,M,N,P,R,S,X,O,DILANG S DILANG=+$G(DUZ("LANG")),DIFLAG=$G(DIFLAG) I $G(DIPE)]"",$O(DIPE(""))="" S DIPE(1)=DIPE I '$O(^DI(.84,D0,4,DILANG,1,0))!('DILANG) S DILANG=1 S P=$P(^DI(.84,+D0,0),U,3)["y",R=$P(^(0),U,2) S:'R R=1 S O=$G(DIALOGO) S:O="" O="^TMP(",DIFLAG=DIFLAG_"F" D S DIALOGO=O . S I=$E(O,$L(O)) I $E(O,1,4)="DIR(" S DIFLAG=$TR(DIFLAG,"F","") . I DIFLAG'["F" S O=$E(O,1,($L(O)-1))_$S(I="(":"",I=",":")",1:I) Q . S O=$P(O,")",1)_$S("(,"[I:"",O'["(":"(",1:",")_""""_$P("DIERR^DIMSG^DIHELP",U,R)_""""_$P(","""_$J_"""",U,O["^TMP(")_")" ;WORRIED THAT $J WOULD NOT BE NUMERIC . Q S N=$O(@DIALOGO@(":"),-1) S N=N+1,(I,J,M)=0 S:R>1!(DIFLAG'["F") J=N-1 I R=1,DIFLAG["F" S O=$P(O,")",1)_","_N_",""TEXT"")" I DILANG>1 F S I=$O(^DI(.84,D0,4,DILANG,1,I)) Q:'I S M=M+1,K(M)=$G(^(I,0)) I P S L=0 D PARAM I DILANG'>1 F S I=$O(^DI(.84,D0,2,I)) Q:'I S M=M+1,K(M)=$G(^(I,0)) I P S L=0 D PARAM G:'M Q2 D . N X S X=M . I N>1,DIFLAG'["S" I DIFLAG'["F"!(R>1) S J=J+1,@O@(J)=" ",X=X+1 . I DIALOGO'["DIR" S:R=1 DIERR=($P($G(DIERR),U)+1)_U_($P($G(DIERR),U,2)+X) S:R=2 DIMSG=$G(DIMSG)+X S:R=3 DIHELP=$G(DIHELP)+X . D BTXT Q I (DIALOGO["DIR")!(R'=1)!(DIFLAG'["F") G Q2 S @DIALOGO@(N)=D0 S I="",J=0 F S I=$O(DIPE(I)) Q:I="" I $G(DIPE(I))]"" S @DIALOGO@(N,"PARAM",I)=DIPE(I),J=J+1 I J S @DIALOGO@(N,"PARAM",0)=J S @DIALOGO@("E",D0,N)="" ; Q2 I $G(^DI(.84,D0,6))]"" X ^(6) Q1 Q:DINAKED="" I DINAKED["(" Q:$O(@(DINAKED))]"" Q I $D(@(DINAKED)) Q ; PARAM S S=$F(K(M),"|",L) G:'S QP S E=$F(K(M),"|",S) G:'E QP S X=$E(K(M),S,E-2) G:X="" PARAM S DIPI(X)=$S($G(DIPI(X))]"":DIPI(X),1:$G(DIPI)),L=S+$L(DIPI(X))-$L(X) I ($L(K(M))+$L(DIPI(X)))<245 S K(M)=$E(K(M),1,S-2)_DIPI(X)_$E(K(M),E,9999) G:K(M)]"" PARAM K K(M) S M=M-1 G QP I $L($E(K(M),1,S-2))+$L(DIPI(X))<245 S K(M+1)=$E(K(M),E,9999),K(M)=$E(K(M),1,S-2)_DIPI(X),M=M+1,L=0 G PARAM I $L(DIPI(X))+$L($E(K(M),E,9999))<245 S K(M+1)=DIPI(X)_$E(K(M),E,9999),K(M)=$E(K(M),1,S-2),M=M+1,L=0 G PARAM S K(M+1)=DIPI(X),K(M+2)=$E(K(M),E,9999),K(M)=$E(K(M),1,S-2),M=M+2,L=0 G PARAM QP Q ; BTXT N M F M=0:0 S M=$O(K(M)) Q:'M S J=J+1 D .I DIALOGO'["DIR" S @O@(J)=K(M) Q .I '$O(K(M)),'$O(^DI(.84,D0,2,I)) S @DIALOGO=K(M) Q .S @DIALOGO@(J)=K(M) Q Q ; EZBLD(D0,DIPI) ;RETURN SINGLE LINE OF TEXT FROM DIALOG FILE. ;D0 = DIALOG file IEN, DIPI = Input Params N DINAKED S DINAKED=$NA(^(0)) I $G(^DI(.84,+$G(D0),0))="" D Q1 Q "" N DILANG S DILANG=+$G(DUZ("LANG")) N X I DILANG>1 S X=$O(^DI(.84,+D0,4,DILANG,1,0)) S:X X=$G(^(X,0)) I $G(X)']"" S X=$O(^DI(.84,+D0,2,0)) S:X X=$G(^(X,0)) I ($P(^DI(.84,+D0,0),"^",3)'["y"!($G(X)="")) S X=$G(X) G QEZ N K,S,L,M,I,E S M=1,L=0,K(M)=X I $G(DIPI)]"",$O(DIPI(""))="" S DIPI(1)=DIPI D PARAM S X=$G(K(1)) QEZ D Q X . N X D Q2 Q ; ; MSG(DIFLGS,DIOUT,DIMARGIN,DICOLUMN,DIINNAME) ;WRITE MESSAGES OR MOVE THEM TO SIMPLE ARRAY. ;1)Flags, 2)Output array name, 3)Margin width of text, 4)Starting column no., 5)Input array name. N Z,%,X,Y,I,J,K,N,DITYP,DIWIDTH,DITMP,DIIN,DINAKED S DINAKED=$NA(^(0)) S:$G(DIFLGS)="" DIFLGS="W" D . S DITMP=0 I $G(DIINNAME)="" S DIINNAME="^TMP(",DITMP=1 Q . N % S %=DIINNAME I %'["(" S DIINNAME=DIINNAME_"(" Q . Q:$E(%,$L(%))="," . I $E(%,$L(%))=")" S DIINNAME=$P(%,")",1)_"," Q . S DIINNAME=%_"," Q S DITYP="",%=0 D . F Z="E","H","M" S %=%+1 I DIFLGS[Z,$D(@(DIINNAME_""""_$P("DIERR^DIHELP^DIMSG",U,%)_""""_$P(","""_$J_"""",U,(DITMP>0))_")")) S $P(DITYP,U,%)=$P("DIERR^DIHELP^DIMSG",U,%) . I DITYP="",$D(@(DIINNAME_"""DIERR"""_$P(","""_$J_"""",U,(DITMP>0))_")")) S DITYP="DIERR" . Q S DIWIDTH=$S($G(DIMARGIN):DIMARGIN,$G(IOM):(IOM-5),1:75),DICOLUMN=+$G(DICOLUMN) K:DIFLGS["A" DIOUT S (K,Z)=0 AWS S K=K+1 I K>3 G Q1 G:$P(DITYP,U,K)="" AWS S DIIN=DIINNAME_""""_$P(DITYP,U,K)_"""" S:DITMP DIIN=DIIN_","""_$J_"""" S (I,N)=0 F S N=$O(@(DIIN_")")@(N)) Q:'N S:K>1 X=$G(@(DIIN_","_N_")")) D:K>1 I K=1 D:I&(DIFLGS'["B") LN S I=1,J=0 F S J=$O(@(DIIN_")")@(N,"TEXT",J)) Q:'J S X=$G(@(DIIN_","_N_",""TEXT"","_J_")")) D . I DIFLGS["A",'$G(DIMARGIN) S Z=Z+1,DIOUT(Z)=X . I DIFLGS'["W",'$G(DIMARGIN) Q . S Y=X D:X="" F Q:X="" F %=$L(X," "):-1:1 S:%=1&($L($P(X," ",1,%))>DIWIDTH) X=$E(X,1,(DIWIDTH-1))_" "_$E(X,DIWIDTH,$L(X)),%=%+1 I $L($P(X," ",1,%))'>DIWIDTH S Y=$P(X," ",1,%) D S X=$P(X," ",%+1,$L(X," ")) Q .. W:DIFLGS["W" !?DICOLUMN,Y S:DIFLGS["A"&$G(DIMARGIN) Z=Z+1,DIOUT(Z)=Y .. Q . Q F I=K:1:2 I $P(DITYP,U,I+1)]"" D LN Q I DIFLGS["A",DIFLGS["T" S DIOUT=Z I DIFLGS'["S" K @(DIIN_")"),@($P(DITYP,U,K)) G AWS ; LN W:DIFLGS["W" ! S:(DIFLGS["A")&Z Z=Z+1,DIOUT(Z)="" Q DIALOGU DIALOGU ;SFISC/MMW - FUNCTIONS FOR DIALOGS ;24MAR2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q ;not for interactive use OUT(Y,DIALF,%F) ;convert FileMan Data to language dependant output format ;Y is the value to transform, DIALF is the type of data ;%F Only for "FMTE" node. Passed from FMTE^DILIBF, indicates date format. ;DIALF must correspond to at least a subscript in the language file ;for the english language (entry #1) but may also have corresponding ;entries for other languages I $D(Y)[0!($G(DIALF)="") Q "" N DINAKED,DIY S DINAKED=$NA(^(0)) N DILANG S DILANG=+$G(DUZ("LANG")) S:DILANG<1 DILANG=1 S DIY=$G(^DI(.85,DILANG,DIALF)) I DIY="" S:DILANG'=1 DIY=$G(^DI(.85,1,DIALF)) I DIY="" S Y="" G Q X DIY Q D:DINAKED]"" . I DINAKED["(" Q:$O(@(DINAKED)) Q . I $D(@(DINAKED)) . Q Q Y ; PRS(D0,X) ;parse language dependant user input ;D0 is an entry in the DIALOG file ;X is the user input ;the function returns the number of the matching command word ;plus the corresponding english text. If no match was found -1 will ;be returned. If there is no user input the function returns the ;null string. N DINAKED,Y S DINAKED=$NA(^(0)) I '$D(^DI(.84,+$G(D0)))!($G(X)']"") S Y=0 G Q N R,I,I1,IL,T,W,%,DILANG S DILANG=+$G(DUZ("LANG")) S:DILANG<1 DILANG=1 I DILANG>1,'$O(^DI(.84,D0,4,DILANG,1,0)) S DILANG=1 S X=$$OUT(X,"UC"),U="^" S R=$S(DILANG=1:"^DI(.84,"_D0_",2)",1:"^DI(.84,"_D0_",4,"_DILANG_",1)") S (I,I1,%)=0 F S I=$O(@R@(I)) Q:'I!% S T=$$OUT(@R@(I,0),"UC") D .F IL=1:1 S W=$P(T,U,IL) Q:W=""!% S I1=I1+1 S:$E(W,1,$L(X))=X %=I1_U_$P(@R@(I,0),U,IL) I '% S Y=-1 G Q I DILANG=1 S Y=% G Q S (I,I1)=0,%=+% F S I=$O(^DI(.84,D0,2,I)) Q:'I!(I1=%) S T=^(I,0) D .F IL=1:1 Q:$P(T,U,IL)=""!(I1=%) S I1=I1+1,W=$P(T,U,IL) S Y=%_U_$G(W) G Q DIALOGZ DIALOGZ ;GFT/GFT - CREATE AND USE FOREIGN-LANGUAGE ADDITIONS TO THE DATA DICTIONARY ; 16NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;FOREIGN-LANGUAGE UTILITES ; D LANG($G(DUZ("LANG"),1)) Q ; ENGLISH ; N LANG D LANG(1) Q GERMAN ; N LANG D LANG(2) Q SPANISH ; N LANG D LANG(3) Q FINNISH ; N LANG D LANG(5) Q PORTUG ; N LANG D LANG(7) Q ARABIC ; N LANG D LANG(10) Q ; LANG(LANG) ; N DIC,DIR,DIAL,Y,DLAYGO,DIF,DIE,DSTART,DIALFILE,DA,DR,DIALDD,DUOUT S U="^",DIAL=$P(^DI(.85,LANG,0),U) D D^DICRW Q:Y<1 FILE S (DIALFILE,DSTART)=+Y,DIF=$P(Y,U,2) I $D(^DIC(DIALFILE,"ALANG",LANG,0)) S DIR("B")=^(0) D DIR(60) I X="@"!'$D(DUOUT) D .I $D(DIR("B")) K ^DIC("ALANG"_LANG,DIR("B"),DIALFILE) .I Y="" K ^DIC(DIALFILE,"ALANG",LANG) W " " Q .S ^DIC("ALANG"_LANG,Y,DIALFILE)="",^DIC(DIALFILE,"ALANG",LANG,0)=Y K DIR FIELDS F D Q:'$D(DSTART) .S DIC="^DD(DIALFILE,",DIC(0)="AEQM" .D DICW(DIALFILE) .W !! D ^DIC I Y<0 D Q ..I DIALFILE=DSTART K DSTART Q ..S DIALFILE=DSTART .K DIR,DUOUT S DIALDD=+Y,DIF=$P(Y,U,2) .I $D(^DD(DIALFILE,DIALDD,.008,LANG,0)) S DIR("B")=^(0) .D DIR(60) K DIR I X="@"!'$D(DUOUT) D ..S ^DD(DIALFILE,DIALDD,.008,LANG,0)=Y ..I Y="" K ^(0) W " " .S Y=+$P(^DD(DIALFILE,DIALDD,0),U,2) I Y,$D(^DD(Y,.01,0)),$P(^(0),U,2)'["W" S DIALFILE=Y Q ;GO DOWN INTO MULTIPLE HLP .D:$G(^DD(DIALFILE,DIALDD,3))]"" Q:$D(DUOUT) ..W !!,"Current ",DIF," Field Help " S DIF="Prompt" W DIF,": " ..W:$X+$L(^(3))>75 !?2 W ^(3) D ...N DUZ S DUZ("LANG")=LANG I $D(^(.009,LANG,0)) S DIR("B")=^(0) ..D DIR(240) Q:X'="@"&$D(DUOUT) ..K DIR S ^DD(DIALFILE,DIALDD,.009,LANG,0)=Y ..I Y="" K ^(0) W " " SET .D:$P(^DD(DIALFILE,DIALDD,0),U,2)["S" ..N SET ..S SET=$$SL($P(^(0),U,3)),DIF="SET values" ..W !!,"Current ",DIF,": " W:$X+$L(SET)>75 !?2 W SET ..I $D(^(.007,LANG,0)) S DIR("B")=^(0) ..S DIR("?")="YOU MUST ENTER "_$L($$SL(SET),";")_" EXTERNAL VALUES, SEPARATED BY SEMICOLONS(;)" ..D DIR("240^S X=$$SL^DIALOGZ(X) K:$L(X,"";"")-$L(SET,"";"")!(X["":"") X") Q:X'="@"&$D(DUOUT) ..K DIR S ^DD(DIALFILE,DIALDD,.007,LANG,0)=Y ..I Y="" K ^(0) W " " W !!! Q ; SL(S) ; I S?.E1";" S S=$E(S,1,$L(S)-1) Q S ; ; DIR(LN) S DIR("A")=DIAL_" translation of "_DIF,DIR(0)="FO^2:"_LN K DUOUT G ^DIR ; FILENAME(FILE) ; N N,F I 'FILE Q "FIELD" I $D(^DIC(FILE,0))#2 D Q F .S F=$P(^(0),"^") .I $G(DUZ("LANG")),$D(^("ALANG",DUZ("LANG"),0))#2 S F=^(0) S N=$G(^DD(FILE,0,"UP")) I N S F=$O(^DD(N,"SB",FILE,0)) I F Q $$LABEL(N,F) Q "" ; ; LABEL(FILE,FIELD) ;Called many places to return the foreign-language FIELD NAME N N S N=$P($G(^DD(FILE,FIELD,0)),"^") I N="" Q N I $P(^(0),"^",2)["W",$G(^DD(FILE,0,"UP")) Q $$LABEL(^("UP"),$O(^DD(^("UP"),"SB",FILE,0))) I $G(DUZ("LANG")),$D(^(.008,DUZ("LANG"),0))#2 Q ^(0) Q N ; HELP(FILE,FIELD) ; G 3:FILE<2!'$G(DUZ("LANG")),3:$G(^DD(FILE,FIELD,3))'?.P&(DUZ("LANG")'>1) I $D(^DD(FILE,FIELD,.009,DUZ("LANG"),0))#2 Q ^(0) N Y,DICATT5,DICATT2,P S DICATT2=$P(^DD(FILE,FIELD,0),U,2),DICATT5=$P(^(0),U,5,999) I DICATT2["D" D .D EARLY^DICATTD1 S:$D(Y) P(1)=Y D LATEST^DICATTD1 S:$D(Y) P(2)=Y .K Y I $D(P(1)) S Y=$$EZBLD^DIALOG($S($D(P(2)):9114,1:9114.01),.P) I DICATT2["N" D .S P(1)=+$P(DICATT5,"X<",2) .S P(2)=+$P(DICATT5,"X>",2) .S P(3)=$P(DICATT5,"1"".""",2)-1 I P(3)<0 S P(3)=0 S:DICATT5["""$""" P(3)=2 .S Y=$$EZBLD^DIALOG($S(DICATT5["""$""":9118.1,1:9118),.P) I DICATT2["F" D .S P(1)=+$P(DICATT5,"$L(X)<",2) I P(1) S P(2)=+$P(DICATT5,"$L(X)>",2) I P(2) S Y=$$EZBLD^DIALOG($S(P(1)=P(2):9119.1,1:9119),.P) I $D(Y) S ^DD(FILE,FIELD,.009,DUZ("LANG"),0)=Y I $G(Y)]"" Q Y 3 Q $G(^DD(FILE,FIELD,3)) ; DICW(FILE) ; S DIC("W")="N % S %=$P(^(0),U,2)" ;**CCO/NI + NEXT 2 LINES WRITE OUT FIELD NAME IN 2 LANGUAGES I $G(DUZ("LANG"))>1 S DIC("W")=DIC("W")_" W:$D(^(.008,DUZ(""LANG""),0)) ?37,$$LABEL^DIALOGZ("_FILE_",+Y)" S DIC("W")=DIC("W")_" W:% $P("" (multiple)^ (word-processing)"",U,$P($G(^DD(+%,.01,0)),U,2)[""W""+1)" Q ; ; SETIN() ;NAKED REFERENCE Builds the SET STRING user sees, with 1,2,3... N C,P S C=$P(^(0),U,3) I $D(^(.007,DUZ("LANG"),0)) D .S C=^(0) F P=1:1:$L(C,";") S $P(C,";",P)=P_":"_$P(C,";",P) E D .N TRY,OUT,O .S TRY="" F P=1:1 Q:$P(C,";",P)="" S O=$P($P(C,";",P),":",2),OUT=$$YESORNO(O),TRY=TRY_P_":"_OUT_";" I OUT=O K TRY Q .I $D(TRY) S C=TRY Q C ; SETOUT() ;NAKED REFERENCE Builds the SET STRING that converts INTERNAL to user's EXTERNAL N P,V,C S C=$P(^(0),U,3) I $D(^(.007,DUZ("LANG"),0)) D .F P=1:1:$L(^(0),";") S V=$P(C,";",P),$P(V,":",2)=$P(^(0),";",P),$P(C,";",P)=V E F P=1:1:$L(C,";") S V=$P(C,";",P),$P(V,":",2)=$$YESORNO($P(V,":",2)),$P(C,";",P)=V Q C ; YESORNO(Y) ;TRY TO TURN YES OR NO INTO 'SI', WHATEVER Q:'$G(DUZ("LANG")) Y I $$UP^DILIBF(Y)="YES",$D(^DI(.84,7001,4,DUZ("LANG"),1,1,0)) Q $P(^(0),U) I $$UP^DILIBF(Y)="NO",$D(^DI(.84,7001,4,DUZ("LANG"),1,1,0)) Q $P(^(0),U,2) Q Y ; DIAR DIAR ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS ;7/1/93 4:17 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. G NOKL ; 1 ;;SELECT ENTRIES TO ARCHIVE S DIAR=1 D DIAR^DICRW G Q:Y<0 S %=$P(Y,U,2),(Y,DIARF,DIART)=+Y ;TEMPORARY CHANGE TO SKIP SUB-FILE OPTION--NOT COMPLETE G O G O:'$O(^DD(DIARF,"SB",0)) W !!,"IF YOU PLAN TO ARCHIVE DATA ONLY FROM ONE SUB-FILE" W !,"PLEASE IDENTIFY IT HERE. OTHERWISE, JUST PRESS RETURN.",! D SUB^DICRW G Q:$D(DTOUT)!$D(DUOUT),O:'$D(DIA) S DIARF=DIA S DIARF0="D0," F D=1:1 Q:'$D(^DD(DIA,0,"UP")) S DIARF0=DIARF0_"D"_D_",",DIA=^("UP") O S I="" D CHK I '$D(DIARC) D NEW^DIARCALC G Q:'$D(DIARC) G T1 I $P(Y(0),U,7)>0 W !!,"There is already an outstanding "_$S(+$P(Y(0),U,17):"extract",1:"archiving")_" activity.",!,"Please finish it or CANCEL it.",$C(7),!! G Q D MRK^DIARU T1 S DIC=DIART,L="]" I $D(DIARF0) S DIARF1=$L(DIARF0,",")-1 D EN^DIS I '$P(^DIAR(1.11,DIARC,0),U,7) W $C(7),!!,"NO RECORDS WERE SELECTED TO BE "_$S($D(DIAX):"EXTRACTED",1:"ARCHIVED")_"!!",!,"I AM DELETING THIS ARCHIVING ACTIVITY RECORD!!" S DIK="^DIAR(1.11,",DA=DIARC D ^DIK G Q ; CHK ;IS THERE A VALID SEARCH ? K DIARC,Y(0) S I=0,Y=$S($D(DIARF):DIARF,1:Y) C S I=$O(^DIAR(1.11,"C",+Y,I)) Q:'I S Y(0)="" G C:'$D(^DIAR(1.11,I,0)) G C:$P(^(0),U,8)>89 S Y(0)=^(0) S DIC=$P(Y(0),U,2),DIARC=I,DIARU=$P(Y(0),U,3),DIARP=$P(Y(0),U,4) Q 2 ;;ADD/DELETE SELECTED ENTRIES S DIAR=2 G ENTE^DIARB ; 3 ;;PRINT SELECTED ENTRIES S DIAR=3 G OUT^DIARA ; 4 ;;CREATE FILEGRAM ARCHIVING TEMPLATE S DI=1,DIAR="" G EN^DIFGO ; 5 ;;WRITE ENTRIES TO TEMPORARY STORAGE S DIAR=4 G OUT^DIARA ; ; 6 ;;MOVE ARCHIVED DATA TO PERMANENT STORAGE S DIAR=5 D FILE^DIARU G Q:'$D(DIARC) W !!,"NOTE: This option will 1) print an archive activity report to specified",!,"PRINTER DEVICE and 2) will move archive data to permanent storage to specified",!,"ARCHIVE STORAGE DEVICE." W !!,"Select some type of SEQUENTIAL media, such as SDP, TAPE, or DISK FILE (HFS),",!,"for archival storage.",! S %ZIS("A")="PRINTER DEVICE: ",%ZIS("B")="",%ZIS="NQ" D ^%ZIS G 65:POP S DIARPDEV=$S($D(ION)#2:ION,1:IO),DIARTRM=$S(IO=IO(0):1,1:0) I $D(IOST)#2,IOST]"" S DIARPDEV=DIARPDEV_";"_IOST F DIARX="IOM","IOSL" S:($D(@DIARX)#2&@DIARX) DIARPDEV=DIARPDEV_";"_@DIARX I $D(IO("Q")) S DIARQUED=1 S %ZIS="Q",%ZIS("B")="",%ZIS("A")="ARCHIVE STORAGE DEVICE: " D ^%ZIS G 65:POP I IOT'["HFS",IOT'["MT",IOT'["SDP" D 63 I $D(DIRUT)!('Y) D 64 G 65 I $D(IO("Q")),DIARTRM U IO(0) W !,$C(7),"SINCE YOU SELECTED QUEUEING, YOU SHOULD SELECT A PRINTER DEVICE",!,"OTHER THAN YOUR TERMINAL!",! G 65 D AL I $D(DTOUT)!$D(DIRUT) D 64 G 65 I $D(IO("Q")) D G Q . I '$D(DIARQUED),'DIARTRM S DIARQUED=1 U IO(0) W !,$C(7),"SINCE YOU SELECTED QUEUEING, REPORT WILL BE QUEUED ALSO!",! . S ZTRTN="62^DIAR",ZTSAVE("DIARC")="",ZTSAVE("DIAR")="",ZTDESC="Move archived data to permanent storage",ZTSAVE("DIARPDEV")="",ZTSAVE("DIARQUED")="" . D ^%ZTLOAD,HOME^%ZIS Q 62 D ^DIARX S DIARL="F Q:$A(DIARLINE)-32 S DIARLINE=$E(DIARLINE,2,999)" U IO F I=0:0 S I=$O(^DIAR(1.11,DIARC,"D",I)) Q:I'>0 I $D(^(I,0)) S DIARLINE=^(0) X:$E(DIARLINE)[" " DIARL W DIARLINE,! W "#$#",! D 64,OUT^DIARX,UPDATE^DIARU G Q 63 U IO(0) W !,$C(7),"The ARCHIVE STORAGE device selected does not look like a SEQUENTIAL",!,"storage medium.",! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to continue" D ^DIR I Y U IO(0) W !,"OK.",! Q 64 X $G(^%ZIS("C")) Q 65 ; G UNLK^DIARA ; 7 ;;PURGE STORED ENTRIES D S DIAR=90 G ENTD^DIARA ; 8 ;;CANCEL ARCHIVAL SELECTION S DIAR=99 G ENTC^DIARA ; 9 ;;FIND ARCHIVED ENTRIES S DIC=9.4,DIC(0)="QM",DIC("S")="I $P(^(0),U,2)=""XU""",X="KERNEL" D ^DIC K X,DIC I Y'>0 W !,$C(7),"YOU NEED KERNEL TO RUN THIS OPTION" Q I $G(^DIC(9.4,+Y,"VERSION"))'>7.0 W !,$C(7),"YOU NEED KERNEL V7.1 TO RUN THIS OPTION" Q G ^DIARR ; Q G Q^DIARB ; AL ; archive device label U IO(0) K DIR,DA S DIARXXX=$S(IOT["MT":IO_"ARCHIVE"_";"_DT_";"_DIARC,1:IO) S DIR(0)="1.11,18",DIR("B")=DIARXXX D ^DIR Q:$D(DTOUT)!$D(DUOUT) S DIARXXX=X,DIE=1.11,DA=DIARC,DR="18////^S X=DIARXXX" D ^DIE Q NOKL S DIK="^DOPT(""DIAR""," G GO:$D(^DOPT("DIAR",9)) S ^(0)="ARCHIVE OPTION^1.01^" K ^("B") F I=1:1:9 S ^DOPT("DIAR",I,0)=$P($T(@I),";;",2) D IXALL^DIK GO W ! S DIC=DIK,DIC(0)="AEQI" D ^DIC K DIC,DIK I Y'<0 S X=+Y K Y D @X G NOKL W ! G Q^DII DIARA DIARA ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS (CONT) ;22SEP2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ENTD ; PURGE W:'$D(DIAX) !!,$C(7),$C(7),"BEFORE YOU PURGE, MAKE SURE THAT YOUR ARCHIVE MEDIUM IS READABLE!",!,"YOU MAY USE THE FIND ARCHIVED ENTRIES OPTION TO FIND THE LAST",!,"ARCHIVED RECORD APPEARING ON THE INDEX.",! K DIR S DIR(0)="Y",DIR("A")="Do you want to proceed",DIR("B")="NO" D ^DIR Q:$D(DUOUT)!$D(DTOUT)!($G(Y)'=1) D FILE^DIARU G Q:'$D(DIARC) I $D(^DD(DIARF,0,"PT")) W !!,$C(7),"The records about to be purged should not be 'pointed to' by other records to",!,"maintain database integrity." W ! K DIR S DIR(0)="Y",DIR("A",1)="This option will DELETE DATA from both "_$P(^DIC(DIARF,0),U),DIR("A",2)="and from the ARCHIVAL ACTIVITY file.",DIR("A")="Are you sure you want to continue",DIR("B")="NO" D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT)!($G(Y)'=1) S DIFILE=DIARF,DIAC="DEL" D ^DIAC I '% W !,$C(7),"Sorry, you cannot purge this archival activity!",!,"You do not have DELETE access to ",$P(^DIC(DIARF,0),U),"." G UNLK W !!,"The entries will be deleted in INTERNAL NUMBER order." S DIARS="" F K="ID","SP" F I=0:0 S I=$O(^DD(DIARF,0,K,I)) Q:+I'=I I $D(^DD(DIARF,I,0))#2 S X=$P(^(0),U,4) I $P(X,";")=0 S DIARS=DIARS_$P(X,";",2)_U D0 S DA=$O(^DIBT(DIARU,1,0)) I DA="" W !!,"<< ",$P(^DIAR(1.11,DIARC,0),U,7)," ENTRIES PURGED >>" K ^("D"),^("EX") D UPDATE^DIARU G Q S DIK=DIC,DIARS(0)=$S($D(@(DIC_"DA,0)")):^(0),1:"") K ^DIBT(DIARU,1,DA) I DIARS(0)="" S Y=$P(^DIAR(1.11,DIARC,0),U,7),$P(^(0),U,7)=Y-1 G D0 D ^DIK G D0:DIARF'=DIARF2 S Y=DIARS(0),X=$P(Y,U) D F I=1:1 Q:$P($G(DIARS),U,I)="" S %=$P(DIARS,U,I),$P(X,U,%)=$P(Y,U,%) E G D0 ; ENTC ;CANCEL S DIC("A")="CANCEL WHICH "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" SELECTION: " D FILE^DIARU G Q:'$D(DIARC) S DIR("A")="Are you sure you want to CANCEL this "_$S($D(DIAX):"EXTRACT",1:"ARCHIVING")_" ACTIVITY",DIR("B")="NO",DIR(0)="Y" S DIR("??")="^W !!?5,""Enter YES to stop this activity and start again from the beginning.""" D ^DIR G UNLK:$D(DUOUT)!$D(DTOUT),UNLK:'Y F I=0:0 S I=$O(^DIBT(+DIARU,1,I)) Q:'I K @(DIC_I_",-9)") I $D(DIAX) S DIAXNRB=0 I DIARST=6,$D(^DIAR(1.11,DIARC,"EX")) D ASK^DIARB G UNLK:$D(DUOUT)!$D(DTOUT) I 'DIAXNRB,$D(^DIAR(1.11,DIARC,"EX")) S DIK=^DIC(DIAXFNO,0,"GL"),DA=0,DIOVRD=1 F S DA=$O(^DIAR(1.11,DIARC,"EX","B",DA)) Q:DA'>0 D ^DIK S DIK="^DIAR(1.11,",DA=DIARC D ^DIK W !!,">>> DONE <<<" G Q ; OUT ;USED TO PRINT LISTING OR TO WRITE TO TEMP.STORAGE K DIARC,FLDS D FILE^DIARU G Q:'$D(DIARC) S DIARD=0 W !! D @DIAR I DIAR'=3 K DIARP S DIE="^DIAR(1.11,",DA=DIARC,DR="3;S DIARP=X" D ^DIE G UNLK:$D(DTOUT)!'$D(DIARP) S FLDS="[`"_DIARP_"]" S FR="",TO="",L=0 K DIOEND S:(DIAR'=3) DIOEND="W !,$P(^DIAR(1.11,DIARC,0),U,7)"_","""_" ITEMS HAVE BEEN "_$S($D(DIAX):"EXTRACTED",1:"ARCHIVED")_"""",DISTOP=0 K DIE,DR,DA S BY="[`"_DIARU_"]",DIARI=DIARU S:DIAR=3 BY=BY_",.01" S DHD=$P(^DIC(DIARF,0),U)_$S($D(DIAX):" EXTRACT",1:" ARCHIVING")_" ACTIVITY",DIC=^(0,"GL") F %=0:0 S %=$O(^DIAR(1.11,DIARC,"S",%)) Q:%'>0 S DIFG(+DIARF2,^(%,0))=^(1) S %=$O(DIFG(+DIARF2,"")) K:%="" DIFG I $D(DIFG) S DIFG(+DIARF2,"S")="X DIFG("_+DIARF2_","_%_")" D EN1^DIP I DIAR'=3,$G(POP) G UNLK G Q UNLK S DIAR="" D UPDATE^DIARU Q K POP G Q^DIARB ; 3 W "Enter regular Print Template name or fields you wish to see printed on this",!,"report of entries to be "_$S($D(DIAX):"extracted.",1:"archived.") Q 4 W "You MUST enter a FILEGRAM template name. This FILEGRAM template will be used",!,"to actually build the archive message." Q DIARB DIARB ;SFISC/TKW,WISC/CAP-ARCHIVING FUNCTIONS (CONT) ;4/24/96 10:55 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ENTE ;ADD/REMOVE ENTRIES TO SELECTED S DIC("A")="ADD/DELETE ENTRIES FROM ARCHIVAL ACTIVITY: " K DIARC D FILE^DIARU G Q:'$D(DIARC) S DIARCNT=0 K DIC D S DIC=+DIARF,DIC(0)="AEQMF",DIART=DIARF2,Z=0 E W ! S DIC("W")="W:$D(^DIBT(DIARU,1,+Y)) "" *on "_$S($D(DIAX):"EXTRACT",1:"ARCHIVE")_" list*"" S DIARX="""" F DIARX2=0:0 S DIARX=$O(^DD(+DIARF,0,""ID"",DIARX)) Q:DIARX="""" S DIARX3=^(DIARX) I $D(@(DIC_""+Y,0)"")) X DIARX3" D ^DIC K DIC("W") I Y'>0 G QE S X=DIART G F:'X S Z=Z+1,%=$P($P(X,U,2),",",Z) G F:'% S $P(X,U)=$P($P(X,U),",",2,999),DIC=DIC_+Y_","_%_"," I $D(@(DIC_"0)")),$P(^(0),U,2)-X=0 S DIART=X G E W !,$C(7),"No "_$O(^DD(+X,0,"NM",""))_" entry !!!",! G D F K DR S DA=+Y,DR=0 D EN^DIQ I '$D(^DIBT(DIARU,1,DA)) G E1 S DIR(0)="Y",DIR("A")="DELETE this entry FROM the "_$S($D(DIAX):"EXTRACT",1:"ARCHIVAL")_" SELECTION",DIR("B")="YES" D ^DIR G QE:$D(DUOUT)!$D(DTOUT),QE:'$D(Y) I 'Y W !!,"OK, I left it IN !" G D S DIARCNT=DIARCNT+1,A=^DIAR(1.11,DIARC,0),$P(A,U,7)=$P(A,U,7)-1,$P(A,U,8)=2,^(0)=A K ^DIBT(DIARU,1,DA),@(DIC_DA_",-9)") W " Deleted" G D E1 S DIR(0)="Y",DIR("A")="ADD this entry TO the "_$S($D(DIAX):"EXTRACT",1:"ARCHIVAL")_" SELECTION",DIR("B")="YES" D ^DIR G QE:$D(DUOUT)!$D(DTOUT),QE:'$D(Y) I 'Y W !!,"OK, I left it OUT !" G D S DIARCNT=DIARCNT+1,A=^DIAR(1.11,DIARC,0),$P(A,U,7)=$P(A,U,7)+1,$P(A,U,8)=2,^(0)=A S ^DIBT(DIARU,1,DA)="" W " DONE" G D QE S:'DIARCNT DIAR="" D UPDATE^DIARU Q K DIAR,DIARC,DIARCNT,DIARD,DIARE,DIARF,DIARF0,DIARF1,DIARF2,DIARI,DIARP,DIARS,DIARST,DIART,DIARU,DIARX,DIAR K DIR,DIC,DIARL,DIARLINE,DIARBLNE,DIARPDEV,DIARPG,DIAX,DIAXFNO,DIAXNRB,DIAXMSG,DIARQUED,DIARTAB,DIARTRM,DIARXZ,DIARFLD,DIARFI,DIARXY K DIFILE,DIARXXX,DISTOP,DIARX2,DIARX3,DIPG,DIERR,DIOVRD Q ASK W !!,$C(7),"This extract activity has already updated the destination file.",! S DIR("A")="Delete the destination file entries created by this extract activity",DIR("B")="NO",DIR(0)="Y" S DIR("??")="^W !!?5,""Enter YES to rollback the destination file to its state before the update.""" D ^DIR I 'Y S DIAXNRB=1 Q DIARCALC DIARCALC ;SFISC/TKW,WISC/CAP-ARCHIVING Variables Doc / Misc Calc.;06:10 PM 5 Dec 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;COMPUTE BOUNDARIES FROM ;SELECT FROM VALUE 4 SORT S X="F" D G FIRST I $D(DIARS) S:A="" A=$P(DIARS,U,2) S:A="" A=$$EZBLD^DIALOG(7070) G Q ;**CCO/NI 'FIRST' D H Q:X="" S DIARS=Y_U_X Q TO ;SELECT TO VALUE 4 SORT S X="T" D G LAST I $D(DIARE) S:A="" A=$P(DIARE,U,2) S:A="" A=$$EZBLD^DIALOG(7071) G Q ;**CCO/NI 'LAST' D H Q:X="" S DIARE=Y_U_X Q G S DIART=L,L=0 I $D(DIPP(DJ,X)) S A=$P(DIPP(DJ,X),U,2) Q I $D(DPP(DJ,X)) S A=$P(DPP(DJ,X),U,2) Q S A="" Q H ; S %=X,%1=DISV I +%1,$D(^DIBT(%1,2,DJ,%)) S (X,%2)=$P(^(%),U,2) I "z"'[X EGP E S %2=$S(%="T":$$EZBLD^DIALOG(7071),1:$$EZBLD^DIALOG(7070)),X="" ;**CCO/NI 'FIRST' OR 'LAST' I X="",'$D(DIAR) S A=%2,L=DIART G Q D CK:X'="" S L=DIART,A=$S(%="F"&(X]%2):X,%="T"&(%2]X)&(X'=""):X,A'="":A,1:%2) Q K %,%1,%2,DIART Q ; NEW ;SET UP INITIAL ARCHIVAL ACTIVITY D NOW^%DTC S X=$P(^DIAR(1.11,0),U,3) F X=X:1 L +^DIAR(1.11,X):0 Q:$T&'$D(^(X)) L -^DIAR(1.11,X) S Z="1////"_DIART_";4////"_DT_$S($D(^VA(200)):";8////"_DUZ,1:"")_";30////"_DIARF_";13////"_DIAR_";14////"_%_$S($D(^VA(200)):";15////"_DUZ,1:"")_";16////"_$S($D(DIAX):1,1:0) I $D(DIARF0) S Z=Z_";31////"_DIARF0 S DINUM=X,DIC("DR")=Z S DIC="^DIAR(1.11,",DIC(0)="EF" K DO D FILE^DICN S DIARC=+Y K DR Q ; CK S DIART=%_U_%2_U_A D CK^DIP12 S %=$P(DIART,U,1),%2=$P(DIART,U,2),A=$P(DIART,U,3) Q VAR ; ;DIAR0 = List of human readable conditions from ^DOPT("DIS" in ^ pieces ;DIARC = Internal record number of Archival Activity ;DIARD = Array of information from default package archival search ; template for this file. (Created in DIAR0) ;DIARDC= Number of default conditions ;DIARE = To value in DIP sort questions ;DIARF = Internal number of file being archived ;DIARF0= Subfile List or DIAR/DIBT INDEX ;DIARI = SEARCH TEMPLATE USED ;DIARF1=Level # that search is on ;DIARP = Internal record no. of Filegram template ;DIARS = Temporary value / From value in DIP sort questions ;DIART = Temporary storage variable ;DIARU = Internal number of Select Criteria Template ;DIARST = Archival Activity upon entry to archival option DIARR DIARR ;SFISC/DCM-ARCHIVING FUNCTION, RETRIEVAL OF ARCHIVED RECORD ;8/11/98 13:19 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. START W !!,"This option will scan your archived file and will attempt to retrieve entries" W !,"that match the name (.01) field and",!,"either Primary KEY or identifier field(s) of the archived file." W !!,"Magnetic tapes should be opened with variable length records." ; INIT S DIARX="F U DIARIO R DIARL Q:DIARL]""""&($A(DIARL)'=13) " D HOME^%ZIS S DIOF=IOF,DIOSL=IOSL D DT^DICRW K ^TMP("DIAR",$J) S (DIARREQ,DIAROUT,DIARZ,DIAREOF,DIARMTCH,DIARFGEN,DIARPG,DIARRCT,DIARZID,DIARZL,DIARZ1,DIARZ2,DIARX1,DIARY,DIARNM,DIARRCT,DIARFND,DIARRHP)=0,DIARLINE="" ; SEQDEV S %ZIS("A")="SEQUENTIAL ARCHIVE DEVICE: ",%ZIS("HFSMODE")="R" D ^%ZIS G EOJ:POP I IOT'["MT",IOT'["SDP",IOT'["HFS" D ^%ZISC W !,$C(7),"This has to be a sequential device." G SEQDEV I IOT["MT",IOPAR'["V" D ^%ZISC W !,$C(7),"Open this device with variable length records." G SEQDEV S DIARIO=IO ; RC X DIARX I $E(DIARL,1,4)'["$IND",$E(DIARL,1,4)'["$DAT" D ^%ZISC W !,$C(7),"Archive information is not in filegram format" G SEQDEV I $E(DIARL,1,6)="$INDEX" S DIARIDX=1 D ^DIARR6 G RC3 U IO(0) W !!,"Sampling archived file...",! RC2 I $P(DIARL,U)="$DAT" S DIARFILE=$P(DIARL,U,2),DIARFN=+$P(DIARL,U,3) X DIARX S DIARNAME=$P(DIARL,"=",2) X DIARX F X DIARX Q:(($P(DIARL,":")="END")&(+$P(DIARL,U,2)=DIARFN)) D RC1:$P(DIARL,":")="BEGIN" I ($P($P(DIARL,U),":")="IDENTIFIER")!($P($P(DIARL,U),":")="SPECIFIER") D ID F X DIARX Q:$P(DIARL,U)["$END DAT" I +$P(DIARL,U,2)=".01" S DIAR01=$P(DIARL,U) S ^TMP("DIARHLP",$J,DIARRCT+1,.01)=DIAR01_" = "_$P(DIARL,"=",2) Q I '$D(DIAR01) S DIARNM=1,^TMP("DIARHLP",$J,DIARRCT+1,.01)="NAME = "_DIARNAME S DIARRCT=DIARRCT+1 F X DIARX Q:((DIARL["#$#")!(DIARRCT>5)) G RC2:((DIARRCT'>5)&($P(DIARL,U)["$DAT")) ; RC3 I DIARNM,'$D(DIAR01) S DIAR01="NAME" S DIARXXX=$$REWIND^%ZIS(IO,IOT,IOPAR) ; FILE U IO(0) W !,"You are reading archived information from the "_DIARFILE_" file." K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to continue" D ^DIR G EOJ:'Y!($D(DIRUT)) ; D ^DIARR1 G EOJ:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR))!POP K DIRUT,DUOUT D ^DIARR2 D ^DIARR3 D ^DIARR5 D EOJ Q ; ID S DIARID(+$P(DIARL,U,2))=$P($P(DIARL,U),":",2)_U_+$P(DIARL,U,2) S ^TMP("DIARHLP",$J,DIARRCT+1,$P($P(DIARL,U),":",2))=$P($P(DIARL,U),":",2)_" = "_$P(DIARL,"=",2) Q ; RC1 S DIARFN1=+$P(DIARL,U,2) F X DIARX Q:(($P(DIARL,":")="END")&(+$P(DIARL,U,2)=DIARFN1)) Q ; EOJ D ^%ZISC K POP,DIARX,DIARFILE,DIARFN,DIARIO,DIARID,DIAR01,DIARZ,DIARREQ,DIARR,DIR,DIRUT,DTOUT,DUOUT,%MT,DIAROUT,DIARPDEV K DIARL,DIARA,DIAREOF,DIARF2,DIARFGEN,DIARFGL,DIARMTCH,DIARNM,DIARY,DIARIDDN,DIARMTID,DIARMT01,DIARZID K ^TMP("DIAR",$J),DIARRF,DIARZ1,DIARZ2,DIARRCT,DIARPG,DIARZL,DIARX1,DIARLINE,DIARIDS,DIARQUED,DIARFN1 K DIARHLP,DIARRHP,DIARZHP,DIARNAME,DIAROFLD,DIAROIDF,DIAROAT,DIAROFLD,DIAROIDF,DIAROLVL,DIAROSTK,DIAROVAL,DIAROXPL K DIAROLNE,DIAROLUP,DIAROM,DIAROREQ,DIAROSUB,DIAROTAB,DIAROX,DIAROX1,DIAROZ,DIARZZ,DIARTAB,DIAROBPT,^TMP("DIARO",$J) K DIAROBCK,DIAROBF,DIAROBFN,DIAROBF1,DIAROSF,DIAROSFN,DIAROXX,DIARCNT,DIARCTR,DIARFLD,DIARFLGT,DIARFNA,DIARFNO,DIARIDX K DIARIXCT,DIARIXX,DIARPC,DIARREC,DIARVAL,DIARXX,DIARFND,DIARYY,DIARXXX,^TMP("DIARHLP",$J),DIAROX2,DIOF,DIOSL Q DIARR1 DIARR1 ;SFISC/DCM-ARCHIVING FUNCTION, PROMPT FOR ARCHIVED RECORD ;7/1/93 8:43 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. PROC D N Q:$D(DTOUT)!($D(DUOUT)&(DIARREQ'>0))!('$D(DIARR)) D PRINTDEV Q:POP I '$D(IO("Q")) U IO(0) W !,"Searching archived file..." Q ; N U IO(0) I '$D(DIARIDX) W !!,"Type ?? at any prompt to display sampled entries.",! W !!,"Multiple requests may be made.",!,"One set of all prompts makes one request.",! I $D(DIARIDX) D ASKIX Q:$D(DIRUT) N1 W ! K DIR S DIR("?",1)="Enter the "_DIAR01_" (.01) field.",DIR("?",2)="Answer to this prompt will retrieve all entries that match the ",DIR("?")=DIAR01_" field.",DIR("??")="^D HELP^DIARR1" S DIR(0)="FO",DIR("A")="Enter "_DIAR01 D ^DIR S:((X]"")&(X'="^")) DIARR(DIARREQ+1,".01")=X Q:$D(DTOUT)!(DIAROUT&(X=""))!($D(DUOUT))!('$D(DIARID)&$D(DIRUT)) I $D(DIARID) D IDS Q:$D(DTOUT) S:$D(DIARR(DIARREQ+1)) DIARREQ=DIARREQ+1 G N1 ; IDS S DIAROUT=0 K DIR S DIR(0)="FO",DIR("?",1)="Enter identifier information. Answer to this prompt, along with all",DIR("?",2)="previously answered prompts for this request, will be used in the matching",DIR("?")="process." S DIR("??")="^D HELP^DIARR1" F DIARZ=.019:0 S DIARZ=$O(DIARID(DIARZ)) Q:DIARZ'>0 S DIR("A")="Enter "_$P(DIARID(DIARZ),U)_" (id) " D ^DIR Q:$D(DTOUT)!$D(DUOUT) S:((X]"")&(X'="^")) DIARR(DIARREQ+1,"ID",+$P(DIARID(DIARZ),U,2))=X I '$D(DIARR(DIARREQ+1)) S DIAROUT=1 Q Q ; HELP S DIARZHP="" W @DIOF F DIARHLP=0:0 S DIARHLP=$O(^TMP("DIARHLP",$J,DIARHLP)) Q:DIARHLP'>0!$D(DTOUT)!$D(DIRUT) W ! F S DIARZHP=$O(^TMP("DIARHLP",$J,DIARHLP,DIARZHP)) Q:DIARZHP="" W !,^(DIARZHP) I $Y>(DIOSL-3) D E Q:$D(DTOUT)!$D(DIRUT) Q ; E ; N DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!$D(DIRUT) W @DIOF Q ; PRINTDEV Q:'$D(DIARR) S %ZIS="QN",%ZIS("B")="",%ZIS("A")="PRINT FOUND ENTRIES TO DEVICE: " D ^%ZIS Q:POP S DIARPDEV=$S($D(ION)#2:ION,1:IO) I $D(IOST)#2,IOST]"" S DIARPDEV=DIARPDEV_";"_IOST F DIARZ="IOM","IOSL" S:($D(@DIARZ)#2&DIARZ) DIARPDEV=DIARPDEV_";"_@DIARZ I $D(IO("Q")) U IO(0) W !,"THE PRINTING OF REPORT WILL BE QUEUED. PROCESSING CONTINUES..." S DIARQUED="" Q ; ASKIX W !,"This archived file contains an index of all archived entries." K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to see the index now" D ^DIR Q:'Y!($D(DIRUT)) W @DIOF,! S DIARTAB=0 F DIARXX=1:1:DIARCNT S DIARFLD=$P(DIARPC(DIARXX),U,2),DIARTAB=DIARTAB+25 W $E(DIARFLD,1,23),?DIARTAB S DIARYY="" W ! F DIARXX=1:1:DIARCTR W ! S DIARTAB=0 D I $Y>(DIOSL-2) D E Q:$D(DTOUT)!$D(DIRUT) . F S DIARYY=$O(DIARPC(DIARYY)) Q:DIARYY'>0 S DIARFLD=+$G(DIARPC(DIARYY)),DIARTAB=DIARTAB+25 W $E($P($G(^TMP("DIARHLP",$J,DIARXX,DIARFLD)),"= ",2),1,23),?DIARTAB . Q K DTOUT,DIRUT Q DIARR2 DIARR2 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG) PROCESS REQUEST ;11/18/92 11:29 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. I $D(DIARIDX) D PROC^DIARR6 G C ; FG F DIARZ=1:1 X DIARX Q:(DIARL="#$#") S ^TMP("DIARFG",$J,DIARZ)=DIARL D:DIARL="$END DAT" FG1 C S X=DIARIO X ^DD("FUNC",7,1) K:$D(DIARIO)#2&(DIARIO]"") IO(1,DIARIO) D EOP Q ; FG1 F DIARZ=1:1 S DIARFGL=$G(^TMP("DIARFG",$J,DIARZ)) Q:((DIARFGL="$END DAT")!(DIARFGEN)) D FG2 D IDS D MATCH D EOP Q ; FG2 Q:$P(DIARFGL,U)="$DAT" I DIARNM,$P(DIARFGL,U)=DIARFILE S DIARA(".01")=$P(DIARFGL,"=",2) Q I $P(DIARFGL,":")="BEGIN" D FG3 Q I $P(DIARFGL,":")="IDENTIFIER" S DIARA("ID",+$P(DIARFGL,U,2))=$P(DIARFGL,"=",2) Q I $P(DIARFGL,":")="SPECIFIER" S DIARA("ID",+$P(DIARFGL,U,2))=$P(DIARFGL,"=",2) Q I +$P(DIARFGL,U,2)=".01" S DIARA(".01")=$P(DIARFGL,"=",2) S DIARFGEN=1 Q Q ; FG3 Q:+$P(DIARFGL,U,2)=DIARFN S DIARF2=+$P(DIARFGL,U,2),DIARZ=DIARZ+1 F DIARZ=DIARZ:1 S DIARFGL=$G(^TMP("DIARFG",$J,DIARZ)) Q:(($P(DIARFGL,":")="END")&(+$P(DIARFGL,U,2)=DIARF2)) Q ; IDS F DIARIDS=0:0 S DIARIDS=$O(DIARID(DIARIDS)) Q:DIARIDS'>0 I '$D(DIARA("ID",DIARIDS)) S DIARA("ID",DIARIDS)="" Q ; MS S DIARMTID="",DIARMT01=0,DIARMTCH=0,DIARIDDN=0,DIARRF(DIARY)=$S($D(DIARRF(DIARY)):DIARRF(DIARY),1:0) Q ; MATCH F DIARY=0:0 S DIARY=$O(DIARR(DIARY)) Q:DIARY'>0 D MS D:$D(DIARR(DIARY,".01")) MATCH01 D:$D(DIARR(DIARY,"ID")) MATCHID:'DIARIDDN D:DIARMTCH FOUND Q ; MATCH01 Q:DIARR(DIARY,".01")="" Q:DIARA(".01")="" I $P(DIARA(".01"),DIARR(DIARY,.01))="" S DIARMT01=1 I $D(DIARR(DIARY,"ID")) D MATCHID I 'DIARMTID Q I DIARMT01 S DIARMTCH=1 Q ; MATCHID F DIARZID=0:0 S DIARZID=$O(DIARR(DIARY,"ID",DIARZID)) Q:DIARZID'>0 D MATCHID1 Q:DIARMTID=0 I DIARMTID,'$D(DIARR(DIARY,".01")) S DIARMTCH=1 S DIARIDDN=1 Q ; MATCHID1 Q:DIARR(DIARY,"ID",DIARZID)="" Q:DIARA("ID",DIARZID)="" I $P(DIARA("ID",DIARZID),DIARR(DIARY,"ID",DIARZID))="" S DIARMTID=1 Q S DIARMTID=0 Q ; FOUND S DIARFND=1 I $D(DIARIDX) S DIARIXX(DIARIXCT)=DIARIXX(DIARIXCT)_DIARY_"," Q S %X="^TMP(""DIARFG"",$J,",%Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY)+1," D %XY^%RCR S DIARRF(DIARY)=DIARRF(DIARY)+1 Q ; EOP S DIARZ=0,DIARFGEN=0 K ^TMP("DIARFG",$J),DIARA Q DIARR3 DIARR3 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG ;3/15/93 7:55 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q:'DIARFND U IO(0) W !,"Formatting found records..." S (DIARTAB,DIAROREQ,DIAROM,DIAROZ,DIARZZ,DIAROIDF,DIAROFLD,DIAROLVL,DIAROBPT,DIAROBFN)=0,DIAROFLD(DIAROLVL)=0 K ^TMP("DIARO",$J) F S DIAROREQ=$O(^TMP("DIAR",$J,DIAROREQ)) Q:DIAROREQ'>0 F S DIAROM=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM)) Q:DIAROM'>0 D CLEANUP^DIARR4 F S DIAROZ=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ)) Q:DIAROZ'>0 S DIAROX=^(DIAROZ) D EN Q EN Q:DIAROX["$END DAT"!(DIAROX="") S DIAROX1=$P(DIAROX,":") I $P(DIAROX,U)="$DAT" S DIAROSF=$P(DIAROX,U,2),DIAROSFN=+$P(DIAROX,U,3),DIAROLNE="ARCHIVE FILE: "_DIAROSF_" (#"_DIAROSFN_")" D SET D SV Q Q:DIAROX["$END DAT" EN1 I DIAROX1="BEGIN" D BEGIN D SV Q I DIAROX1="END" D END D SV Q I DIAROX1="IDENTIFIER"!(DIAROX1="SPECIFIER")!(DIAROX1="KEY") D ID D SV Q I $L(DIAROX,U)=3,"AMLD"[$P($P(DIAROX,U,3),"=") G:$P(DIAROX,"=",2)?1"@".N1"E" BE^DIARR4 D F1 I DIAROSFN=+$P(DIAROX,U,2) D SV Q I DIAROX="^"!(DIAROX=":") D POP^DIARR4 D SV Q I $E(DIAROX1)="""" S DIAROLNE=$E(DIAROX1,2,$L(DIAROX1)-1) D SET Q D FLDS SV S DIAROXPL=DIAROX Q BEGIN S DIAROBF=$P($P(DIAROX,U),":",2),DIAROBFN=+$P(DIAROX,U,2),DIARTAB=DIARTAB+2,DIAROLVL=DIAROLVL+1,DIAROSTK(DIAROLVL)=DIAROBF_U_DIAROBFN_U_DIARTAB,DIAROIDF(DIAROLVL)=0,DIAROFLD(DIAROLVL)=0 S DIAROSUB="@"_$P(DIAROX,"@",2),DIAROAT(DIAROSUB)=$S(DIAROXPL["@":"@"_$P(DIAROXPL,"@",2),1:$P(DIAROXPL,"=",2)) I DIAROBPT D SUB Q I DIAROZ=3 G BEGLN1 I $P(DIAROXPL,U,2)[":" S DIAROLNE="FILE: " D SUB G BEGLN I $P(DIAROXPL,":")="BEGIN" S DIAROLNE=".01 POINTER TO FILE: " G BEGLN I $L(DIAROXPL,U)=3,"AMLD"[$P($P(DIAROXPL,U,3),"=") S DIAROLNE="SUBFILE: " D SUB G BEGLN I $L(DIAROXPL,U)=2 S DIAROLNE="POINTER TO FILE: " BEGLN S DIAROLNE=DIAROLNE_DIAROBF_" (#"_DIAROBFN_")" D SET BEGLN1 I $D(DIAROLUP(DIAROBF)) S DIARTAB=$P(DIAROSTK(DIAROLVL),U,3),DIAROLNE=$P(DIAROLUP(DIAROBF),U) D SET K DIAROLUP(DIAROBF) Q SUB S DIAROSUB(DIAROBFN)=1_U_DIARTAB Q END S (DIAROIDF(DIAROLVL),DIAROFLD(DIAROLVL))=0,DIAROBF=$P(DIAROSTK(DIAROLVL),U),DIAROBFN=$P(DIAROSTK(DIAROLVL),U,2) I $D(DIAROSUB(DIAROBFN)) S DIARTAB=DIARTAB-2 Q S:DIAROLVL'=1 DIAROLVL=DIAROLVL-1 Q ID I DIAROIDF(DIAROLVL)=0 S DIAROLNE="IDENTIFIERS: ",DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+2 D SET S DIAROIDF(DIAROLVL)=1 S DIAROLNE=$P($P(DIAROX,U),":",2)_" (#"_+$P(DIAROX,U,2)_") = "_$P(DIAROX,"=",2),DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+4 D SET Q FLDS S DIAROBCK=0 I DIAROLVL=1,DIAROFLD(DIAROLVL)=0 S DIAROLNE="FIELDS: ",DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+2 D SET S DIAROFLD(DIAROLVL)=1 S (DIAROVAL,DIAROLUP)=$P(DIAROX,"=",2),DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+4 I $L(DIAROX,U)=3 S DIAROBF1=$P(DIAROX,U,2) I $E(DIAROBF1,$L(DIAROBF1))=":" D BKPTR^DIARR4 Q I +$P(DIAROX,U,2),DIAROVAL["" S DIAROLNE="FIELD NAME: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_") = " D LKUP^DIARR4:$E(DIAROVAL)="@" G:DIAROBCK FLDS I $D(DIAROSUB)=11 S DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+2 S DIAROLNE=DIAROLNE_DIAROVAL D SET Q S:$D(DIAROXX) DIAROX=DIAROXX K DIAROXX Q SET S DIAROTAB="" S:DIARTAB $P(DIAROTAB," ",DIARTAB)=" " S DIARZZ=DIARZZ+1,DIAROLNE=DIAROTAB_DIAROLNE S ^TMP("DIARO",$J,DIAROREQ,DIAROM,DIARZZ)=DIAROLNE Q F1 S DIAROLUP($P(DIAROX,U))="LOOKUP VALUE (#.01): "_$P(DIAROX,"=",2) Q DIARR4 DIARR4 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG(CONT) ;3/15/93 8:54 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CLEANUP K DIAROSF,DIAROSFN,DIAROBF,DIAROBFN,DIAROFLD,DIAROIDF,DIAROSUB,DIAROLUP S (DIARTAB,DIAROIDF,DIAROFLD,DIAROLVL)=0 Q ; LKUP Q:$E(DIAROVAL)'="@" S DIAROVAL=$G(DIAROAT(DIAROVAL)) I $E(DIAROVAL)="@" G LKUP S DIAROXX=DIAROX,DIAROX=$P(DIAROX,"=")_"="_DIAROVAL,DIAROBCK=1 Q ; BKPTR S DIAROLNE="FILE SHIFT (Forward Pointer/Backward Pointer): " D SET^DIARR3 I DIAROX["=@",$G(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ+1))'["BEGIN:" S DIAROLNE="FILE: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_")" D SET^DIARR3 D SFT2 Q ; SFT2 S DIAROBPT=1,DIAROXX=DIAROX,DIAROX="BEGIN:"_$P(DIAROX,":")_$P(DIAROX,"=",2) D BEGIN^DIARR3 S DIAROBPT=0 S DIAROX=DIAROXX K DIAROXX Q ; POP S DIAROLVL=DIAROLVL-1 S:DIAROLVL=0 DIAROLVL=1 K DIAROSUB(DIAROBFN) Q ; BE S DIAROLVL=+$P($P(DIAROX,"=",2),"@",2) I $P(DIAROX,U)=$P(DIAROSTK(DIAROLVL-1),U) S DIAROSTK(DIAROLVL)=DIAROSTK(DIAROLVL-1) S DIAROZ=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ)),DIAROX2=^(DIAROZ) S DIAROLNE="FIELD NAME: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_") = "_$P(DIAROX2,"=",2) D SET^DIARR3 S DIAROLNE="SUBFILE: "_$P(DIAROX,U)_" (#"_$P(DIAROSTK(DIAROLVL),U,2)_") ",DIARTAB=$P(DIAROSTK(DIAROLVL),U,3) D SET^DIARR3 S DIAROLNE="LOOKUP VALUE (#.01): "_$P(DIAROX2,"=",2) D SET^DIARR3 S DIAROLNE="FIELD NAME: "_$P(DIAROX2,U)_" (#"_+$P(DIAROX2,U,2)_") = "_$P(DIAROX2,"=",2),DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+2 D SET^DIARR3 S DIARTAB=DIARTAB-4 Q DIARR5 DIARR5 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG)-PRINT REQUEST ;4/8/93 8:00 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. PRINT I $D(DIARQUED) G Q S IOP=DIARPDEV D ^%ZIS G Q:POP DQ S DIARPG=0 F DIARY=0:0 S DIARY=$O(DIARR(DIARY)) Q:DIARY'>0 D HD Q:$D(DTOUT)!($D(DIRUT)) D PRINT1:$D(^TMP("DIARO",$J,DIARY)) W:'$D(^TMP("DIARO",$J,DIARY)) !,?11,"MATCHES FOUND: ",DIARRF(DIARY) D ^%ZISC Q ; PRINT1 F DIARZ=0:0 S DIARZ=$O(^TMP("DIARO",$J,DIARY,DIARZ)) Q:DIARZ'>0!$D(DTOUT)!$D(DIRUT) W ! F DIARZ1=0:0 S DIARZ1=$O(^TMP("DIARO",$J,DIARY,DIARZ,DIARZ1)) Q:DIARZ1'>0 W ^(DIARZ1),! I $Y>(IOSL-2) D HD Q:$D(DTOUT)!$D(DIRUT) W !,?11,"MATCHES FOUND: ",DIARRF(DIARY) Q ; HD U IO I "C"[$E(IOST) K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DIRUT)) S Y=DT X ^DD("DD") W:$Y @IOF W "ARCHIVE RETRIEVAL LIST",?60,Y,?72,"PAGE: ",DIARPG+1 HD1 W !,"REQUEST: ",DIARY W:$D(DIARR(DIARY,.01)) !,?2,DIAR01," = ",DIARR(DIARY,.01) D HD2:$D(DIARR(DIARY,"ID")) S $P(DIARLINE,"-",IOM)="" W !,DIARLINE,! S DIARPG=DIARPG+1 Q ; HD2 F DIARX1=0:0 S DIARX1=$O(DIARR(DIARY,"ID",DIARX1)) Q:DIARX1'>0 W:DIARX1 !,?2,$P(DIARID(DIARX1),U)," = ",DIARR(DIARY,"ID",DIARX1) Q ; Q S ZTRTN="DQ^DIARR5",ZTDTH=$H,ZTSAVE("DIARR(")="",ZTSAVE("^TMP(""DIARO"",$J,")="",ZTSAVE("DIARRF(")="",ZTDESC="RETRIEVAL OF ARCHIVED DATA",ZTIO=DIARPDEV,ZTSAVE("DIAR01")="",ZTSAVE("DIARID(")="" D ^%ZTLOAD,HOME^%ZIS U IO(0) W !! I '$D(DIARQUED) W:POP "UNABLE TO OPEN SELECTED PRINTER AT THIS TIME. " W "OUTPUT QUEUED!" Q DIARR6 DIARR6 ;SFISC/DCM-PROCESS ARCHIVED FILE WITH INDEX ;11/18/92 11:49 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DIARFILE=$P(DIARL,U,3),DIARFN=+$P(DIARL,U,2) S DIARREC=$P(DIARL,U,4,99) F DIARXX=1:1 S DIARFLD=$P(DIARREC,U,DIARXX) Q:DIARFLD="" S DIARFNO=$P(DIARFLD,":"),DIARFNA=$P(DIARFLD,":",2) D . I +DIARFNO=.01 S DIAR01=DIARFNA . S DIARPC(DIARXX)=DIARFNO_U_DIARFNA . S:+DIARFNO'=.01 DIARID(DIARFNO)=DIARFNA_U_DIARFNO . S DIARCNT=DIARXX . Q S DIARCTR=0,DIARFLGT=0 F X DIARX Q:DIARL["$DAT" S DIARCTR=DIARCTR+1 F DIARXX=1:1:DIARCNT S DIARFLD=$P(DIARL,U,DIARXX) S DIARFNA=$P(DIARPC(DIARXX),U,2),DIARFNO=+DIARPC(DIARXX),^TMP("DIARHLP",$J,DIARCTR,DIARFNO)=DIARFNA_" = "_DIARFLD D FLGTH Q ; FLGTH S $P(DIARPC(DIARXX),U,3)=$S($L(DIARFLD)>+$P(DIARPC(DIARXX),U,3):$L(DIARFLD),1:+$P(DIARPC(DIARXX),U,3)) Q ; PROC S DIARIXCT=0 K DIARRF PROC1 F X DIARX Q:DIARL["$DAT" G PROC1:DIARL["$INDEX" D PROC2 D MATCH^DIARR2 K:'$G(DIARIXX(DIARIXCT)) DIARIXX(DIARIXCT) G PROC1 Q:'$D(DIARIXX) S (DIARIXCT,DIARXX)=1 D:$G(DIARIXX(DIARIXCT)) FOUND F S DIARXX=$O(DIARIXX(DIARXX)) Q:DIARXX'>0 D PROC1A Q ; PROC1A F X DIARX Q:DIARL["#$#" I DIARL["$DAT" S DIARIXCT=DIARIXCT+1 I DIARIXCT=DIARXX D FOUND Q Q ; PROC2 K DIARA S DIARIXCT=DIARIXCT+1,DIARIXX(DIARIXCT)="" F DIARXX=1:1:DIARCNT S DIARVAL=$P(DIARL,U,DIARXX) D PROC2A Q ; PROC2A I +$P(DIARPC(DIARXX),U)=.01 S DIARA(.01)=DIARVAL Q S DIARA("ID",+$P(DIARPC(DIARXX),U))=DIARVAL Q ; FOUND K ^TMP("DIARFG",$J) S DIARZ=1 D SET F DIARZ=DIARZ+1:1 X DIARX D SET I DIARL["$END DAT" Q F DIARZ=1:1 S DIARY=$P(DIARIXX(DIARIXCT),",",DIARZ) Q:DIARY="" S DIARRF(DIARY)=$S($D(DIARRF(DIARY)):DIARRF(DIARY)+1,1:0) D SETFG Q ; SET S ^TMP("DIARFG",$J,DIARZ)=DIARL Q ; SETFG S %X="^TMP(""DIARFG"",$J,",%Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY)," D %XY^%RCR Q DIARU DIARU ;SFISC/TKW-ARCHIVING FUNCTIONS (CONT) ;2/18/93 5:21 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. UPDATE ;UPDATE ARCHIVING FILE (DJ=#ITEMS SELECTED) called w/in DIO4 N DIE D:DIAR=3 NOW^%DTC S DA=DIARC,DIE="^DIAR(1.11,",X="" S:DIAR&(DIAR'=3) X="7////"_DIAR_";" S X=X_"13////@;14////@;15////@" I DIAR=1 S X=X_";4////"_DT_$S($D(^VA(200)):";8////"_DUZ,1:"")_";6////"_DJ I DIAR=3 S X=X_";12////"_% I DIAR=4!(DIAR=5)!(DIAR=6) S X=X_$S($D(^VA(200)):";5////"_DUZ,1:"")_";10////"_DT ;I DIAR=3!(DIAR=4),U'[DIARP S %=$P(DIARP,U,2),X=X_";3////"_$S(%:%,1:+DIARP) I DIAR=90 S X=X_$S($D(^VA(200)):";9////"_DUZ,1:"")_";11////"_DT S DR=X,DA=DIARC D ^DIE S DV="" Q ; FILE ;LOOKUP ARCHIVING ACTIVITY K DIC S DIC(0)="AEQIMZ",DIC="^DIAR(1.11,",DIC("S")="I $P(^(0),U,8)<90"_$S($D(DIAX):",$P(^(0),U,17)",1:",'+$P(^(0),U,17)"),DIC("A")="Select "_$S($D(DIAX):"EXTRACT",1:"ARCHIVAL")_" ACTIVITY: " D ^DIC Q:Y<0!$D(DUOUT)!$D(DTOUT) I $P(Y(0),U,14) D ER1 Q S DIARC=+Y,DIARF=$P(Y(0),U,2),DIARU=$P(Y(0),U,3),DIARP=$P(Y(0),U,4),DIARST=$P(Y(0),U,8) S:$D(DIAX) DIAXFNO=+$P(Y(0),U,18) I DIAR'=99,'DIARU W !!,$C(7),"No selection template used for this ARCHIVING ACTIVITY--CANCEL it!" K DIARC Q I (DIAR=2!(DIAR=4)),DIARST>2 D ER2 K DIARC Q I DIAR=5 W:DIARST=5 $C(7),!!,"This data has already been moved to permanent storage once !!",! I DIARST<4 D ER3 K DIARC Q I DIAR=6,DIARST=6 W !!,$C(7),"This data has already been moved to the destination file!",!,"PURGE data or CANCEL this extract activity." K DIARC Q I DIAR=90,$S($D(DIAX):DIARST'=6,1:DIARST'=5) D ER4 K DIARC Q I DIAR=99 D:DIARST=5 MSG I DIARST>6 D ER5 K DIARC Q S DIARF2=$S($D(^DIAR(1.11,+Y,1)):^(1),1:DIARF) S DIARX=Y(0) D:DIAR'=3 MRK S Y(0)=DIARX,DIC=$G(^DIC(+DIARF,0,"GL")) I DIC="" D ER6 S DIK="^DIAR(1.11,",DA=DIARC D ^DIK K DIK,DIARC Q Q ; MRK ;SET FIELDS TO LOCK OUT OTHER USERS DURING ARCHIVING ACTIVITY D NOW^%DTC S DIE="^DIAR(1.11,",DA=DIARC,DR="13////"_DIAR_";14////"_%_";15////"_DUZ D ^DIE Q ; ER1 W $C(7),!!!,"The following Archival Activity is in progress--no access allowed!",! S DIARX=Y(0),Y=$P(Y(0),U,14),C=$P(^DD(1.11,13,0),U,2) D Y^DIQ W Y_" STARTED: " S Y=$P(DIARX,U,15) X:Y ^DD("DD") W Y_" BY: " W:$S($D(^VA(200,+$P(DIARX,U,16),0)):1,1:$D(^DIC(3,+$P(DIARX,U,16),0))) $P(^(0),U,1) W ! Q ER2 I $D(DIAX) W !!,$C(7),"Data has already been moved to the destination file.",!,"List cannot be edited." Q W !!,$C(7),"This data has already been archived to "_$S(DIARST=4:"temporary",1:"permanent")_" storage" W:DIARST>5 " and purged" W ".",! W:DIAR=2 "List cannot be edited after data has been archived!" Q ER3 W !!,$C(7),"Cannot write to permanent storage until data has been written",!,"to temporary storage!!" Q ER4 W !!,$C(7),$S(DIARST>6:"Data ALREADY purged",$D(DIAX):"Data has NOT YET been moved to the destination file",1:"Data has NOT YET been archived to PERMANENT storage"),"!",! Q ER5 W !!,$C(7),"Cannot cancel archiving record after archiving has been complete--this now",!,"acts as your history!!" Q ER6 W !!,$C(7),"Source File is missing!",!,"I AM DELETING THIS ",$S($D(DIAX):"EXTRACT",1:"ARCHIVING")," ACTIVITY!" Q MSG W !!,$C(7),"Just a reminder--you have already archived these records to permanent storage.",!,"You probably won't want to save the sequential storage media since you",!,"are cancelling this archiving activity!!",! Q DIARX DIARX ;SFISC/DCM-ARCHIVING FUNCTION, BUILD INDEX ;8/12/98 10:25 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. IX K ^UTILITY("DIQ1",$J) N DIC S DIARREC=^DIAR(1.11,DIARC,0),(DIARIXF,DIC)=$P(DIARREC,U,2),DIARIXST=$P(DIARREC,U,3),(DA,DIARDR,DIARIX,DIARDA)="",DR=".01",DIARLINE=.01_":"_$P(^DD(DIARIXF,.01,0),U) N DIXIEN S DIXIEN=$O(^DD("KEY","AP",DIARIXF,"P",0)) I DIXIEN F S DIARDR=$O(^DD("KEY",DIXIEN,2,"BB",DIARDR)) Q:'DIARDR I DIARDR'=.01,$O(^(DIARDR,0))=DIARIXF,$D(^DD(DIARIXF,DIARDR,0)) D IDKEY F S DIARDR=$O(^DD(DIARIXF,0,"ID",DIARDR)) Q:DIARDR'>0 I DIARLINE'[("^"_DIARDR_":"),$D(^DD(DIARIXF,DIARDR,0)) D IDKEY S DIARBLNE=DIARLINE S DIARLINE="$INDEX"_U_DIARIXF_U_$P(^DIC(DIARIXF,0),U)_U_DIARLINE U IO W DIARLINE,! F S DA=$O(^DIBT(DIARIXST,1,DA)) Q:DA'>0 S DIQ(0)="E" D EN^DIQ1 F S DIARDA=$O(^DIBT(DIARIXST,1,DIARDA)) Q:DIARDA'>0 D IX1 K DIARREC,DIARIXF,DIARIXST,DA,DIARDR,DIARIX,DIARDA,DR,DIARLINE Q ; IDKEY ; Save KEY or Identifier data S DIARLINE=DIARLINE_U_DIARDR_":"_$P(^DD(DIARIXF,DIARDR,0),U) S DR=DR_";"_DIARDR Q Q ; IX1 S DIARLINE="" F S DIARIX=$O(^UTILITY("DIQ1",$J,DIARIXF,DIARDA,DIARIX)) Q:DIARIX'>0 S DIARLINE=DIARLINE_^(DIARIX,"E")_U W DIARLINE,! Q ; OUT I $D(DIARQUED) G QP S IOP=DIARPDEV D ^%ZIS G QP:POP DQ ;print archive activity report S DIARPG=0,DIARLINE="",DIARX=^DIAR(1.11,DIARC,0),DIARFI=$P(DIARX,U,2) U IO S Y=DT X ^DD("DD") S DIARXY=Y D HDR,BODY Q HDR W:$Y @IOF W !,"ARCHIVE ACTIVITY REPORT",?IOM-24,DIARXY,?IOM-10,"PAGE: ",DIARPG+1 S DIARPG=DIARPG+1,$P(DIARLINE,"-",IOM)="" W !,DIARLINE Q ; BODY W !!,"ARCHIVAL ACTIVITY: ",DIARC,!,"ARCHIVE DEVICE LABEL INFORMATION: ",$P(^DIAR(1.11,DIARC,0),U,19) W !,"PRIMARY ARCHIVED FILE: ",$P($G(^DIC(DIARFI,0)),U)_" (#"_DIARFI_")" W !,"ARCHIVER: ",$P($G(^VA(200,$P(DIARX,U,6),0)),U) W !,"SEARCH CRITERIA: " S DIARU=$P(DIARX,U,3),DIARXZ=0 F S DIARXZ=$O(^DIBT(DIARU,"O",DIARXZ)) Q:DIARXZ'>0 Q:'$D(^(DIARXZ,0)) W !,?5,^(0) W !!,"INDEX INFORMATION: ",! S (DIARTAB,DIARFLD)=0 F DIARXZ=1:1 S DIARFLD=$P($P(DIARBLNE,U,DIARXZ),":",2) Q:DIARFLD="" W DIARFLD S DIARTAB=DIARTAB+25 W ?DIARTAB F DIARXZ=0:0 S DIARXZ=$O(^UTILITY("DIQ1",$J,DIARFI,DIARXZ)) Q:DIARXZ'>0 D HDRC Q:$D(DTOUT)!$D(DIRUT) W ! S DIARTAB=0 F S DIARFLD=$O(^UTILITY("DIQ1",$J,DIARFI,DIARXZ,DIARFLD)) Q:DIARFLD'>0 W ^(DIARFLD,"E") S DIARTAB=DIARTAB+25 W ?DIARTAB W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***" I $E(IOST)'="C",$Y W @IOF D ^%ZISC Q ; HDRC Q:($Y+1DIB(1)) I $O(^DD(DIB,"AUDIT",""))]"" S (DUB,DFF)=DIB Q I 'DIB!(DIB>DIB(1)) G Q2 S FLDS="W DFF;C1;L9;""FILE"",.001;L9,.01;L20,.25;L15,1.1",DISUPNO=1 S L=0,DHD="AUDITED FIELDS",DIS(0)="I $D(^DD(DFF,D0,""AUDIT"")),""n""'[^(""AUDIT"")" S DIA=1,DIC="^DD(DFF,",DIOEND="G L^DIDC" D EN1^DIP ; GOTO Q2 ; end of 1 (LIST FIELDS BEING AUDITED) ; ; 2 ;;TURN DATA AUDIT ON/OFF ; N J,DUOUT,DIRUT,DA,DDA,DIAU,DIA,C,D,%,DIC,X,Y,DIR S (DDA,DIA)=0 D AU^DICRW I 'DIA Q 21 S DIC="^DD("_DIA_",",DIC(0)="QEANIZ",DA(1)=DIA S DIC("S")="I 1 S %=$P(^(0),U,2) I $E(%)'=""C""" 22 S DIC("W")="N %,%A S %A=$G(^(""AUDIT"")),%=$P(^(0),U,2) W:% $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"") S:% %A=$G(^(""AUDIT"")) W "" "",%A" D ^DIC I Y<0 K DIA G Q I $P(Y(0),U,2) S DA(1)=+$P(Y(0),U,2),DIC="^DD("_DA(1)_"," G 22 K DIC,DIR S DDA=+Y S:$D(^("AUDIT")) DIR("B")=^("AUDIT") S DIR(0)="0,1.1" D ^DIR I $D(DIRUT) Q:X'="@" S Y="n" D TURNON^DIAUTL(DA(1),DDA,Y) I $D(DIRUT) K ^DD(DA(1),DDA,"AUDIT") W !! ; GOTO 21 ; end of 2/21/22 (TURN DATA AUDIT ON/OFF) ; ; 3 ;;DATA AUDIT TRAIL PURGE ; S DIC("S")="I $D(^DIA(+Y)),'$D(^DD(+Y,0,""AUDPURGEFORBID"")) S DIAC=""AUDIT"",DIFILE=+Y D ^DIAC I DIAC" S DIA="" D AU^DICRW K DIC("S") G Q2:$D(DTOUT),Q2:Y<0,Q2:'$D(DIC) S DDA="DATA" D ALL G Q2:$D(DIRUT) I Y W !!,"..." K ^DIA(DIA) H 3 W "DELETED" G Q2 W ! S L="PURGE AUDIT RECORDS",DIOEND="D ENDKILL^DIAU",DISTOP=0 S FLDS="",DHD="PURGE OF AUDIT DATA: "_$O(^DD(DIA,0,"NM",0))_" FILE",DISUPNO=1 S DHIT="D KILLDIA^DIAU",DIACNT=0 D EN1^DIP K DISTOP,DHIT,DIK,DA,DIACNT ; GOTO Q2 ; end of 3 (DATA AUDIT TRAIL PURGE) ; ; ALL ; Confirm Purge of All Audit Records for Options 3 & 5 ; S DIR(0)="Y",DIR("B")="NO" S DIR("A")="DO YOU WANT TO PURGE ALL "_DDA_" AUDIT RECORDS" S DIR("??")="^W !!?5,""Answer 'YES' to purge all the "_DDA_" audit records for this file, or"",!?5,""answer 'NO' to sort out the records to be purged.""" D ^DIR Q:$D(DIRUT) I Y S DIR("A")="ARE YOU SURE" D ^DIR K DIR ; QUIT ; end of ALL ; ; KILLDIA ; DHIT Code for Option 3 (DATA AUDIT TRAIL PURGE) ; ; called from DHIT S X=$G(^DIA(DIA,D0,0)) K ^DIA(DIA,D0) S Y=$P(X,U) I Y K ^DIA(DIA,"B",Y,D0) S Y=$P(X,U,2) I Y K ^DIA(DIA,"C",Y,D0) S Y=$P(X,U,4) K ^DIA(DIA,"D",+Y,D0) S DIACNT=DIACNT+1 ; QUIT ; end of KILLDIA ; ; ENDKILL ; DIOEND Code for Option 3 (DATA AUDIT TRAIL PURGE) ; ; check danglers S $P(^(0),U,4)=$P($G(^DIA(DIA,0)),U,4)-DIACNT W !!,"...",! W $$DANGLE(DIA)," POINTERS FIXED." W !!,DIACNT," RECORDS PURGED." ; QUIT ; end of ENDKILL ; ; DANGLE(DIA) ; Clean Danglers for ENDKILL ; N A,B,D0,AA,C S C=0 F AA=1,2,4 S A=$E("BC D",AA),B="" D .F S B=$O(^DIA(DIA,A,B)) Q:B="" D ..F D0=0:0 S D0=$O(^DIA(DIA,A,B,D0)) Q:'D0 I $P($G(^DIA(DIA,D0,0)),U,AA)'=B K ^DIA(DIA,A,B,D0) S C=C+1 ; Q C ; end of $$DANGLE ; ; 4 ;;SHOW DD AUDIT TRAIL ; N DIR,DIRB,%DT S DIRB=$$EZBLD^DIALOG(7065) S DIR(0)="FO^^S:X=DIRB X=1900 S %DT=""EP"" D ^%DT",DIR("A")="Show Data Dictionary changes since",DIR("B")=DIRB S DIR("?")="Enter a date. All audited changes to Data Dictionaries, starting with that date, will be shown." D ^DIR I Y>0 D DISP^DIAUTL(Y) ; QUIT ; end of 4 (SHOW DD AUDIT TRAIL) ; ; 5 ;;DD AUDIT TRAIL PURGE ; S DIC("S")="I '$D(^DD(+Y,0,""DDAUDPURGEFORBID"")) S DIAC=""AUDIT"",DIFILE=+Y D ^DIAC I DIAC" S DIA="DDA",DDA="DD" D A^DICRW G Q:$D(DTOUT)!(Y<0)!'$D(DIC) D ALL G:$D(DIRUT) Q I Y S X=DIA D PR G Q W ! S L="PURGE DD AUDIT RECORDS",DIOEND="G M^DIAU",DISTOP=0,DISUPNO=1 S FLDS="",DHD="PURGE OF DD AUDIT: "_$O(^DD(DIA,0,"NM",0))_" FILE" S DHIT="S DIK=DCC,DA=D0,DIACNT=DIACNT+1 D ^DIK",DIACNT=0,DIC="^DDA(DDA," S DDA=DIA D EN1^DIP K DISTOP,DHIT,DIK,DA,DIACNT ; GOTO Q2 ; end of 5 (DD AUDIT TRAIL PURGE) ; ; PR ; Purge All Audit Records for a File & Its Subfiles for Option 5 ; N DIA S DIA=X N X K ^DDA(DIA) F X=0:0 S X=$O(^DD(DIA,"SB",X)) Q:X'>0 D PR ; QUIT ; end of PR ; ; M ; DIOEND Code for Option 5 (DD AUDIT TRAIL PURGE) ; S DDA=$O(^DDA(DDA)) I DDA'>0!(DDA-1>DIA) W !!,DIACNT," RECORDS PURGED." G QM S %=0,X=DDA D UP GOTO P:%,M:'% ; UP Q:'$D(^DD(X,0,"UP")) S X=^("UP") I X=DIA S %=1 Q GOTO UP ; P K ^UTILITY($J,0) S %X="DIPP(",%Y="DPP(" D %XY^%RCR S DPP=DIPP,L=0,DJ=DIJS,DPQ=DIPQ,M=DIMS,C=",",DIOSL=IOSL G ^DIO QUIT ; QM ; return to ^DIO4 from line tag M+3 ; GOTO STOP^DIO4 ; end of M/UP/P/QM ; ; 6 ;;MONITOR A USER ; N DIAUSR,%DT,DHIT,DWHEN,DIC,DIAUIDEN S DIC=200,DIC(0)="AQEM",DIC("A")="Select a USER who has signed on to this system: ",DIC("S")="I $G(^(1.1))" D ^DIC K DIC Q:Y<0 S DIAUSR=+Y D R1^DICRW ;Creates a DIC("S") that screens out files user has no access to S DIC("S")=DIC("S")_" I $D(^DIA(+Y,""D"",DIAUSR))",DIC=1,DIC(0)="QAEI",DIC("A")="Select AUDITED File: " S Y=$G(^DISV(DUZ,"^DIC(")) I Y X DIC("S") I S DIC("B")=Y D ^DIC K DIC Q:$G(Y)'>0 S DIA=+Y,DIAUIDEN=$G(^DD(DIA,0,"ID","WRITE")) K ^UTILITY("DIAU",$J) S B=0,%DT="AEPT",%DT("A")="START WITH DATE: FIRST// " D ^%DT S DWHEN=" SINCE "_$$DATE^DIUTL(Y) I Y<1 Q:X]"" S Y=0,DWHEN="" S A=$O(^DIA(DIA,"C",Y-.0001)) Q:'A S B=$O(^(A,0))-.01 F A=B:0 S A=$O(^DIA(DIA,"D",DIAUSR,A)) Q:'A S P=$G(^DIA(DIA,A,0)) I P D .I $D(^UTILITY("DIAU",$J,0,+P)) S $P(^(+P),U,2)=A Q .S ^UTILITY("DIAU",$J,0,+P)=A,DP=$$GET1^DIQ(DIA,+P,.01) S:DP]"" ^UTILITY("DIAU",$J,1,DP,+P)="" ;BY NAME ; WRITE ; Display Monitor a User Report ; S BY(0)="^UTILITY(""DIAU"","_$J_",1,",L(0)=2,FLDS="" S DHD="W ! D WUSRDHD^DIAU" S DIC=^DIC(DIA,0,"GL") S DIOEND="K ^UTILITY(""DIAU"","_$J_")",DHIT="D WUSR^DIAU(D0)" D EN1^DIP ; Q2 K DIA,A,B,DIJ,DP,P,BY,FLDS,DIS,DHD,DCC,L,DNP,DFF,DIB,DIJS,DIPQ,DIMS,DIPP,DUB,DIOEND ; QUIT ; end of 6/WRITE/Q2 (MONITOR A USER) ; ; WUSRDHD ; DHD Code for Option 6 (MONITOR A USER) ; ; called by DHD W $P(^DIC(DIA,0),U)," RECORDS ACCESSED BY ",$P(^VA(200,DIAUSR,0),U)," (DUZ=",DIAUSR,") ",DWHEN,?IOM-8,"Page ",DC,! W ?IOM-50,"EARLIEST ACCESS",?IOM-25,"LATEST ACCESS",! W $TR($J("",IOM)," ","-"),! ; QUIT ; end of WUSRDHD ; ; WUSR(Y) ; DHIT Code for Option 6 (MONITOR A USER) ; ; called by DHIT N X,DIAU,DIC,DITAB W $$GET1^DIQ(DIA,Y,.01) ;NAME S DITAB=IOM-50 D:DIAUIDEN]"" .;I IOM>131 W ?80 S $X=19 .;E D N^DIO2 W ?19 .S DIC=^DIC(DIA,0,"GL") I $G(@(DIC_"+Y,0)"))]"" X DIAUIDEN ;CALL ^DD(2,0,"ID","WRITE") WITH NAKED REFERENCE .I IOM<132 D N^DIO2 S DIAU=^UTILITY("DIAU",$J,0,D0),X=+DIAU W ?DITAB D W ?DITAB+25 S X=$P(DIAU,U,2) D:X .N Y S Y=$P(^DIA(DIA,X,0),U,2) X ^DD("DD") W Y D N^DIO2 ; QUIT ; end of WUSR ; ; EOR ; end of routine DIAU DIAUTL DIAUTL ;GFT/GFT - UTILITIES TO TURN ON AND TO ANALYZE FILEMAN AUDITS;24JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. TURNONDD(DIFILE,DIMODE) ;Turn on DATA DICTIONARY AUDITING --THIS IS NOW A NO-OP, BECAUSE WE AUDIT ALL DD CHANGES IN FILE .6!!!! K:$G(DIMODE)=1 DIMODE S DIMODE=$G(DIMODE,"Y") I DIMODE'="Y",DIMODE'="N" D BLD^DIALOG(200) Q I DIFILE<1.11 Q I '$D(^DIC(+DIFILE)) D BLD^DIALOG(401,DIFILE) Q S ^DD(DIFILE,0,"DDA")=DIMODE ;It's really just one SET! Q ; DISP(DDB) ;DISPLAY DD CHANGES FROM ^DDA SINCE DATE 'DDB' N DIA,FR,BY,TO,DHD,DDHD,DIC,L,POP,DDIO,DIOEND,DDTOUT,DIOSL,DIFIXPT,DIFIXPTH S DIFIXPT=1 ;KEEPS ^%ZIS FROM BEING CALLED IN ^DIP3 D ^%ZIS Q:POP S DDIO=IO U IO F DIA=0:0 S DIA=$O(^DDA(DIA)) Q:'DIA S FR=$O(^DDA(DIA,"D",DDB)) D:FR Q:$D(DDTOUT) .U IO W @IOF D DDHD .S DIC="^DDA("_DIA_",",BY="-(#.03)@",TO=DT+1,FLDS="[DIAUTL]",L=0 .S DIOEND="S:$G(DIOO1) DDTOUT=1",DIOSL=IOSL ;DHD="W ?0 D DDHD^DIAUTL",IOP=DDIO .D EN1^DIP U IO W @IOF D CLOSE^DIO4 Q DDHD S DDHD="DATA DICTIONARY CHANGES, "_$P($G(^DIC(DIA,0)),U)_" FILE(#"_DIA_")" S:DDB DDHD=DDHD_" since "_$$DATE^DIUTL(DDB) W DDHD,! W "FIELD ATTRIBUTE USER NUMBER",! W "------------------------------------------------------------------------------",! Q ; ; TURNON(DIFILE,FLDS,DIMODE) ;Turn on AUDITING for the FLDS named --MODE is either "y", "n" or "e" N D,DIFIELD,DIE,DR,DA,DIQUIET,DIEZS,D0,DQ,DI,DIC,X K:$G(DIMODE)=1 DIMODE S DIMODE=$E($G(DIMODE,"y")) I DIMODE'="y",DIMODE'="e",DIMODE'="n" D BLD^DIALOG(200) Q S DIQUIET=1,DIEZS=1 Q:DIFILE<1.11&(DIFILE-.4)&(DIFILE-.401)&(DIFILE-.402)&(DIFILE-.403)&(DIFILE-.5)&(DIFILE-.7)&(DIFILE-.84)&(DIFILE-.847) D DT^DICRW F DIFIELD=0:0 S DIFIELD=$O(^DD(DIFILE,DIFIELD)) Q:'DIFIELD D:$$FLDSINC(DIFILE,FLDS,DIFIELD) ON Q ON N DIOLD S DIOLD=$G(^DD(DIFILE,DIFIELD,"AUDIT")) I DIOLD=DIMODE Q ;It's already on S D=$P($G(^(0)),U,2) Q:D["C" I D D TURNON(+D,"**",DIMODE) Q ;Recursive! S DR="1.1////"_DIMODE,DIE="^DD("_DIFILE_",",DA(1)=DIFILE,DA=DIFIELD I DA=.001,DIMODE="y" Q ;CAN'T AUDIT NUMBER FIELD!! D ^DIE D IN^DIU0(DIFILE,DIFIELD),DDAUDIT(DIFILE,DIFIELD,1.1,DIOLD,DIMODE) I $G(^DD(DIFILE,0,"DIK"))]"" D EN2^DIKZ(DIFILE,"",^("DIK")) ;Recompile CROSS-REFS if auditing changes Q ; CHANGED(FILE,FLDS,FLAGS,ARRAY,START,END) ; ;Returns in @ARRAY the list of entries in FILE who had any of the fields in FLDS changed from START to END ;If FLAGS is "O", the Oldest values are saved in @ARRAY@(entry,field) N GLO,E,F,T,D,%I K @ARRAY S FLAGS=$G(FLAGS) S GLO=^DIC(FILE,0,"GL") I '$G(START) S START=0 I '$G(END) D NOW^%DTC S END=% S T=START D F S T=$O(^DIA(FILE,"C",T)) Q:T>END!'T D .F D=0:0 S D=$O(^DIA(FILE,"C",T,D)) Q:'D D ..S E=$G(^DIA(FILE,D,0)) Q:$P(E,U,6)="i"!'E ..I $D(@ARRAY@(+E)),FLAGS="" Q ..S F=+$P(E,U,3) Q:'$$FLDSINC(FILE,FLDS,F) ..I '$D(@(GLO_"+E)")),FLAGS="" Q ..S @ARRAY@(+E)="" I FLAGS["O",'$D(@ARRAY@(+E,F)) S @ARRAY@(+E,F)=$G(^DIA(FILE,D,2)) Q ; FIRST(DIQGR,ENTRY,FLDS) ; N LOF S LOF=1 G LOF LAST(DIQGR,ENTRY,FLDS) ;returns DATE^USER who most recently touched any of the FLDS in ENTRY in File DIQGR N LOF S LOF=-1 LOF N E,F,DILAST,DENTRY,L S DILAST="",DENTRY=+ENTRY I ENTRY["," D .F F=2:1 Q:'$D(^DD(DIQGR,0,"UP")) S DENTRY=$P(ENTRY,",",F)_","_DENTRY D E S DENTRY=ENTRY_"," F S DENTRY=$O(^DIA(DIQGR,"B",DENTRY)) Q:DENTRY-ENTRY D E Q DILAST ; E S E="" F S E=$O(^DIA(DIQGR,"B",DENTRY,E),LOF) Q:'E I $$FLDSINC(DIQGR,FLDS,+$P($G(^DIA(DIQGR,E,0)),U,3)) D Q:DENTRY=ENTRY&DILAST .Q:$P(^DIA(DIQGR,E,0),U,6)="i" ;Ignore INQUIRY .S L=$P(^(0),"^",2)_"^"_$P(^(0),"^",4)_"^"_$P($G(^(4.1)),U) .I LOF=-1,L>DILAST S DILAST=L .I LOF=1,DILAST>L!'DILAST S DILAST=L Q ; DATE(FILE,FIELD) ; D VALUE(FILE,FIELD,2) Q ; USER(FILE,FIELD) ; D VALUE(FILE,FIELD,4) Q ; VALUE(FILE,FIELD,TU) ;FILE' can be SubFile N DIACMP,ENTRY,I S ENTRY=+$G(D0) F I=1:1 Q:'$D(^DD(FILE,0,"UP")) S ENTRY=ENTRY_","_+$G(@("D"_I)),F=^("UP"),FIELD=$O(^DD(F,"SB",FILE,0))_","_FIELD,FILE=F D PRIOR(FILE,ENTRY,FIELD,.DIACMP) S D="" F S D=$O(DIACMP(D),-1) Q:'D S X=$S($G(TU):$P(^DIA(FILE,D,0),U,TU),1:DIACMP(D)) X DICMX Q:'$D(D) S X="" Q ; PRIOR(FILE,ENTRY,FIELD,OUT) ; N E F E=0:0 S E=$O(^DIA(FILE,"B",ENTRY,E)) Q:'E I $P($G(^DIA(FILE,E,0)),U,3)=FIELD S OUT(E)=$G(^(2)) Q ; FLDSINC(DIQGR,DR,DIAUTLF) ;is DIAUTLF within DR? -- from 'DIQGQ' routine I DR=""!'DIAUTLF Q 0 I DR="*" Q 1 N DIAUGOT,DIQGCP,DIQGDD,DIQGXDC,DIQGXDF,DIQGXDI,DIQGXDN,DIQGXDD S DIQGXDC=0,DIAUGOT=0,DIQGDD=1,DIQGCP="D" I '$D(DIQGR) N X S X(1)="FILE" G 202 S DIQGXDD="^DD("_DIQGR_")" S:DIQGR DIQGR=$S(DIQGDD:$$DD(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA)) I DIQGR="" N X S X(1)="FILE AND IEN COMBINATION" G 202 F DIQGXDI=1:1 S DIQGXDF=$P(DR,";",DIQGXDI),DIQGXDN=$P(DIQGXDF,":") Q:DIQGXDF="" D RANGE G GOT:DIAUGOT NOGOT Q 0 ; RANGE I DIQGXDC,$P(^DD(+DIQGXDC,.01,0),"^",2)'["W" S:DR="**" DIQGXDN=DIQGXDN_"*" Q:$L(DIQGXDN,"*")'=2 ;multiple I DIQGXDN'?.N,$L(DIQGXDN,"*")=2,$P(DIQGXDN,"*")]"",$D(@DIQGXDD@("B",$P(DIQGXDN,"*"))) S DIQGXDN=$O(^($P(DIQGXDN,"*"),""))_"*" I DIQGXDN?1.2"*" S DIAUGOT=1 Q Q:DIAUTLFF!'$D(^DD(T)) S F=T,FLD=$P(FLD,",",2,C) I FLD=.01,DAT>DATE,$P(^DIA(FILE,E,0),U,5)="A" K @TMP@(F,I) S @TMP@(F,I)=1 Q ;THAT ENTRY OR SUB-ENTRY DIDN'T EXIST AS OF DATE 2nd level will only be defined in this case I $G(FIELD),FLD-FIELD!(F-FIL) Q I '$D(@TMP@(F,I,FLD)) S @TMP@(F,I,FLD)=DAT_U_E Q I DAT>DATE Q I @TMP@(F,I,FLD)DAT Q $$D(2) ;We know what it was before deletion Q $$D(3) D(ON) S X=$G(^DIA(FILE,+$P(X,U,2),ON)) I $G(DIAUTLEX)["E" Q X N S,Y S S=$G(^(ON+.1)) I X]"",S="" D I Y>0 Q Y .N %DT S %DT="T" D ^%DT S S=$P(S,U) I S]"" Q S Q X ; DDAUDIT(B0,DA,A0,A1,A2) ;B0=File or SubFile, DA=Field, A0=Attribute #, A1=Old value, A2=New value N DDA,%,%T,%D,J,B3,I Q:'$D(DUZ)!'$G(DT) D IJ^DIUTL(B0) S A0=+$G(A0),A0=$P($G(^DD(0,A0,0)),U)_U_A0 K:$G(A1)="" A1 L:$G(A2)="" A2 D P^DICATTA Q DIAX DIAX ;SFISC/DCM-EXTRACT OPTIONS ;12/8/98 07:55 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. 0 S DIK="^DOPT(""DIAX""," G OPT:$D(^DOPT("DIAX",9)) S ^(0)="EXTRACT OPTION^1.01^" K ^("B") F I=1:1:9 S ^DOPT("DIAX",I,0)=$P($T(@I),";;",2) D IXALL^DIK OPT W ! S DIC=DIK,DIC(0)="AEQIZ" D ^DIC K DIC,DIK I Y'<0 S DI=+Y K Y D EN G 0 W ! K %,DIC,DIK,DI,DA,I,J,X,Y,DIAX Q ; EN S DIAX=1 D @DI Q ; 1 ;;SELECT ENTRIES TO EXTRACT G 1^DIAR ; 2 ;;ADD/DELETE SELECTED ENTRIES S DIAR=2 G ENTE^DIARB ; 3 ;;PRINT SELECTED ENTRIES S DIAR=3 G OUT^DIARA ; 5 ;;CREATE EXTRACT TEMPLATE W !!,"This option lets you build a template where you specify fields to extract",!,"and their corresponding mapping in the destination file." W !!,"For more detailed description of requirements on the destination file,",!,"please see your VA FileMan User Manual." S DI=1 G EN^DIFGO ; 4 ;;MODIFY DESTINATION FILE W !!,"This option allows you to build a file which will store data extracted from",!,"other files. When creating fields in the destination file, all data types" W !,"are selectable. However, only a few data types are acceptable for receiving",!,"extracted data." W !!,"Please see your User Manual for more guidance on building the destination file." D 41 G Q:'$D(DIAXDIC) D 61,Q Q 41 ; G ^DICATT 61 ; Q:$P(@(^DIC(DIAXDIC,0,"GL")_"0)"),U,4) K DIR S DIR("A")="ARCHIVE FILE",DIR(0)="YO",DIR("??")="^W !?5,""'YES' will not allow modifications or deletions of data or data dictionary"",!?5,""'NO' will place no restrictions on the file""" S DIR("B")=$S($P($G(^DD(DIAXDIC,0,"DI")),U)["Y":"YES",1:"NO") D ^DIR Q:$D(DTOUT)!$D(DUOUT) S (DIARCH,DIE)=$S(Y:"Y",1:"N") 62 ; D FLAG(DIAXDIC,DIE,DIARCH) K DIAXDIC,DIE,DIARCH Q H6 W !!?5,"'YES' will not allow editing or deleting existing file entries or adding",!?11,"new file entries" W !?5,"'NO' will place no restrictions on the file" Q 6 ;;UPDATE DESTINATION FILE N DIAR,DIARC,DIARP,DIARB,DIE,DA,DR,DTOUT,DIAXFNO,%ZIS,POP,ZTRTN,ZTSAVE S DIAR=6 D FILE^DIARU G Q:'$D(DIARC) N DIARP,DIE,DA,DR W !!,"You MUST enter an EXTRACT template name. This EXTRACT template will be used",!,"to populate your destination file." S DIE="^DIAR(1.11,",DA=DIARC,DR="3;I X=""^"" S Y="";S DIARP=X;S DIAXFNO=+$P(^DIPT(DIARP,0),U,9);17////^S X=DIAXFNO" D ^DIE G UNLK:$D(DTOUT)!'$D(DIARP) S DIARB=+$P(^DIAR(1.11,DIARC,0),U,3) D EN^DIAXM I $G(DIERR) G UNLK W $C(7),!,"If entries cannot be moved to the destination file, an exception report",!,"will be printed.",!!,"Select a device where to print the exception report." W !!,"QUEUEING to this device will queue the Update process." N %ZIS,POP,ZTRTN,ZTSAVE,DIAXIOP S %ZIS="Q",%ZIS("A")="EXCEPTION REPORT DEVICE: ",%ZIS("B")="" D ^%ZIS G UNLK:POP S DIAXIOP=ION I $D(IO("Q")) S ZTRTN="DQ^DIAXU",(ZTSAVE("DIARP"),ZTSAVE("DIARB"),ZTSAVE("DIARC"))="",ZTSAVE("DIAXIOP")="",ZTIO="" D ^%ZTLOAD G UNLK D DIAX^DIAXU Q ; 7 ;;PURGE EXTRACTED ENTRIES S DIAR=90 G ENTD^DIARA ; 8 ;;CANCEL EXTRACT SELECTION S DIAR=99 G ENTC^DIARA ; 9 ;;VALIDATE EXTRACT TEMPLATE N X,DIC,Y S DIC="^DIPT(",DIC(0)="ASQEM",DIC("A")="Select EXTRACT TEMPLATE: ",DIC("S")="I $P(^(0),U,8)=2" D ^DIC Q:Y'>0 S DIARP=+Y,DIAR="" D EN^DIAXM D Q G 9 ; UNLK N DIAR S DIAR="" D UPDATE^DIARU Q D Q^DIARB Q ; FLAG(DIC,DIE,DIARCH) ; Q:'DIC Q:'$D(^DD(DIC,0)) S $P(^DD(DIC,0,"DI"),U)=DIARCH,$P(^DD(DIC,0,"DI"),U,2)=DIE Q DIAXD DIAXD ;SFISC/DCM-GET SOURCE DATA ;9/6/96 15:17 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ; N DILL,FRFILE,TOFILE,DIAXIEN,DIAXI,DIAXFR,DIAXTO,DATAFR,DATALST,Z S (DILL,DIAXI)=$G(DILL)+1,FRFILE=@DIAXTFR@(DILL,"FR"),TOFILE=@DIAXTFR@(FRFILE,"TO"),Z="," S DIAXFR="^TMP($J,""DIAXFR"")",DIAXTO="^TMP($J,""DIAXTO"")",DATAFR="^TMP($J,""DATAFR"")",DATALST="^TMP($J,""DATALST"")" D Q,TOP I $G(DIERR) D Q Q D NEXTLVL Q K @DIAXFR,@DIAXTO,@DATAFR K:$G(DIERR) ^TMP("DIAX",$J) Q TOP ; N FRIENS,TOIENS S (FRIENS,@DIAXFR@(FRFILE,"IENS"))=DIAXFE_Z S (TOIENS,@DIAXTO@(TOFILE,"IENS"),@DIAXTO@(FRFILE,"IENS",FRIENS))=$$DIAXIEN() D GETFDA(FRIENS,TOIENS) Q GETFDA(FRIENS,TOIENS) ; D GETS Q:$G(DIERR) D FDA Q GETS ; N DR,FLAGS,FIELDS F S DR=$G(DR)+1 Q:'$G(@DIAXTFR@(FRFILE,"DR",DR)) D Q:$G(DIERR) . S FLAGS="EIN" . S FIELDS=@DIAXTFR@(FRFILE,"DR",DR) . D GETS^DIQ(FRFILE,FRIENS,FIELDS,FLAGS,DATAFR,DIAXERR) D:$G(DIERR) ERR Q FDA ; N A,B,C S A=0 F S A=$O(@DATAFR@(FRFILE,FRIENS,A)) Q:A'>0 F C=0,1 S B=$G(@DIAXTTO@(FRFILE,A,C)) D:B]"" Q:$G(DIERR) . I $O(@DATAFR@(FRFILE,FRIENS,A,0)) S ^TMP("DIAX",$J,TOFILE,TOIENS,+$P(B,U,2))=U_$P($$GET1^DIQ(FRFILE,FRIENS,A,"B"),U,2) Q . S ^TMP("DIAX",$J,TOFILE,TOIENS,+$P(B,U,2))=$S(+$P(B,U,3):@DATAFR@(FRFILE,FRIENS,A,"E"),1:@DATAFR@(FRFILE,FRIENS,A,"I")) I '$D(^TMP("DIAX",$J,TOFILE,TOIENS,.01)) S ^TMP("DIAX",$J,TOFILE,TOIENS,.01)=$$GET1^DIQ(FRFILE,FRIENS,.01,"I","",DIAXERR) D:$G(DIERR) ERR K @DATAFR Q GETLIST ; N SCR,A,B S SCR=$G(DIAXSCR(FRFILE)) S FRIENS=$G(FRIENS),PART=$G(PART),INDEX=$G(INDEX) K @DATALST D LIST^DIC(FRFILE,FRIENS,"","","","",PART,INDEX,.SCR,"",DATALST,DIAXERR) I $G(DIERR) D ERR,Q1 Q I '$P(@DATALST@("DILIST",0),U) D Q1 Q I $G(PART)]"" S FRIENS=Z_@DIAXFR@(PARENT,"IENS") S A=0 F S A=$O(@DATALST@("DILIST",2,A)) Q:A'>0 S B=@DATALST@("DILIST",2,A),@DIAXFR@(FRFILE,"IENS",$E(FRIENS,2,99),B_FRIENS)="" Q1 K @DATALST,PART,INDEX Q TOIENS ; N A,B S A="" F S A=$O(@DIAXFR@(FRFILE,"IENS",FRIENS,A)) Q:A="" S B=$$DIAXIEN(),@DIAXTO@(FRFILE,"IENS",A)=B_@DIAXTO@(PARENT,"IENS",FRIENS) Q GETDATA ; Q:'$D(@DIAXTFR@(FRFILE,"DR")) N A,ZFRIENS S A="",ZFRIENS=FRIENS N FRIENS F S A=$O(@DIAXFR@(FRFILE,"IENS",ZFRIENS,A)) Q:A="" S FRIENS=A D Q:$G(DIERR) . N TOIENS . S TOIENS=@DIAXTO@(FRFILE,"IENS",FRIENS) . D GETFDA(FRIENS,TOIENS) Q:$G(DIERR) . I $D(DIAXFILE(FRFILE)) D Q . . N Y,DIERZ . . D RECURSE . . I $G(DIERZ) N DIERR,Y S Y("IEN")=DIAXFE D BLD^DIALOG(1300,"",.Y) D STE^DIAXU() Q MULT(FRIENS) ; S FRIENS=Z_FRIENS D GETLIST Q:$G(DIERR) S FRIENS=$E(FRIENS,2,99) D TOIENS D GETDATA Q ERR ; Q:'$D(FRFILE)!('$D(FRIENS)) Q:'$D(DIAXFILE(FRFILE)) D STE^DIAXU(FRFILE,FRIENS) Q NEXTLVL ; F DIAXI=$G(DIAXI):0 S DIAXI=$O(@DIAXTFR@(DIAXI)) Q:'$D(@DIAXTFR@(+DIAXI,"FR")) D NEXTLVL2 Q:$G(DIERR)!(DIAXI="") Q NEXTLVL2 ; N FRFILE,TOFILE,PARENT,DILL,FRIENS,TOIENS,TAG S FRFILE=@DIAXTFR@(DIAXI,"FR"),TOFILE=@DIAXTFR@(FRFILE,"TO"),PARENT=^("PRT"),DILL=^("P2"),TAG=^("P4") D @TAG Q 3 ; I $D(DIAXFILE(FRFILE)) D FILE Q:$G(DIERR) I DILL=2 S FRIENS=@DIAXFR@(PARENT,"IENS") D MULT(FRIENS) Q N A,B S (A,B)="" F S B=$O(@DIAXFR@(PARENT,"IENS",B)) Q:B="" D . F S A=$O(@DIAXFR@(PARENT,"IENS",B,A)) Q:A="" D Q:$D(DIAXFILE(PARENT)) . . S FRIENS=A D MULT(FRIENS) Q:$G(DIERR) Q 2 ; N PTRFLD,FRIENS,PTRIEN,A,B S PTRFLD=$P(@DIAXTFR@(FRFILE,"P5"),":") I DILL=2 S FRIENS=@DIAXFR@(PARENT,"IENS") D 21 Q S (A,B)="" F S B=$O(@DIAXFR@(PARENT,"IENS",B)) Q:B="" D Q:$G(DIERR)!('PTRIEN) . F S A=$O(@DIAXFR@(PARENT,"IENS",B,A)) Q:A="" D Q:$G(DIERR)!'(PTRIEN)!($D(DIAXFILE(PARENT))) . . S FRIENS=A D 21 Q 21 N TOIENS S PTRIEN=$$GET1^DIQ(PARENT,FRIENS,PTRFLD,"I","",DIAXERR) D:$G(DIERR) Q:$G(DIERR)!('PTRIEN) . N FRFILE . S FRFILE=PARENT . D ERR S FRIENS=PTRIEN_Z S TOIENS=@DIAXTO@(PARENT,"IENS",A) D GETFDA(FRIENS,TOIENS) Q 4 ; N PART,INDEX,FRIENS S PART=$$GET1^DIQ(PARENT,@DIAXFR@(PARENT,"IENS"),.01,"I","",DIAXERR) D:$G(DIERR) Q:PART']""!$G(DIERR) . N FRFILE,FRIENS . S FRFILE=PARENT . S FRIENS=@DIAXFR@(PARENT,"IENS") . D ERR S INDEX=@DIAXTFR@(FRFILE,"P7") I $D(DIAXFILE(FRFILE)) D FILE Q:$G(DIERR) S FRIENS="" D GETLIST Q:$G(DIERR) S FRIENS=@DIAXFR@(PARENT,"IENS") D TOIENS,GETDATA Q DIAXIEN() ; S DIAXIEN=$G(DIAXIEN)+1 Q "+"_DIAXIEN_Z FILE ; Q:'$D(^TMP("DIAX",$J)) N IEN S IEN="^TMP($J,""IEN"")" D Q2,UPDATE^DIE("E","^TMP(""DIAX"",$J)",IEN,DIAXERR) I $G(DIERR) D Q . K ^TMP("DIAX",$J) . D ERR N %,NODE,A,B,FI,VAL,DA S %=0,NODE=DIAXTO I $G(@IEN@(1)) S DIAXDA=^(1),FI=0,FI=$O(@NODE@(FI)) E S FI=FRFILE F S %=$O(@IEN@(%)) Q:'% S DA=@IEN@(%) D VAL Q2 K @IEN Q VAL S NODE=DIAXTO,NODE=$NA(@NODE@(FI)) F S NODE=$Q(@NODE) Q:NODE'["DIAXTO" Q:$QS(NODE,5)'[$G(FRIENS) S VAL=@NODE I VAL[("+"_%_Z) S VAL=$P(VAL,"+"_%_Z,1)_DA_Z_$P(VAL,"+"_%_Z,2) S @NODE=VAL D . S A=$QS(NODE,3),B=$QS(NODE,5) . Q:(A'=DIAXF)&('$D(DIAXFILE(A))) . Q:A=""!(B="") . I A=DIAXF S B=+B,VAL=+VAL . S @DIAXRSLT@("RESULT",A,B)=VAL Q RECURSE ; N DIAXIZ,DILLZ,DIERR S DIAXIZ=DIAXI,DILLZ=DILL D NEXTLVL,FILE N NODE,SUB,FILE S FILE=FRFILE F S FILE=$O(@DIAXFR@(FILE)) Q:'FILE F NODE=$NA(@DIAXFR@(FILE)),$NA(@DIAXTO@(FILE)) F S NODE=$Q(@NODE) Q:NODE'["IENS" S SUB=$QS(NODE,5) I SUB[FRIENS K @NODE K @DIAXFR@(FRFILE,"IENS",ZFRIENS,FRIENS),@DIAXTO@(FRFILE,"IENS",FRIENS) S DIAXI=DIAXIZ,DILL=DILLZ,A="" I $G(DIERR) K DIAXDA S DIERZ=1 Q DIAXERR DIAXERR ;SFISC/DCM-EXTRACT MAPPING UTILITIES ;5/1/96 16:49 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ERR(A) ; Q:'$D(A) N DIAXMSG S DIPG=+$G(DIPG),DIERR=($G(DIERR)+1)_U_($P($G(DIERR),U)+1) S DIAXMSG=$S(+A:$P($T(@(+A)),";",3),1:A) I DIPG S ^TMP("DIERR",$J,+DIERR)="",^(+DIERR,"TEXT",1)=DIAXMSG Q E D EN^DDIOL(DIAXMSG) Q 5 ;;Destination file does not exist 6 ;;Mapping information does not exist 7 ;;Extract field does not exist 8 ;;Field in destination file does not exist DIAXF DIAXF ;SFISC/DCM-FILE EXTRACTED DATA ;5/13/96 14:01 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ; Q:'$D(^TMP("DIAX",$J)) N DIAXDAZ S DIAXDAZ="^TMP(""DIAXDAZ"",$J)" K @DIAXDAZ D UPDATE^DIE("E","^TMP(""DIAX"",$J)",DIAXDAZ,DIAXERR) I $G(DIERR) D Q . K ^TMP("DIAX",$J) I $D(@DIAXDAZ) D Q . . N NODE,DA,DIK S NODE=$Q(@(DIAXDAZ)) . . S DA=@NODE,DIK=DIAXDFRT . . D ^DIK K @DIAXDAZ Q S DIAXDA=@($Q(@DIAXDAZ)) K @DIAXDAZ Q DIAXG DIAXG ;SFISC/DCM-UPDATE DESTINATION FILE ;6/11/93 11:32 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; EN I $G(DIAXNTC)'=DIARP D EN^DIAXM G EOJ:$D(DIAXMSG) S DIAXNTC=DIARP ; EN1 K ^TMP("DIAX",$J),DIAXDA D INIT^DIAXGI,BODY,EOJ Q ; BODY D BASE Q:$D(DIAXMSG) D NEXTLVL Q ; BASE D ^DIAXGU Q:$D(DIAXMSG) D FIELDS D ^DIAXU1 Q:$D(DIAXMSG) S DIAXDA=^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DA") Q ; NEXTLVL S DIAX(DILL,"DIAXI")=DIAXI,DILL=DILL+1 F DIAXI=DIAXI:0 S DIAXI=$O(^DIPT(DIARP,1,DIAXI)) Q:DIAXI'=+DIAXI S X=^(DIAXI,0) D NEXTLVL2 Q:DIAXI=""!$D(DIAXMSG) S DILL=DILL-1,DIAXI=DIAX(DILL,"DIAXI") Q ; NEXTLVL2 I $P(X,U,2)200 D DR S DR="",DIAXDRR="" D DR:DR]"" K DIAX2,DIAXDRZ Q ; EN ; DR I '$D(DIAX(DILL,"MUL")) S DIC=DIAX(DILL,"FILE"),DA=DIAX(DILL,"FE") S DIQ(0)="IEN" D EN^DIQ1 K DIQ F DIAX2(DILL,"FLD")=0:0 D DR2 Q:DIAX2(DILL,"FLD")'=+DIAX2(DILL,"FLD") S X=^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"),$S($G(DIAXEXT(DIAX2(DILL,"FLD"))):"E",1:"I")) D FIELD D ET I '$D(DIAX(DILL,"MUL")) K DA,DIC,DR,DIAXDRR,DIAXDR,DIAXEXT K ^UTILITY("DIQ1",$J,DIAX(DILL,"FILE")),DRX Q ; DR2 S DIAX2(DILL,"FLD")=$O(^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"))) Q:DIAX2(DILL,"FLD")="" I $O(^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"),0)) S V("WP")=0,^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),DIAX2(DILL,"FLD"),"I")="wp" Q ; FIELD D:$L(DIAXDRR)+$L(X)>235 ET Q:'$D(DIAXDR(DIAX2(DILL,"FLD"))) I DIAXDR(DIAX2(DILL,"FLD"))=".01" S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"X")=X G F2 S:X[";" ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),DIAXDR(DIAX2(DILL,"FLD")))=X S:'$D(V) DIAXDRR=DIAXDRR_DIAXDR(DIAX2(DILL,"FLD"))_"///"_$S(X'[";":X,1:"^S X=^TMP(""DIAX"",$J,"_DIAXET(DILL,"FILE")_","_DIAXDR(DIAX2(DILL,"FLD"))_")")_";" D:$D(V)>9 WP F2 K X,V Q ; WP S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),DIAXDR(DIAX2(DILL,"FLD")),"DTO(1)")=^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"GL"),^("DTL")=1 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),DIAXDR(DIAX2(DILL,"FLD")),"DFR(1)")=DIAX(DILL,"FGBL")_DIAX(DILL,"FE")_","""_$P($P(^DD(DIAX(DILL,"FILE"),DIAX2(DILL,"FLD"),0),U,4),";")_""",",^("DFL")=1 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"WP",0)="",^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"WP",DIAXDR(DIAX2(DILL,"FLD")),0)="" Q ; ET I '$D(^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DR")) S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DR")=DIAXDRR G ET1 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DR",$G(DIAXDRZ)+1)=DIAXDRR,DIAXDRZ=$G(DIAXDRZ)+1 ; ET1 S DIAXDRR="" Q DIAXG2 DIAXG2 ;SFISC/DCM-EXTRACT SUBFILES ;9/2/94 06:35 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SUBFILE F DIAX(DILL,"FE")=0:0 S DIAX(DILL,"FE")=$O(@(DIAX(DILL,"FGBL")_DIAX(DILL,"FE")_")")) Q:DIAX(DILL,"FE")'=+DIAX(DILL,"FE")!($D(DIAXMSG)) D SUBENTRY Q ; SUBENTRY ; N DIAXOUT D DR S DR(DIAX(DILL,"FILE"))=.01 S DIAX(DILL,"MUL")=1 D ^DIAXGU Q:$D(DIAXMSG)!$G(DIAXOUT) D DR,DRS D ^DIAXU1 G X1:$D(DIAXMSG) D RECURSEM X1 K DIAX(DILL,"MUL"),DA,DR,DIAXDR,DIAXDRR,DIAXEXT,DIAX2,DRX Q ; DR K DR S I=0 F %=DIAX(DILL,"FILE"):0 Q:'$D(^DD(%,0,"UP")) S X=^("UP"),Y=$O(^DD(X,"SB",%,0)),DR(X)=Y,DA(%)=DIAX(DILL-I,"FE"),%=X,I=I+1 S DA=DIAX(DILL-I,"FE"),DIC=DIAX(DILL-I,"FILE"),DR=DR(%) K DR(%) Q ; DRS S DR(DIAX(DILL,"FILE"))="",DIAXDRR="" F DIAX2=0:0 S DIAX2=$O(^DIPT(DIARP,1,DIAXI,"F",DIAX2)) Q:DIAX2'=+DIAX2 I $D(^(DIAX2,0)) S DRX=^(0) D . S DR(DIAX(DILL,"FILE"))=DR(DIAX(DILL,"FILE"))_+DRX_";",DIAXDR(+DRX)=$P(DRX,U,3),DIAXEXT(+DRX)=$P(DRX,U,5) . I $L(DR(DIAX(DILL,"FILE")))>200 D EN^DIAXG1 S DR(DIAX(DILL,"FILE"))="" D EN^DIAXG1:DR(DIAX(DILL,"FILE"))]"" Q ; RECURSEM D NEXTLVL^DIAXG Q ; DIAXG3 ; FILE F DIAX(DILL,"FE")=0:0 D FILE2 Q:DIAX(DILL,"FE")=""!($D(DIAXMSG)) D ENTRY K X Q ; FILE2 S DIAX(DILL,"FE")=$O(@(DIAX(DILL,"FGBL")_""""_DIAX(DILL,"XREF")_""","_DIAX(DILL-1,"FE")_","_DIAX(DILL,"FE")_")")) Q ; ENTRY S DIAX(DILL,"NAV")=1 D ^DIAXGU Q:$D(DIAXMSG) K DIAX(DILL,"NAV") D ^DIAXG1 D ^DIAXU1 G X1:$D(DIAXMSG) D RECURSEF Q ; RECURSEF D NEXTLVL^DIAXG Q DIAXGI DIAXGI ;SFISC/DCM-EXTRACT INITIALIZATION ;11/10/92 2:56 PM ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. INIT S DIAXI=0,DILL=1 D FIRST Q ; FIRST S DIAXI=$O(^DIPT(DIARP,1,DIAXI)) Q:DIAXI'=+DIAXI S X=^(DIAXI,0) D FVARS Q ; FVARS S DILL=$P(X,U,2),DIAX(DILL,"FILE")=+X,DIAXET(DILL,"FILE")=$P(X,U,9),(DIAXET(DILL,"PRT"),DIAXET(DIAXET(DILL,"FILE")))=$P(X,U,10) I DILL=1 S DIAX(DILL,"FE")=DIAXFE I $P(X,U,4)=1 S DIAX(DILL,"FE")=DIAX(DILL-1,"FE") S DIAX(DILL,"XREF")=$S($P(X,U,4)=4:$P(X,U,7),1:$P(X,U,4)),%=$P(X,U,5) I $E(%,$L(%))=":" S DIAX(DILL,"NAV")=1 I $P(X,U,4)=2 S DIAX(DILL,"NAV")=2 D DIRECT K %,Y I $P(X,U,4)=3 S %=$P(X,U,3),%=$O(^DD(%,"SB",+X,0)),%=^DD(+$P(X,U,3),%,0),%=$P($P(^(0),U,4),";") S:+%'=% %=""""_%_"""" S DIAX(DILL,"FGBL")=DIAX(DILL-1,"FGBL")_DIAX(DILL-1,"FE")_","_%_"," K DIAX(DILL,"NAV") D FGBL Q S DIAX(DILL,"FGBL")=^DIC(DIAX(DILL,"FILE"),0,"GL") D FGBL Q ; DIRECT S DIAX(DILL,"FE")=0,%=$P(%,":") S:'$D(^DD(DIAX(DILL-1,"FILE"),"B",%)) %=$O(^(%)) S %=$O(^DD(DIAX(DILL-1,"FILE"),"B",%,0)) Q:%'=+% S Y=$P(^DD(DIAX(DILL-1,"FILE"),%,0),U,4),%("N")=$P(Y,";"),%("P")=$P(Y,";",2) S:+%("N")'=%("N") %("N")=""""_%("N")_"""" I $D(@(DIAX(DILL-1,"FGBL")_DIAX(DILL-1,"FE")_","_%("N")_")")) S Y=@("^("_%("N")_")"),DIAX(DILL,"FE")=$P(Y,U,%("P")) Q ; FGBL S DIAXFI=+$P(X,U,10) I 'DIAXFI Q I DILL=1 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"GL")=^DIC(DIAXET(DILL,"FILE"),0,"GL") Q S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"GL")=^TMP("DIAX",$J,DIAXFI,"GL")_$S(DIAXET(DILL,"FILE")'=DIAXFI:^TMP("DIAX",$J,DIAXFI,"DA")_$S($P(X,U,11)]"":","""_$P($P(X,U,11),";")_""",",1:","),1:"") S:$D(^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"WP")) ^("DTO(1)")=^("GL") S ^("DA(1)")=DIAXET(DIAXFI,"DA") I $G(DIAXET(DIAXFI,"DA(1)"))]"" F DIAXII=1:1 Q:'$D(DIAXET(DIAXFI,"DA("_DIAXII_")")) S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DA("_(DIAXII+1)_")")=DIAXET(DIAXFI,"DA("_DIAXII_")") K DIAXFI,DIAXII Q DIAXGU DIAXGU ;SFISC/DCM-EXTRACT FUNCTIONS ;9/2/94 06:40 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. LOOKUP D SETX G Q:$D(DIAXMSG)!$G(DIAXOUT) D ET Q K X,X1,^UTILITY("DIQ1",$J),DIQ Q ; SETX I '$D(DIAX(DILL,"MUL")) S DIC=DIAX(DILL,"FILE"),DA=DIAX(DILL,"FE"),DR=".01" I '$D(@(DIAX(DILL,"FGBL")_DA_",0)")) D ERR^DIAXERR(97,DIAXFN_U_DIAXFE_U_DIAX(1,.01)) D FIX^DIAXU2 Q S DIQ(0)="EIN" D EN^DIQ1 S X=^UTILITY("DIQ1",$J,DIAX(DILL,"FILE"),DIAX(DILL,"FE"),.01,"E"),X1=^("I") I DILL=1 S DIAX(DILL,.01)=X I $D(DIAX(DILL,"MUL")),$G(DIAXSCR(DIAX(DILL,"FILE")))]"" D .N X S X=X1 X DIAXSCR(DIAX(DILL,"FILE")) S:'$T DIAXOUT=1 Q ; ET I '$D(DIAX(DILL,"MUL")) K DA,DIC,DR I DIAX(DILL,"XREF")=2 S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"MODE")="M" Q S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"X")=X,^("MODE")="A" I $D(DIAX(DILL,"MUL"))!(DIAX(DILL,"XREF")?1A.E) S ^TMP("DIAX",$J,DIAXET(DILL,"FILE"),"DIC(""P"")")=DIAXET(DILL,"FILE") Q DIAXM DIAXM ;SFISC/DCM-PROCESS MAPPING INFORMATION ;6/16/93 4:04 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ASK S DIAXTAB=DL+DL-2 S:DJ DIAXTAB=DIAXTAB+1 I $D(DC(DC)),$P(DC(DC),U,3)]"",'DINS S DIAXDEF=$P($G(^DD(DIAXF,$P(DC(DC),U,3),0)),U)_"// " W !?DIAXTAB,"MAP ",DIAXDICA," TO ",DIAXEF,$S($D(DIAXSB):" SUB-FIELD: ",1:" FIELD: ") W:'DINS $G(DIAXDEF) R DIAXX:DTIME I '$T S (DTOUT,DIRUT)=1 Q I DIAXX="",$D(DIAXDEF) S X=$P(DIAXDEF,"//") G ASK1 I DIAXX=U S (DUOUT,DIRUT)=1 Q I $D(DIAXDEF),DIAXX="@" S $P(DC(DC),U,3)="" K DIAXDEF G ASK I DIAXX="" W !?DIAXTAB,$C(7),DIAXDICA," will not be extracted" K DIAXDICA Q S X=DIAXX ASK1 D DIC I Y'>0 W:X'["?" $C(7),"??",!?DIAXTAB,"Check available fields for mapping by typing '??'." G ASK I +$P(Y(0),U,2),$P(^DD(+$P(Y(0),U,2),.01,0),U,2)["W" S DIAX1=$P(Y(0),U,4),Y(0)=^(0),$P(Y(0),U,4)=DIAX1 S DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y K:+Y=.01 DIAXE01(DIAXFILE) D PR Q DIC K DIC,Y S DIAXS1="$P(^(0),U,2)",DIC="^DD("_DIAXF_",",DIC(0)="ZE"_$E("O",DC>0) D DICS S DIC("S")=DIC("S")_",'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U)" D ^DIC Q ; DICS I DIAXFT["W" S DIC("S")="I +"_DIAXS1_",$P(^DD(+"_DIAXS1_",.01,0),U,2)[""W""" Q I DIAXFT["C" S DIC("S")="I "_DIAXS1_"[""F""!("_DIAXS1_"["""_$S(DIAXFT["D":"D"")",1:"N"")") Q S DIC("S")="I "_DIAXS1_"["""_$S(DIAXFT["K":"K""",1:"F""")_$S(DIAXFT["D":"!("_DIAXS1_"[""D"")",DIAXFT["N"!(DIAXFT["P"&'$G(DIAXEXT)):"!("_DIAXS1_"[""N"")",1:"")_$S((DIAXFT["S"&'$G(DIAXEXT)):"!("_DIAXS1_"[""S"")",1:"") Q PR S DIAXTO=1,DIAXFR=0 D EN1 Q EN S DIPG=+$G(DIPG) N DIAXF W:'DIPG !!,"Excuse me, this will take a few moments...",!,"Checking the destination file...",! I '$P(^DIPT(DIARP,0),U,9)!('$D(^DIC(+$P(^DIPT(DIARP,0),U,9),0))) D ERR^DIAXERR(5) Q I '$D(^DIPT(DIARP,1,0)) D ERR^DIAXERR(6) Q F DIAX1=0:0 S DIAX1=$O(^DIPT(DIARP,1,DIAX1)) Q:DIAX1'>0 S DIAX41=^(DIAX1,0),(DIAXDK,DK)=+DIAX41,DIAXDL=$P(DIAX41,U,2),DIAXF=$P(DIAX41,U,9),DIAXEF=$O(^DD(DIAXF,0,"NM",0)) D D IX^DIAXMS . S DIAXLNK=+$P(DIAX41,U,4),DIAXE01(DIAXF)=$S(DIAXLNK>2:+$P(DIAX41,U,3),1:DIAXDK)_U_(DIAXLNK>2) . F DIAX2=0:0 S DIAX2=$O(^DIPT(DIARP,1,DIAX1,"F",DIAX2)) Q:DIAX2'>0 S DIAX42=^(DIAX2,0),DIAXEXT=+$P(DIAX42,U,5) D . . K DIC S X=+DIAX42,DIC="^DD(DIAXDK,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(7) Q . . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0) . . S DIAXFR=1,DIAXTO=0,DIAXTAB=0 D EN1 . . K Y,DIC . . I DIAXF#1 S DIAXSB=1 . . S X=$P(DIAX42,U,3),DIC="^DD(DIAXF,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(8) K DIAXFR Q . . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0) . . I +Y=.01 K DIAXE01(DIAXF) . . D PR,Q . . K DIAXSB I $D(DIAXE01) D F1^DIAXMS I $G(DIERR),'DIPG,DIAR=6 W !!,$C(7),"Sorry, I can not proceed with the update. Your destination file needs fixing",!,"first." I '$G(DIERR),'DIPG,DIAR="" W !,$C(7),"Template looks OK!" D Q,Q1^DIAXMS Q EN1 D IN Q:($D(DIAXMSG)&'$D(DIAR)) D EN^DIAXM1 Q IN S DIAXFT=$P(Y(0),U,2),DIAXFTY=$$TYP^DIAXMS(DIAXFT) Q:($D(DIAXMSG)&'$D(DIAR)) S DIAXA=$S($D(DIAXVPTR):"DIAXVFR",DIAXFR:"DIAXFR",1:"DIAXTO") S @(DIAXA_"(""TY"")")=DIAXFT,@(DIAXA_"(""NM"")")=Y(0,0),@(DIAXA_"(""TYP"")")=DIAXFTY I "FN"[DIAXFTY S DIAXHI=+$P($P(Y(0),U,5,9),">",2),DIAXLO=+$P($P(Y(0),U,5,9),"<",2) D HL(DIAXHI,DIAXLO) Q Q D Q^DIAXMS Q EN2 S DIAXDICA=Y(0,0),DIAXFR=1,DIAXTO=0,DIAXC=C,DIAXDJ=DJ,DIAXS=S,DIPG=0,DIAXTAB=+$G(DIAXTAB) D EN1 I $D(DIAXMSG)!$D(DIRUT) K Y D Q Q D ASK,Q Q HL(A,B) S:A]"" @(DIAXA_"(""HI"")")=+A S:B]"" @(DIAXA_"(""LO"")")=+B Q DIAXM1 DIAXM1 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;7/11/95 06:33 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN D @DIAXFTY Q:DIAXFR Q:$D(DIAXMSG) I DIAXFR("TYP")'=DIAXTO("TYP"),'$D(DIAXEXT) S DIAXEXT=1 D:'$D(DIAR) DJ Q ; F Q:DIAXFR!($D(DIAXMSG)) I DIAXFR("TY")["C" D CF^DIAXM2 Q I "FSP"[DIAXFR("TYP"),+DIAXFR("LO"),DIAXFR("LO")DIAXTO("HI") S DIAXE2=DIAXFR("HI") D E2 I DIAXFR("TY")["N",DIAXFR("LE")DIAXTO("HI") S DIAXE2=DIAXFR("LE") D E2 I DIAXFR("TY")["D",DIAXTO("LO")>14 S DIAXE2=14 D E1,E3 I DIAXFR("TY")["D",DIAXTO("HI")<14 S DIAXE2=14 D E2 Q ; N G N^DIAXM3 ; D G D^DIAXM3 ; P D XT I DIAXEXT D P^DIAXM2 Q:$D(DIAXMSG)!DIAXFR D HL^DIAXM(15,1) Q ; V D XT I DIAXEXT D V^DIAXM2 Q:$D(DIAXMSG)!DIAXFR D HL^DIAXM(30,3) Q ; C G C^DIAXM2 ; S I DIAXTO W:'$D(DIAR) !?DIAXTAB,$C(7),"Make sure the SET OF CODES are identical as the extract field." Q D XT D S^DIAXM2 Q ; W Q:DIAXFR I DIAXFR("TY")["L",DIAXTO("TY")'["L" D E3 S DIAXEM=DIAXEM_"be in 'L'ine mode." D X Q ; K Q ; E1 S DIAXE1="minimum" Q E2 S DIAXE1="maximum" E3 S DIAXEM=DIAXTO("NM")_" field in "_DIAXEF_$S($D(DIAXSB):" subfile",1:" file")_" should " Q:DIAXFTY["W" S DIAXEM=DIAXEM_"have a "_DIAXE1_" length of at least "_DIAXE2_" characters." X D ERR^DIAXERR(DIAXEM) K DIAXE1,DIAXE2 Q ; DJ S DIAXDJ=DIAXDJ+1 S ^UTILITY("DIFG",$J,DIAXC,DIAXDJ)=DIAXS_U_U_+Y_U_$P(Y(0),U,4)_U_$G(DIAXEXT) S S=DIAXS,DJ=DIAXDJ,C=DIAXC Q ; XT S DIAXEXT=+$G(DIAXEXT) I '$D(DIAR),$D(DC(DC)) S DIAXEXT=+$P(DC(DC),U,5) Q:'DINS Q:$D(DIAR) K DIR N Y S DIR(0)="Y",DIR("A")="Move EXTERNAL form of the data to the extract field",DIR("B")="Yes",DIR("?")="Answer YES if the RESOLVED value of data should be moved" D ^DIR K DIR Q:'Y S DIAXEXT=1 Q DIAXM2 DIAXM2 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;3/11/93 2:59 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. P K DIC ; P1 S DIC="^DD("_+$P($P(Y(0),U,2),"P",2)_",",DIC(0)="Z",X=.01 D ^DIC I Y'>0 S DIAXEM=DIAXFR("NM")_" points to missing pointed to file." D E Q S DIAXFTY=$$TYP^DIAXMS($P(Y(0),U,2)) Q:$D(DIAXMSG) I $P(Y(0),U,2)["P" G P1 Q:$D(DIAXVPTR) D EN1^DIAXM Q V S DIAXVPTR=1,DIAXZZ=0,DIAXVFLD=+Y,DIAXVFI=DK ; V1 F S DIAXZZ=$O(^DD(DK,DIAXVFLD,"V","B",DIAXZZ)) Q:DIAXZZ'>0 D V2 Q:$D(DIAXMSG) Q:$D(DIAXMSG) S DIAXFR("TY")=$S(DIAXFR("TY")["F":DIAXFR("TY"),1:"F"),DIAXFR("TYP")="F" S DIAXFR("LO")=$S(+DIAXFR("LO")+1:DIAXFR("LO"),1:3) S DIAXFR("HI")=$S(+DIAXFR("HI")+1:DIAXFR("HI"),1:45) S DIAXFT=DIAXFR("TY"),Y(0)=U_DIAXFT K DIAXVPTR D EN^DIAXM1 Q V2 S DIC="^DD(+DIAXZZ,",DIC(0)="Z",X=.01 D ^DIC I Y'>0 S DIAXEM="Missing pointed to file." D E Q I $P(Y(0),U,2)["P" D P1 Q:$D(DIAXMSG) D IN^DIAXM Q:$D(DIAXMSG) S DIAXFR("TY")=$S($G(DIAXFR("TY"))["F":DIAXFR("TY"),1:DIAXVFR("TY")) S:DIAXVFR("TY")["F" DIAXFR("LO")=$S(+$G(DIAXFR("LO"))DIAXVFR("HI"):+$G(DIAXFR("HI")),1:DIAXVFR("HI")) Q ; S S DIAXZ=$P(Y(0),U,3),DIAXZL=0,DIAXPC=$S(DIAXEXT:2,1:1) F DIAXZZ=1:1:$L(DIAXZ,";") S DIAXZY=$P(DIAXZ,";",DIAXZZ) Q:DIAXZY="" S DIAXZL=$S($L($P(DIAXZY,":",DIAXPC))>+DIAXZL:$L($P(DIAXZY,":",DIAXPC)),1:+DIAXZL),DIAXZLL=$S(+$G(DIAXZLL)DIAXTO("LE") D E1 S DIAXEM=DIAXEM_"be at least "_DIAXFR("LE")_" characters long." D E Q ; CF I DIAXFR("TY")["B",DIAXTO("LO")'=1 D E1 S DIAXEM=DIAXEM_"have a minimum length of 1." D E Q Q:DIAXFR("TY")["B" I DIAXFR("TY")["D",DIAXTO("LO")>7 D E1 S DIAXEM=DIAXEM_"a minimum length of at least 7." D E I DIAXFR("TY")["D",DIAXTO("HI")<7 D E1 S DIAXEM=DIAXEM_"a maximum length of at least 7." D E I DIAXFR("TY")["J",DIAXFR("LE")DIAXTO("HI") D E1 S DIAXEM=DIAXEM_"have a maximum length of at least "_DIAXFR("LE")_" characters." D E Q ; CD I DIAXFR("TY")["D",+DIAXTO("LO")!+DIAXTO("HI") D E1 S DIAXEM=DIAXEM_"not have set date ranges." D E Q ; E1 S DIAXEM=DIAXTO("NM")_" field in "_DIAXEF_$S($D(DIAXSB):" subfile",1:" file")_" should " Q ; E D ERR^DIAXERR(DIAXEM) Q DIAXM3 DIAXM3 ;SFISC/DCM-PROCESS MAPPING INFORMATION (CONT) ;3/3/93 12:23 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N S DIAXNO=$P(Y(0),U,2),DIAXLE=+$P(DIAXNO,"J",2) S:DIAXFR DIAXFR("DLR")=$P(Y(0),U,5)["$" S @(DIAXA_"(""LE"")")=DIAXLE,@(DIAXA_"(""DC"")")=+$P(DIAXNO,",",2) Q:DIAXFR I DIAXFR("TY")["C" D CN^DIAXM2 Q I DIAXFR("TY")["P" G N1 I DIAXFR("DLR"),DIAXTO("DC")<2 D E3 S DIAXEM=DIAXEM_"contain at least 2 decimal places." D E I DIAXFR("DC")>DIAXTO("DC") D E3 S DIAXEM=DIAXEM_"contain at least "_DIAXFR("DC")_" decimal places." D E I DIAXFR("LE")>DIAXTO("LE") D E3 S DIAXEM=DIAXEM_"be at least "_DIAXFR("LE")_" digits long." D E N1 I DIAXTO("LO")>DIAXFR("LO") S DIAXE2=DIAXFR("LO") D E1,E3,E4 I DIAXTO("HI")X"),DIAXHI=$P($P(DIAXDT,"K:",2),"DIAXFR("LO") S DIAXDTY=DIAXFR("LO") D DT,E3 S DIAXEM=DIAXEM_"have an earliest date of at least "_DIAXDTY D E I DIAXTO("HI"),DIAXTO("HI")0 S DIAXUP=1 W:X=""&'$D(DTOUT) !,$C(7),DIAXDICA_" will not be extracted" S:$D(DTOUT) DIRUT=1 G QQ S DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y,DIAXEF=Y(0,0) S (DIAXFILE,DIAXF)=+$P(Y(0),U,2),DIAXLOC(DIAXFILE)="",DIAXNP(DL-1)=$P(Y(0),U,4) QQ K DIAXDEF,DIAXDICA Q IX Q:$P($G(^DD($$FNO^DILIBF(DIAXF),0,"DI")),U)'["Y" S (DIAXIX,DIAXFI,DIAXFD)="" F S DIAXIX=$O(^DD(DIAXF,0,"IX",DIAXIX)) Q:DIAXIX="" F S DIAXFI=$O(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI)) Q:DIAXFI'>0 F S DIAXFD=$O(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI,DIAXFD)) Q:DIAXFD'>0 D . I '$D(^DD(DIAXFI,DIAXFD,1)) S DIAXEM="Erroneous 'IX' node for "_DIAXIX D ERR^DIAXERR(DIAXEM) Q . S DIAXIXN=0 F S DIAXIXN=$O(^DD(DIAXFI,DIAXFD,1,DIAXIXN)) Q:DIAXIXN'>0 S DIAXIX0=$P(^(DIAXIXN,0),U,2) Q:DIAXIX=DIAXIX0 . Q:DIAXIXN'>0 S DIAXIX0=$P(^DD(DIAXFI,DIAXFD,1,DIAXIXN,0),U,3) D . . Q:DIAXIX0="" . . I DIAXIX0["MNE"!(DIAXIX0["REG")!(DIAXIX0["KWI")!(DIAXIX0["SOU") Q . . S DIAXEM="The """_DIAXIX_""" cross-reference in "_$P(^DD(DIAXFI,DIAXFD,0),U,1)_" is not allowed for an archive file." D ERR^DIAXERR(DIAXEM) Q:DIPG Q ; Q K DIAXZ,DIAXFT,DIAXHI,DIAXLO,DIAXNO,DIAXLE,DIAXTABZ,DIC,DIAXDICA,DIAXS,DIAXDJ,DIAXC K DIAXDEF,DIAXA,DIAXX,DIAXFR,DIAXTO,DIAXS1,DIAXDT,DIAXZL,DIAXZLL,DIAXZY,DIAXZZ K DIAXIX,DIAXIX0,DIAXIXN,DIAXVFI,DIAXVFLD,DIAXVFR,DIAXDTY K DIAX41,DIAX42,DIAXFTY,DIAXEXT,DIAXE1,DIAXE2,DIAXPC I '$G(DIPG),'$G(DIAR)!($G(DIAR)=6) K DIAXMSG Q Q1 K DIAXDK,DIAXDL,DIAXEF,DIAXF,DIAXFD,DIAXIX,DIAXIX0,DIAXIXN,DIAXTAB K DIAX1,DIAX2,DIAXFI,DIAXEM,DIAXLNK Q F1 S (A1,B1,D1)=0 S:'$D(DIAR) DIAR="" F S A1=$O(DIAXE01(A1)) Q:A1'>0 S B1=$G(DIAXE01(A1)),C="DIAXFR" S:+$P(B1,U,2) DIAXSB=1 D EN(B1,C) S C="DIAXTO",DIAXFR=0 D EN(A1,C) K DIAXSB K DIAXE01,A1,B1,D1 Q EN(W,Z) S @Z=1 S DIC="^DD("_+W_",",X=.01,DIC(0)="Z",DIAXEF=$O(^DD(+W,0,"NM","")) D ^DIC I Y'>0 Q D EN1^DIAXM Q TYP(%) N W,W1,W2,X,Y S W="NPSVWCDFK",W1=% F X=1:1:$L(W) S W2=$F(W1,$E(W,X)) Q:W2 S Y=$E(W1,W2-1) S:Y="" Y="F" Q Y DIAXP DIAXP ;SFISC/DCM-EXCEPTION REPORT ;5/16/96 10:56 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ; N PAGE,LINE,DIAXX,FILE,FNAME,Y,DATE,DIRUT,Z S PAGE=0,LINE="",DIAXX=^DIAR(1.11,DIARC,0),FILE=$P(DIAXX,U,2),FNAME=$P($G(^DIC(FILE,0)),U) S Y=DT X ^DD("DD") S DATE=Y D HDR,BODY,END Q ; C I IOST["C-" N DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT) ; HDR W:$Y @IOF W !,"EXTRACT ACTIVITY EXCEPTION REPORT",?IOM-24,DATE,?IOM-10,"PAGE: ",PAGE+1 S PAGE=PAGE+1,$P(LINE,"-",IOM)="" W !,LINE Q ; BODY W !!,"EXTRACT ACTIVITY: ",DIARC,?31,"ARCHIVER: ",$P($G(^VA(200,$P(DIAXX,U,6),0)),U) W !!,"THE FOLLOWING RECORDS IN THE '"_FNAME_"' FILE WERE NOT PROCESSED BY THE",!,"EXTRACT TOOL" N REC,LINE,ERR S REC=0 D REC Q:$D(DIRUT) W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***" Q REC S LINE="Entry # " S REC=$O(^TMP("DIAXU",$J,"RESULT","ERR",FILE,REC)) Q:'REC S ERR=^(REC) S LINE=LINE_+REC_" was NOT processed because:" D C:($Y+3>IOSL) Q:$D(DIRUT) W !!,LINE N A,B S A=1 D ERR G REC ERR S B=$P(ERR,";",A) Q:B="" S A=A+1 N Z S Z=0 F S Z=$O(^TMP("DIERR",$J,+B,"TEXT",Z)) Q:'Z D C:($Y+1>IOSL) Q:$D(DIRUT) W !?2,$G(^(Z)) G ERR ; END I $E(IOST)'="C",$Y W @IOF D ^%ZISC K ^TMP("DIAXU",$J),^TMP("DIERR",$J) Q DIAXT DIAXT ;SFISC/DCM-GET EXTRACT TEMPLATE SPECS ;5/13/96 14:01 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN N DIAXI,DILL,DIAX S DIAXTTO="^TMP($J,""DIAXTTO"")",DIAXTFR="^TMP($J,""DIAXTFR"")" K @DIAXTTO,@DIAXTFR D SPEC Q SPEC ;get specs D TOP,DR D NEXTLVL Q TOP ;get base file specs from extract template N X S DIAXI=0 S DIAXI=$O(^DIPT(DIAXT,1,DIAXI)) Q:DIAXI'>0 S X=^(DIAXI,0) S DILL=$P(X,U,2) FILE S @DIAXTFR@(DIAXI,"FR")=+X S @DIAXTFR@(+X,"TO")=$P(X,U,9) S @DIAXTFR@(+X,"PRT")=$P(X,U,3) S @DIAXTFR@(+X,"P4")=$P(X,U,4) S @DIAXTFR@(+X,"P2")=$P(X,U,2) S @DIAXTFR@(+X,"P5")=$P(X,U,5) S @DIAXTFR@(+X,"P7")=$P(X,U,7) I DILL>1,$P(X,U,9)'=$P(X,U,10) S @DIAXTTO@(+$P(X,U,9),"PRT")=+$P(X,U,10) Q DR ;get fields N DR,DRN,DRX,DRZ,FILE S DR="",DRN=1,DRZ=0,FILE=@DIAXTFR@(DILL,"FR") F S DRZ=$O(^DIPT(DIAXT,1,DIAXI,"F",DRZ)) Q:'DRZ I $D(^(DRZ,0)) S DRX=^(0) D . S DR=DR_+DRX_";",FILE=@DIAXTFR@(DIAXI,"FR") . S @DIAXTTO@(FILE,+DRX,+$P(DRX,U,5))=@DIAXTFR@(FILE,"TO")_U_$P(DRX,U,3)_U_$P(DRX,U,5) . I $L(DR)>245 S @DIAXTFR@(FILE,"DR",DRN)=DR,DRN=DRN+1,DR="" S:DR]"" @DIAXTFR@(FILE,"DR",DRN)=DR Q NEXTLVL ; S DIAX(DILL,"DIAXI")=DIAXI,DILL=DILL+1 F DIAXI=DIAXI:0 S DIAXI=$O(^DIPT(DIAXT,1,DIAXI)) Q:DIAXI'=+DIAXI S X=^(DIAXI,0) D NEXTLVL2 Q:DIAXI="" S DILL=DILL-1,DIAXI=DIAX(DILL,"DIAXI") Q NEXTLVL2 ; I $P(X,U,2)0 D . N DIAXDA,DIAXFE,DIERR . S DIAXFE=Z . D ONE . Q:$G(DIERR) . I $G(DIAX) D Q . . N FDA,IEN . . S FDA(1.14,"+"_+DIAXFE_","_DIARC_",",.01)=DIAXDA,IEN(DIAXFE)=DIAXDA . . D UPDATE^DIE("","FDA","IEN") . . S @(DIAXFRT_"DIAXFE,-9)")=DIARC . I $G(DIAXFLGS)["D" K ^DIBT(DIAXST,1,DIAXFE) Q STE(FI,IEN) N Z S:$G(FI)="" FI=DIAXF S:$G(IEN)="" IEN=DIAXFE S DIERRZ=(DIERR+DIERRZ)_U_($P(DIERR,U,2)+($P(DIERRZ,U,2))) F DIERRLST=DIERRLST:1:$O(^TMP("DIERR",$J,"E"),-1) S Z=DIERRLST_";" S @DIAXRSLT@("RESULT","ERR",FI,IEN)=Z Q ERR(DIAXER,DIAXTXT) ; D BLD^DIALOG(DIAXER,DIAXTXT,"",DIAXERR,"F") Q EXTRACT(DIAXF,DIAXSRCE,DIAXT,DIAXFLGS,DIAXSCR,DIAXFILE,DIAXRSLT,DIAXERRA) ; N DIAXST,DIAXFE,T,DIFM,DIOVRD,DIERRLST,DIAXTFR,DIAXTTO,DIAXDF,DIAXDFRT,DIAXERR,DIERRZ,DIAXDA S DIAXRSLT=$S($G(DIAXRSLT)]"":DIAXRSLT,1:"^TMP(""DIAXU"",$J)"),(DIFM,DIOVRD)=1,(DIERRLST,DIERRZ)=0,DIAXERR="" K ^TMP("DIAXU",$J),^TMP("DIAX",$J),^TMP($J) D CLEAN^DIEFU I '$G(DIAR) D Q:$G(DIERR) . N %,PARAM F %=1:1:3 S PARAM=$S(%=1:$G(DIAXF)_U_"FILE",%=2:$G(DIAXSRCE)_U_"SOURCE",1:$G(DIAXT)_U_"EXTRACT TEMPLATE") I $P(PARAM,U)']"" D ERR(202,$P(PARAM,U,2)) . Q:$G(DIERR) . I '$$VFILE^DIEFU(DIAXF) D ERR(202,"FILE") Q . I $G(DIAXSRCE) S DIAXFE=+DIAXSRCE,T="ONE" . I $E(DIAXSRCE)="[" S DIAXST=$P($P(DIAXSRCE,"[",2),"]"),T="DIBT" . D DIPT . Q E S T="DIBT",DIAXST=DIAXSRCE D ^DIAXT I $G(DIERR) S:$G(DIAR) DIAR="" Q D @T,K I $G(DIERRZ) S DIERR=DIERRZ I $G(DIERR),$G(DIAXERRA)]"" M @DIAXERRA@("DIERR")=^TMP("DIERR",$J) K ^TMP("DIERR",$J) Q DIAXU1 DIAXU1 ;SFISC/DCM-UPDATE DESTINATION FILE (CONT) ;3/5/93 2:34 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. START K DIC,DO,DA,DR,DD,X D SETVAR,PROCESS,EOJ Q ; SETVAR S DIAXFILE=DIAXET(DILL,"FILE") S DIAXMODE=$P(^TMP("DIAX",$J,DIAXFILE,"MODE"),U) I $D(^TMP("DIAX",$J,DIAXFILE,"X")) S X=^("X") I $D(^TMP("DIAX",$J,DIAXFILE,"DA(1)")) F DIAXII=1:1 Q:'$D(^("DA("_DIAXII_")")) S @("DA("_DIAXII_")="_^("DA("_DIAXII_")")) I $D(^TMP("DIAX",$J,DIAXFILE,"DIC(""P"")")) S DIC("P")=^("DIC(""P"")") Q ; PROCESS I DIAXMODE="A" S DIC=^TMP("DIAX",$J,DIAXFILE,"GL") D CALLDIC^DIAXU2 Q:$D(DIAXMSG) S DIAXAVAL=+Y D ADDCONT Q D BUILDDR S DIE=^TMP("DIAX",$J,DIAXFILE,"GL"),@("DA="_^("DA")) I $G(DR)]"" D CALLDIE^DIAXU2 Q:$D(DIAXMSG) I $D(^TMP("DIAX",$J,DIAXFILE,"WP")) D WP^DIAXU2 Q ; ADDCONT S DA=DIAXAVAL,DIE=DIC I $D(^TMP("DIAX",$J,DIAXFILE,"WP")) D WP^DIAXU2 D BUILDDR I $G(DR)]"" D CALLDIE^DIAXU2 Q:$D(DIAXMSG) D DA Q ; BUILDDR I $D(^TMP("DIAX",$J,DIAXFILE,"DR")) S DR=^("DR") I $D(^TMP("DIAX",$J,DIAXFILE,"DR"))=11 S DIAXZRO=0 F DIAXL=0:0 S DIAXZRO=$O(^TMP("DIAX",$J,DIAXFILE,"DR",DIAXZRO)) Q:'DIAXZRO S DR(1,DIAXFILE,DIAXZRO)=^(DIAXZRO) Q ; DA S (DIAXET(DIAXFILE,"DA"),^TMP("DIAX",$J,DIAXFILE,"DA"))=DIAXAVAL S DIAXX=$G(DIAXET(DIAXFILE)) I DIAXX=""!(DIAXFILE=DIAXX) Q I $D(DIAXET(DIAXX,"DA")) S DIAXET(DIAXFILE,"DA(1)")=DIAXET(DIAXX,"DA") I $D(DIAXET(DIAXX,"DA(1)")) F DIAXII=1:1 Q:'$D(DIAXET(DIAXX,"DA("_DIAXII_")")) S DIAXET(DIAXFILE,"DA("_(DIAXII+1)_")")=DIAXET(DIAXX,"DA("_DIAXII_")") Q ; EOJ K DIC,DIE,DIK,DA,DR,DIAXAVAL,X,Y K:$D(DIAXMSG) ^TMP("DIAX",$J) K ^TMP("DIAX",$J,DIAXFILE,"DR"),^("WP") K DIAXII,DIAXFILE,DIAXMODE,DIAXDRVL,DIAXZRO,DIAXX,DIAXL,DIAX("FIELD") Q DIAXU2 DIAXU2 ;SFISC/DCM-UPDATE DESTINATION FILE (CONT) ;10/13/94 10:01 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CALLDIC S DIADD=1,DIC(0)="FLI",DLAYGO=DIAXFILE D ^DIC I Y<1 D ERR^DIAXERR(99,DIAXFN_U_DIAXFE_U_DIAX(1,.01)) D FIX K DLAYGO,DR,DINUM,DIADD,X Q ; CALLDIE ;I DR[".01///"&($P(^DD(DIAXFILE,.01,0),U,5,99)["DINUM"!$D(^TMP("DIAX",$J,DIAXFILE,"DINUM"))) S DIAXDRVL=$P($P(DR,".01///",2),";"),DR=$P(DR,".01///"_DIAXDRVL)_$P(DR,".01///"_DIAXDRVL_";",2) D ^DIE I $D(Y) D ERR^DIAXERR(98,DIAXFN_U_DIAXFE_U_DIAX(1,.01)) D FIX Q ; WP S DIAX("FIELD")=0 ; WP1 S DIAX("FIELD")=$O(^TMP("DIAX",$J,DIAXFILE,"WP",DIAX("FIELD"))) Q:DIAX("FIELD")'>0 S DKP=0 F A9="DTL","DTO(1)","DFL","DFR(1)" S @A9=^TMP("DIAX",$J,DIAXFILE,DIAX("FIELD"),A9) S DTO(1)=DTO(1)_DIAXAVAL_","""_$P($P(^DD(DIAXET(DILL,"FILE"),DIAX("FIELD"),0),U,4),";")_"""," D WORD^DITR1 K DFR,DKP,DTO,V,A9,DFL,DTL G WP1 ; FIX I $G(^TMP("DIAX",$J,DIAXFNO,"DA")) S DA=^("DA"),DIK=^("GL") D ^DIK Q:DIPG S $P(^(0),U,7)=$P(^DIAR(1.11,DIARC,0),U,7)-1 S:$G(DIOEND)'["DIAXU3" DIOEND=DIOEND_" D ^DIAXU3" K ^DIBT(DIARU,1,DIAXFE),@(DIAXF_DIAXFE_",-9)") Q DIAXU3 DIAXU3 ;SFISC/DCM-EXCEPTION REPORT ;6/9/93 3:55 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ; S DIPAGE=0,DIAXLINE="",DIAXX=^DIAR(1.11,DIARC,0),DIAXZ1=$P(DIAXX,U,2),DIAXZ2=$P($G(^DIC(DIAXZ1,0)),U),DIAXZ=0 S Y=DT X ^DD("DD") S DIAXY=Y D HDR,BODY,END Q ; HDR W:$Y @IOF W !,"ARCHIVAL ACTIVITY EXCEPTION REPORT",?IOM-24,DIAXY,?IOM-10,"PAGE: ",DIPAGE+1 S DIPAGE=DIPAGE+1,$P(DIAXLINE,"-",IOM)="" W !,DIAXLINE Q ; BODY W !!,"ARCHIVAL ACTIVITY: ",DIARC,?31,"ARCHIVER: ",$P($G(^VA(200,$P(DIAXX,U,6),0)),U) W !!,"THE FOLLOWING RECORDS IN THE '"_DIAXZ2_"' FILE WERE NOT MOVED BY THE EXTRACT TOOL" W !!?3,"INTERNAL",?16,$P(^DD(DIAXZ1,.01,0),U),!,"ENTRY NUMBER",! F S DIAXZ=$O(^TMP("DIERR",$J,DIAXZ)) Q:DIAXZ'>0 W !,?5,$G(^(DIAXZ,"PARAM",2,0)),?16,$E($G(^TMP("DIERR",$J,DIAXZ,"PARAM",3,0)),1,50) W !!,"*** PLEASE KEEP THIS FOR FUTURE REFERENCE ***" Q ; END I $E(IOST)'="C",$Y W @IOF D ^%ZISC K ^TMP("DIERR",$J),DIAXY,DIAXLINE,DIPAGE,DIAXX,DIAXZ,DIAXZZ,DIR,DIRUT,DTOUT,DUOUT,DIAXZ1,DIAXZ2 Q ; HDRC Q:($Y+10 I $D(DR) G ^DIA2 Q K DI,DLAYGO,DIA,I,J QQ K ^UTILITY($J),DIAT,DIAB,DIZ,DIAO,DIAP,DIAA,IOP,DSC,DHIT,DRS,DIE,DR,DA,DG,DIC,F,DP,DQ,DV,DB,DW,D,X,Y,L,DIZZ Q ; DIE ; S F=+Y,(DG,X)="^DIZ("_F_"," I DUZ(0)="@" W !!,"INTERNAL GLOBAL REFERENCE: "_DG R "// ",X:DTIME S:'$T X="^" S:X="" X=DG I X?."?" W !,"TYPE A GLOBAL NAME, LIKE '^GLOBAL(' OR '^GLOBAL(4,'",!,"OR JUST HIT 'RETURN' TO STORE DATA IN '"_DG_"'" G DIE ; I X?1"^".E S X=$P(X,U,2,9) I X?.P G ABORT I X?1.AN W $C(7)_" ??" G DIE ; S DG=X D VALROOT(.X,.%) I %'=1 G DIE:DUZ(0)="@"&(DG'=X),ABORT ; W ! W:DG'=X !?2,"Global reference selected: ^"_X,! S DG=U_X ; SET D WAIT^DICD S $P(^DIC(F,0),U,2)=F,^("%A")=DUZ_U_DT,X=$P(^(0),U,1),^(0,"GL")=DG I DUZ(0)]"" F %="DD","DEL","RD","WR","LAYGO","AUDIT" S ^DIC(F,0,%)=DUZ(0) I DUZ(0)'="@",$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) D SET1 S %="" I @("$D("_DG_"0))") S %=^(0) S @(DG_"0)=X_U_F_U_$P(%,U,3,9)") K ^DD(F) S ^(F,0)="FIELD^^.01^1",^DD(F,.01,0)="NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X" S ^(3)="NAME MUST BE 3-30 CHARACTERS, NOT NUMERIC OR STARTING WITH PUNCTUATION" W !?5,"A FreeText NAME Field (#.01) has been created." S DA="B",^DD(F,.01,1,0)="^.1",^(1,0)=F_U_DA,X=DG_""""_DA_""",$E(X,1,30),DA)",^(1)="S "_X_"=""""",^(2)="K "_X S DIK="^DIC(",DA=F D IX1^DIK S DLAYGO=F,DIK="^DD(DLAYGO,",DA=.01,DA(1)=DLAYGO G IX1^DIK ; ABORT ;Delete file and abort W !!?9,$C(7)_"No new file created!" S DIK="^DIC(",DA=F K DG G ^DIK ; VALROOT(X,%) ;Validate the root in X ;Returns: ; X = open root ; % = 0 : invalid root ; 1 : valid root ; N CREF,FNUM,N,OREF,PROMPT,QLEN,ROOT ; S (OREF,X)=$$OREF^DILF(X) S:$E(OREF)=U OREF=$E(OREF,2,999) ; ;Check syntax I OREF?1(1A,1"%").AN1"(" E I OREF?1(1A,1"%").AN1"("1.E1"," E I OREF?1"["1.E1"]"1(1A,1"%").AN1"(" E I OREF?1"["1.E1"]"1(1A,1"%").AN1"("1.E1"," E I OREF?1"|"1.E1"|"1(1A,1"%").AN1"(" E I OREF?1"|"1.E1"|"1(1A,1"%").AN1"("1.E1"," E W $C(7)_" ?? Bad syntax" S %=0 Q ; S CREF=U_$$CREF^DILF(OREF) ; ;Check whether files stored in ancestors S %=1 S QLEN=$QL($NA(@CREF)) F N=QLEN:-1:0 D Q:'% . S ROOT=$NA(@CREF,N) . Q:ROOT="^DIC"&(N'=QLEN) . S FNUM=+$P($P($G(@ROOT@(0)),U,2),"E") . I FNUM D Q:'% .. S OROOT=$$OREF^DILF(ROOT) .. I $G(^DIC(FNUM,0,"GL"))=OROOT D ... W !!,$C(7)_" ERROR -- "_OROOT_" already used by File #"_FNUM_"!" ... S %=0 . I N=QLEN,$O(@CREF@(0))]"" D .. W !,$C(7) .. S PROMPT=" -- ^"_OREF_" already exists!" .. I DUZ(0)'="@" S %=0 W !," ERROR"_PROMPT .. E D YN(" WARNING"_PROMPT_" --OK",.%) Q ; YN(PROMPT,%) ;Prompt yes/no N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y S DIR(0)="Y" S:$G(PROMPT)]"" DIR("A")=PROMPT S DIR("B")="No" D ^DIR S %=Y=1 Q ; EN ; Enter here when the user is allowed to select his fields S DIC=DIE S:DIC DIC=$S($D(^DIC(DIC,0,"GL")):^("GL"),1:"") D 1:DIC]"" K DIC Q ; SET1 ; I $D(^VA(200,"AFOF")) S:'$D(^VA(200,DUZ,"FOF",0)) ^(0)="^200.032PA^"_+F_"^1" S ^(+F,0)=F_"^1^1^1^1^1^1" I $D(^DIC(3,"AFOF")) S:'$D(^DIC(3,DUZ,"FOF",0)) ^(0)="^3.032PA^"_+F_"^1" S ^(+F,0)=F_"^1^1^1^1^1^1" S DIK=$S($D(^VA(200)):"^VA(200,DUZ,""FOF"",",1:"^DIC(3,DUZ,""FOF"","),DA=F,DA(1)=DUZ D IX1^DIK Q DIBT DIBT ;SFISC/GFT,TKW,TOAD-STORE A SORT TEMPLATE ;29JUNE2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. MENU ; 0 ; select and edit templates, until user quits S DIC="^DOPT(""DIBT"",",DICF=DI I '$D(^DOPT("DIBT",.402)) S ^(0)="TEMPLATE FILE^1.01" K ^("B") D .F X=.4,.401,.402 S ^DOPT("DIBT",X,0)=$P(^DIC(X,0),U) .N DIK S DIK=DIC D IXALL^DIK S DIC(0)="QEAIN",DIC("A")="Select TEMPLATE File: " S DIC("S")="I Y=.4!(Y=.401)!(Y=.402)" D ^DIC K DIC Q:Y<0 K DTOUT F Q:'$$T(+Y,DICF) I $D(DTOUT) K DTOUT Q Q ; T(DDSFILE,DICF) ;=.4,.401,.402 N Y,DIC,DIERR,DDSPARM,DR,DA,DIN W !! S DIC=DDSFILE,DIC("S")="I $P(^(0),U,4)="_DICF_",Y'<1",D="F"_DICF S DIC(0)="AEQI" D IX^DIC I Y<0 Q 0 S DA=+Y,DIN=$$SCREEN G SCROLL:DIN=0 I 'DIN Q 0 S DIN=$S(DDSFILE=.4:"DIPTED",DDSFILE=.402:"DIETED",1:"DIBTED") S DR="["_DIN_"]",DDSPARM="" D ^DDS Q '$D(DIERR) ; SCROLL N DIE,DIOVRD,DR S DIE=DDSFILE,DR=".01:3;5:7;10;707;491620",DIOVRD=1 D ^DIE Q 1 ; SCREEN(HELP) ; N DIR,DIRUT,DUOUT,X,Y,DIERR K DUZ("SCREEN") ;COMMENT OUT THIS LINE IF YOU WANT FILEMAN TO REMEMBER! I $G(DUZ("SCREEN"))=0 Q 0 D SET^DDGLIB0 I $D(DIERR) Q 0 I '$G(DUZ("SCREEN")) D I '$D(DUZ("SCREEN")) Q U ;ABORT .S DIR(0)="Y",DIR("A")="Do you want to use the screen-mode version",DIR("B")="YES" .I $D(HELP) S DIR("?")=HELP .D ^DIR I Y-1 S:Y=0 DUZ("SCREEN")=0 Q .S DUZ("SCREEN")=1 D KILL^DDGLIB0() ;I ^DD("OS")=9 U $I:VT=1 ;FOR DATATREE Q +$G(DUZ("SCREEN")) ; S ; D S1^DIBT1 K DIRUT,DIROUT G Q^DIP:$D(DUOUT)!($D(DTOUT)) G N:X="",S:Y<0 S DIBT1=+Y SNEW K ^DIBT(DIBT1,2),^("BY0"),^("BY0D") S $P(^DIBT(DIBT1,0),U,7)=DT I $G(BY(0))]"",$D(DPP(0)) D . N DIBY,DIREC,%,I,D,F,T,Q1,Q2,O S %=DIBT1_"," S DIBY(.401,%,1622)=$P(BY(0),U,2),DIBY(.401,%,1623)=DPP(0)+1 D FILE^DIE("E","DIBY") . F I=1:1:DPP(0) D .. S F=$P($G(DPP(I,"F")),U,2),T=$P($G(DPP(I,"T")),U,2),O=$P($G(DPP(I)),U,4),Q1="" S:O["!" Q1=Q1_"!" S:O["#" Q1=Q1_"#" S Q2=$P($G(DPP(I)),U,5),O=$G(DPP(I,"OUT")) .. S %="+"_I_","_DIBT1_"," K DIBY(.4011624,%) .. S:F]"" DIBY(.4011624,%,1)=F S:T]"" DIBY(.4011624,%,2)=T S:Q1]"" DIBY(.4011624,%,3.1)=Q1 S:Q2]"" DIBY(.4011624,%,3.2)=Q2 S:O]"" DIBY(.4011624,%,4)=O .. Q:'$D(DIBY(.4011624,%)) S DIBY(.4011624,%,.01)=I,DIREC(I)=I Q . D UPDATE^DIE("E","DIBY","DIREC") . Q S (DIBT2,DIBT3)=+$G(DPP(0)) F S DIBT3=$O(DPP(DIBT3)) Q:'DIBT3 S DIBT2=DIBT2+1 D .N DIC,DA,DIE,DINUM,DIOVRD,DR,DO S X=$P(DPP(DIBT3),U) Q:+$P(X,"E")'=X S DIC="^DIBT("_DIBT1_",2,",DIC(0)="L",DA(1)=DIBT1,DINUM=DIBT2,DIOVRD=1,DIC("P")=$P(^DD(.401,1621,0),U,2) D FILE^DICN K DIC,DA,DINUM,DIOVRD .N A,B,C,D S $P(^DIBT(DIBT1,2,DIBT2,0),U,2,10)=$P(DPP(DIBT3),U,2,10) EGP .I $D(DPP(DIBT3,"LANG"))=11 S $P(^(0),U,3)=DPP(DIBT3,"LANG") ;**CCO/NI PUT THE CORRECT NAME INTO STORED TEMPLATE .S A="A" F S A=$O(DPP(DIBT3,A)) Q:A="" S %=$G(DPP(DIBT3,A)) I %]"",(A'="TXT")!($G(DUZ("LANG"))'>1) S ^DIBT(DIBT1,2,DIBT2,A)=% ;**CCO/NI DON'T SAVE FURRIN-LANGUAGE 'TEXT' .S (C,D)=0 F A=-1:0 S A=$O(DPP(DIBT3,A)) Q:+$P(A,"E")'=A D ..I $G(DPP(DIBT3,A))]"" S C=C+1,%=1,%(1)=17,X=A,DINUM=C,DIC("DR")="1////"_DPP(DIBT3,A) D DICM ..S B="" F S B=$O(DPP(DIBT3,A,B)) Q:B="" S D=D+1,%=2,%(1)=18,X=A,DINUM=D D DICM S:Y>0 ^DIBT(DIBT1,2,DIBT2,2,+Y,"RCOD")=$P(DPP(DIBT3,A,B),U,4,99) ..Q .S D=0,A="OV" F S A=$O(DPP(DIBT3,A)) Q:$E(A,1,2)'="OV" S B="" F S B=$O(DPP(DIBT3,A,B)) Q:B="" S C=$G(DPP(DIBT3,A,B)) I C]"" S D=D+1,%=3,%(1)=19,X=A,DINUM=D D DICM I Y>0 S $P(^DIBT(DIBT1,2,DIBT2,3,+Y,0),U,2)=B,^("OVF0")=C .Q I $D(DIBTOLD) K DIBTOLD D K Q S DIBT2=+$G(DPP(0)) S0 S DIBT2=DIBT2+1 G N:DIBT2>DPP,S0:'$D(DPP(DIBT2,"F")),S0:$P(DPP(DIBT2),U,4)["B" S DIR("?",1)="Answer YES if you want the to allow the user to specify beginning and",DIR("?")="ending sort values when the print job is run." W ! S DIR("A")="SHOULD TEMPLATE USER BE ASKED 'FROM'-'TO' RANGE FOR '"_$P(DPP(DIBT2),U,3)_"'",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT) D K G Q^DIP G:Y=0 S0 S1 S ^DIBT(DIBT1,2,DIBT2,"ASK")=1 G S0 ; DICM S DIC="^DIBT("_DIBT1_",2,"_DIBT2_","_%_",",DA(2)=DIBT1,DA(1)=DIBT2,DIC(0)="L",DIOVRD=1,DIC("P")=$P(^DD(.4014,%(1),0),U,2) N C,D I %(1)=18 S DIC("DR")="1////"_B F C=1,2,3 S D=$P(DPP(DIBT3,A,B),U,C) I D]"" S DIC("DR")=DIC("DR")_";"_(C+1)_"////"_D N A,B,DD,DO D FILE^DICN K DIC,DA,DINUM,DIOVRD Q ; US S $P(^DIBT(DIBT1,0),U,7)=DT I '$O(^DIBT(+$G(DIBT1),2,0)) Q N % F X=+$G(DPP(0)):0 S X=$O(DPP(X)) Q:'X D . F %="F","T","SER","TXT","IX","PTRIX","QCON","SRTTXT" K ^DIBT(DIBT1,2,X,%) I $G(DPP(X,%))]"" S:%'="SER" ^DIBT(DIBT1,2,X,%)=DPP(X,%) . Q Q ; K K DIEDT,DIBT2,DIBT3 Q N D K G N^DIP1 DIBT1 DIBT1 ;SFISC/GFT,TKW-STORE A SORT TEMPLATE ;8/2/94 15:57 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S1 K DIR S DIR(0)="O",DIR("A")="STORE IN 'SORT' TEMPLATE",DIR("?")="^D H1^DIBT1" D SAV Q:$D(DIRUT) D DIC Q ; S2 K DIR S DIR(0)="O",DIR("A")="STORE THESE ENTRY ID'S IN TEMPLATE",DIR("?")="^D H2^DIBT1" D SAV Q:$D(DIRUT) D MRG Q ; S3 K DIR S DIR(0)="O",DIR("A")="STORE RESULTS OF SEARCH IN TEMPLATE",DIR("?")="^D H3^DIBT1" S:$D(DIAR) DIR(0)="" D SAV Q:$D(DIRUT) D MRG Q ; SAV S DIR(0)="F"_DIR(0)_"^1,30" D ^DIR K DIR Q:$D(DIRUT) I $E(X)="[" S X=$P($E(X,2,99),"]",1) Q H1 N A,B S A="sort criteria",B="SORT" D H,DIC Q H2 N A,B S A="list of entries",B="SEARCH/SORT" D H,MRG Q H3 N A,B S A="list of entries from the search",B="SEARCH/SORT" W:$D(DIAR) !!,"You must store the results in a template.",!,"Otherwise you will have to rerun this search to archive the entries." D H,MRG Q H W !!,"If you wish to save this "_A_" for later re-use",!,"enter the name of a "_B_" TEMPLATE here (1-30 characters)." Q MRG ; S DIBT1=1 DIC K DIC S DIC="^DIBT(",DLAYGO=0,DIC(0)="QELSZ",DIOVRD=1,DIC("S")="I "_$S($D(DIAR)&('$D(DIARI)):"",1:"'")_"$P(^(0),U,8)" S DIC("S")=DIC("S")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5)!$D(DIEDT)",D="F"_DK D IX^DIC S DIBTY=Y K DIC,DLAYGO,DIEDT,DIOVRD G QDIC:Y'>0 N X,DIBTSEC S DIBTSEC="" I $O(^DIBT(+Y,0))]"" S DIBTSEC=Y(0) D ALR I $D(DIRUT)!(Y'>0) G QDIC D NOW^%DTC S ^DIBT("F"_DK,$P(Y,U,2),+Y)=1,^DIBT(+Y,0)=$P(Y,U,2)_U_+$J(%,0,4)_U_$S(DIBTSEC]"":$P(DIBTSEC,U,3),1:DUZ(0))_U_DK_U_DUZ_U_$S(DIBTSEC]"":$P(DIBTSEC,U,6),1:DUZ(0)) I $D(DIAR),'$D(DIARI) S $P(^(0),U,8)=1 K DIBTSEC N DIE,DA,DI,DK,DR,Y S DIE="^DIBT(",DA=+DIBTY,DR=10,DIOVRD=1 D ^DIE K DUOUT,DIROUT,DIRUT QDIC K DIBT1,DIBTY,DIOVRD,%,%X,%Y Q ALR W !,$C(7) I $D(DIBT),+Y=DIBT W "NO!! YOU ARE USING THAT TEMPLATE FOR YOUR LIST OF ENTRIES!" S Y=-1 Q I $D(DISV),+Y=DISV W "NO!! YOU ARE GOING TO STORE SEARCH RESULTS IN THAT TEMPLATE!" S Y=-1 Q N DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="DATA ALREADY STORED THERE....OK TO PURGE" D ^DIR Q:$D(DIRUT) I Y=1 S %Y="" D S Y=DIBTY Q .F S %Y=$O(^DIBT(+DIBTY,%Y)) Q:%Y="" I %Y'="%D",%Y'="ROU",%Y'="ROUOLD",%Y'="DIPT" K ^DIBT(+DIBTY,%Y) .Q S %Y=-1 I $O(^DIBT(+DIBTY,1,0))'>0!'$D(DIBT1) S Y=-1 Q F %=0:0 S %=$O(^(%)),%Y=%Y+1 Q:%'>0 K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="WANT TO MERGE THESE ENTRIES",DIR("A")="WITH THE "_%Y_" ALREADY IN '"_$P(DIBTY,U,2)_"' TEMPLATE" D ^DIR S Y=$S(Y=0:-1,1:DIBTY) W ! Q DIBTED DIBTED ;SFISC/GFT-SCREEN-EDIT A SORT TEMPLATE ; 15NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N DIC,DIBT0,DIBTED,DRK,I,J,DDSCHG S DIC=.401,DIC(0)="AEQ" D ^DIC Q:Y<1 S DIBT0=+Y D E D PUT K K ^UTILITY("DIBTED",$J) Q ; EDIT(DIBT0) ; EDIT VIA VA FILEMAN SCREEN EDITOR N DRK,DIBTED,I,J E N DA,DPQ,DM,DP,DPP,D0,DIBTEDER,DIBTH,L,N,BY,DE,Y,DIBTX,Q,DIBTROW,DCL,DXS,DHD,DIJJ,DDH,DI,DV,DJ,DL,DK,DIL,DU,P,DNP,DIPP,G,S,C,Q,B,DIPA,DCC D:'$D(DISYS) OS^DII X ^DD("OS",DISYS,"EON") I '$D(^DIBT(DIBT0,0)) W !,"NO TEMPLATE SELECTED",! G K I $D(^("BY0")) W !,"CANNOT EDIT A ""BY(0)"" TEMPLATE WITH SCREEN EDITOR",! H 3 G K S DIBTED="Sort Template """_$P(^(0),U)_"""",(S,DRK)=$P(^(0),U,4),DCC=^DIC(S,0,"GL") W "..." D GET("^TMP(""DIBTED"",$J)") I '$D(^TMP("DIBTED",$J)) D H 2 G K . I '$D(^DIBT(+D0,"DIS")) W !,"NO EDITABLE FIELDS EXIST IN THIS TEMPLATE.",! . W !,"A SEARCH TEMPLATE HAS NO EDITABLE SORT FIELDS.",! S DIBTH="Editing "_DIBTED,DIBTROW=1 DDW D EDIT^DDW("^TMP(""DIBTED"",$J)","M",DIBTH,"(File "_DRK_")",DIBTROW) K ^UTILITY($J,0),^UTILITY("DIBTED",$J),I,J,DPP I $D(DUOUT)!$D(DTOUT) K ^TMP("DIBTED",$J) W $C(7),$$EZBLD^DIALOG(8077) Q S C=",",Q="""" S (DV,DNP)="",DE="SORT",(DIL,L)=0,(DL,DJ)=1,(DI,S)=DRK D PROCESS("^TMP(""DIBTED"",$J)") X ^DD("OS",DISYS,"EON") S DIBTROW=$O(DIBTEDER(0)) I DIBTROW W " ",DIBTEDER(DIBTROW) H 2 S DIBTH="ERROR! Re-editing "_DIBTED K DIBTEDER G DDW K ^TMP("DIBTED",$J) S DDSCHG=1 Q ; GET(DIBTA) ;put displayable template into @DIBTA N DIBTITLE,DIPR,DIJ,%X,%Y,D,DPP,DIBTAD,DJ,DIPP,DIBTRPT,DIBTOLD,C,X K @DIBTA S (DJ,DIBTRPT)=1,C=",",(X,D0)=DIBT0,D="^DIBT("_X_C D ENDIPT^DIP11 S X="",DIBTAD=0 F DIJ=0:0 S DIJ=$O(DPP(DIJ)) Q:DIJ="" S DIPP(DIJ)=DPP(DIJ),%=+DPP(DIJ),DJ=DIJ D E1^DIP0 S %X=0 D E2^DIP0 K DPP,DIJJ F DIJ=0:0 S DIJ=$O(DIPP(DIJ)) Q:DIJ="" D .N Y,%Y,% .D NL .S Y=$P(DIPP(DIJ),U,5),%=$P($P(DIPP(DIJ),U,4),"""",1) I %="@B" S %="@" ;DON'T SHOW 'BOOLEAN' .D W($S($D(DIBTITLE):"WITHIN "_DIBTITLE_", ",DIJ>1:"WITHIN "_DPP(DIJ-1)_", ",1:"")_"SORT BY: "_%_$P(DIPP(DIJ),U,3)_Y) .K DIBTITLE I $L(Y,"""")=3 S DIBTITLE=$$STRIP($P(Y,"""",2)) I DIBTITLE?.E1":" S DIBTITLE=$E(DIBTITLE,1,$L(DIBTITLE)-1) .S DPP(DIJ)=$P(DIPP(DIJ),U,3) .I $D(^DD(+DIPP(DIJ),+$P(DIPP(DIJ),U,2),0)) S X=+$P(^(0),U,2) I X,$D(DIPP(DIJ,X)),$D(^DD(X,0)) D NL,W($P(^DD(X,0),U)_": "_DIPP(DIJ,X)) K DIPP(DIJ,X) .F %=0:0 S %=$O(DIPP(DIJ,%)) Q:'% I $D(DIPP(DIJ,%))#2 D NL,W($S('$D(^DD(%,0,"UP")):$O(^("NM",0))_" ",1:"")_$P(^DD(%,0),U)_": "_DIPP(DIJ,%)) S DPP(DIJ)=DIPP(DIJ,%) .Q:$P(DIPP(DIJ),U,4)["B" .D NL .S Y=$G(^DIBT(D0,2,DIJ,"F")),%Y=$P($G(^("T")),U) .S %Y=$S(%Y="z":"",$TR(%Y," ")="@":"@",1:%Y) FROMDATE .S:Y[".9999" Y=$P(Y,".")+1 X:$P(DIPP(DIJ),U,10)=1 ^DD("DD") .S %=$F(Y,"z"),X="From: "_$S(%:$E(Y,1,%-3)_$C($A(Y,%-2)+1),1:Y),Y=%Y D W(X) .D NL,W("To: ") I Y]"" S:Y[".9999" Y=Y\1 D:$P(DIPP(DIJ),U,10)=1 D W(Y) TODATE ..S:X'?.E1"@"1.NP Y=Y\1 X ^DD("DD") .I $D(^DIBT(D0,2,DIJ,"F")) S Y=$G(^("ASK")) D NL,W($P("Do NOT ask^ASK",U,''Y+1)_" range of values") Q ; NL S DIBTAD=DIBTAD+1,@DIBTA@(DIBTAD)=$J("",DIJ*3-3) Q ; W(X) S @DIBTA@(DIBTAD)=@DIBTA@(DIBTAD)_X Q ; PROCESS(DIBTA) ;puts nodes into ^UTILITY("DIBTED") N DIPP,DIBTMORE,DIBTAB,BY,FR,TO,DIPR,DC,DJ,DK,DIJ,R,ERR,DIBTLINE,DIBTASK,X,A,DIQUIET K DPP S DIPP(1)="" ;Trick: if 1st Sort Field is screwy, DPP(1) will come back null S DIQUIET=1,DK=DRK,DIBTLINE=1,DIJ=0,DIBTAB=1,DC=0,DI=^DIC(DK,0,"GL"),DNP="" F DJ=1:1 D Q:'DIBTMORE .F S BY=$$STRIP($P($$LINE,"SORT BY:",2)) Q:BY'?.P G Q:'DIBTMORE .S DIBTEDER=DIBTLINE,FR(DJ)="",TO(DJ)="" .F Q:DIBTMORE-DIBTAB S X=$$LINE Q:X'["FIELD: " S BY=BY_","_$$STRIP($P(X,"FIELD:",2)) .I DIBTMORE=DIBTAB S DIBTLINE=DIBTLINE-1,FR(DJ)=$$STRIP($P($$LINE,"From:",2)) .I DIBTMORE=DIBTAB S TO(DJ)=$$STRIP($P($$LINE,"To:",2)) .I TO(DJ)]"",FR(DJ)="" S DIBTMORE=0,DIBTEDER(DIBTEDER)="IF YOU HAVE A 'TO' VALUE, YOU MUST HAVE A 'FROM' VALUE" Q .K DIBTASK I DIBTMORE=DIBTAB S DIBTASK=$$UP^DILIBF($$LINE) .D DJ^DIP GOODQ .I $G(DJ),$G(DPP(DJ))]"" D Q ;Does this sort level pass muster? ..S DIBTAB=DIBTMORE ..I $G(DIBTASK)["ASK",DIBTASK'["DON'T",DIBTASK'["NOT" S DPP(DJ,"ASK")=1 .S DIBTMORE=0,DIBTEDER(DIBTEDER)="" Q .Q Q:'$D(DJ) K A D DPQ^DIP1 I $D(A(1)) S DIBTEDER(1)="YOU ARE SORTING BY THE SAME FIELD TWICE" Q M ^UTILITY("DIBTED",$J,"DPP")=DPP Q ; LINE() N P,X G S X=$G(@DIBTA@(DIBTLINE)),DIBTMORE=0 F S DIBTLINE=DIBTLINE+1 Q:'$D(@DIBTA@(DIBTLINE)) S P=@DIBTA@(DIBTLINE) I P'?.P D Q .F DIBTMORE=1:1 Q:$A(P,DIBTMORE)-32 Q $$STRIP(X) ; STRIP(X) N P F P=$L(X):-1:1 Q:$A(X,P)>32 S X=$E(X,1,P-1) B I $A(X)-32 Q X S X=$E(X,2,999) G B ; PUT ;save template from ^UTILITY I '$D(^UTILITY("DIBTED",$J)) Q N DIC S DIC("B")=DIBT0 SAVEAS S DIC=.401,DIC("A")="Save revised "_DIBTED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK" D ^DIC Q:Y<0 I $O(^DIBT(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS L +^DIBT(+Y) S $P(^DIBT(+Y,0),U,4)=J(0) L -^DIBT(+Y) D SAVEFLDS(+Y) Q ; SAVEFLDS(DIBT1) ; N DPP,DIBTOLD Q:'$D(^UTILITY("DIBTED",$J))!'$G(DIBT1) NOW D NOW^%DTC S $P(^DIBT(DIBT1,0),U,2)=+$J(%,0,4) S $P(^DIBT(DIBT1,0),U,5)=$G(DUZ) M DPP=^UTILITY("DIBTED",$J,"DPP") S DIBTOLD=1 D SNEW^DIBT Q ; ; ; BUILDNEW(GFTOUT,DRK,ARRAY,DINAME) ;TAKE SORT TEMPLATE SPEC FOR FILE 'DRK' AND RETURN NEW SORT TEMPLATE NUMBER AND NAME N DV,DNP,DE,DIL,L,DL,DI,DJ,S,DCC,C,Q,DIC,DIBTEDER,Y,X S GFTOUT=-1 Q:'$G(DRK)!'$O(@ARRAY@(0)) S DCC=$G(^DIC(DRK,0,"GL")) Q:DCC'[U K ^UTILITY($J,0),^UTILITY("DIBTED",$J),I,J,DPP S C=",",Q="""" S (DV,DNP)="",DE="SORT",(DIL,L)=0,(DL,DJ)=1,(DI,S)=DRK D PROCESS(ARRAY) I '$D(^UTILITY("DIBTED",$J)) Q S Y=$O(DIBTEDER(0)) I Y S GFTOUT="-1^LINE "_Y_" OF TEMPLATE COULD NOT BE PROCESSED" Q S:$G(DINAME)="" DINAME="ZZZZZ "_$J S X=DINAME S DIC="^DIBT(",DIC("S")="I '$G(^(""GFT"")),$D(^(2)),$P(^(0),U,4)="_DRK,DIC(0)="XY" D ^DIC I Y+1 S GFTOUT="-1^TEMPLATE NAMED '"_DINAME_"' ALREADY EXISTS" Q S DIC(0)="LX",DIC("S")="I $P(^(0),U,5)=$G(DUZ),$G(^(""GFT""))",DIC("DR")="4///"_DRK_";5///"_+$G(DUZ) D ^DIC K DIC S DINAME=Y I Y>0 S ^DIBT(+Y,"GFT")=$H D SAVEFLDS(+Y) S GFTOUT=DINAME Q ; TEST K GFT S GFT(1)="SORT BY: NAME" S GFT(2)="From: X" S GFT(3)="To: z" D BUILDNEW(.OUT,200,"GFT") W !,OUT Q DIC DIC ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 ;29AUG2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N %,D,DF,DIFILEI,DIENS,DINDEX,DS,DIASKOK,DIY,DO S U="^",DIC(0)=$G(DIC(0)) D GETFILE^DIC0(.DIC,.DIFILEI,.DIENS) I DIFILEI="" S Y=-1 Q S %=$P("K^",U,DIC(0)["K"),(D,DINDEX,DINDEX("START"))=$$DINDEX^DICL(DIFILEI,%) ;ASSUMES A "B" CROSS-REFERENCE K % EN I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% K DO,DICR,DIROUT,DTOUT,DUOUT S U="^" D INIT^DIC0 I DIFILEI="" S Y=-1 D Q^DIC2 Q S DIC(0)=$G(DIC(0)) D . I DIC(0)["T" K ^TMP($J,"DICSEEN") S ^TMP($J,"DICSEEN",DIFILEI)="" . I $D(ZTQUEUED),$E($G(IOST),1,2)'="C-" S DIC(0)=$TR(DIC(0),"AEQ") . I DIC(0)["X",DIC(0)["O" S DIC(0)=$TR(DIC(0),"O") . S:DINDEX("#")>1 DIC(0)=$TR(DIC(0),"M") Q N DIPGM S DIPGM=$$PGM^DIC2(.DIC,$G(DF),DIFILEI) I DIPGM]"" D KILL1^DIC0 K DIC("W") S DIPGM(0)=1 G @DIPGM ASK I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% D INIT^DIC0 I DIFILEI="" S Y=-1 D Q^DIC2 Q I '$D(DIVAL) N DIVAL,DIALLVAL K DIVAL,DIALLVAL S DIVAL(0)=0,Y=-1,DIALLVAL=1 I DIC(0)["A" K X W ! D ^DIC1 I $G(DTOUT) D Q^DIC2 Q I DIC(0)'["A" D CHKVAL^DIC0,CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS) A1 I DIVAL(0) D . D CHKVAL1^DIC0(DINDEX("#"),.DIVAL,DIC(0),DIC(0),.DIALLVAL) Q:'DIVAL(0) . I $D(DIADD),X]"",X'["""" S (X,DIVAL(1))=""""_X_"""" S:DINDEX("#")>1 X(1)=X . N DUOUT K DINDEX S (DINDEX,DINDEX("START"))=D,DINDEX("WAY")=1 . D INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL) Q X ;from DICM0 I $G(DIFILEI)=""!('$D(DINDEX)#2) K DUOUT,DTOUT N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D I DIFILEI="" S Y=-1 D Q^DIC2 Q . D INIT^DIC0 Q:$D(DIVAL(0))!(DIFILEI="") . D SETVAL^DIC0 Q I DIVAL(0),$D(^DD(DIFILEI,.01,7.5)) X ^(7.5) D NODE75^DIC5 I $G(X)="" G:DIC(0)["A" ASK D Q^DIC2 Q N DIPGM S DIPGM=$S(DIVAL(0)'>1:$$PGM^DIC2(.DIC,$G(DF),DIFILEI),1:"") I DIPGM]"" D KILL2^DIC0 S DIPGM(0)=2 G @DIPGM RTN I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D I DIFILEI="" S Y=-1 D Q^DIC2 Q . D INIT^DIC0 Q:$D(DIVAL(0))!(DIFILEI="") . D SETVAL^DIC0 Q I X?1."?" D Q:$G(DTOUT) G:DIC(0)["A" ASK Q . D DSPHLP^DICQ(.DIC,.DIFILEI,.DINDEX,X) . S Y=-1 Q I DIVAL(0)=0!($G(DUOUT)) S Y=-1 D Q^DIC2 Q D:'$D(DO(2)) GETFA^DIC1(.DIC,.DO) GRV I X?1"`".NP S Y=-1 G DBLGRV:X?1"``".E&(DO(2)["P") D BYIEN1^DIC5 Q:Y>0 I '$$TRYADD^DIC11(.DIC,DIFILEI) D DING G:DIC(0)["A" ASK D Q^DIC2 Q I DIVAL(0)=1,+$P(X,"E")=X,X>0 S Y=-1 N DISKIPIX D BYIEN2^DIC5 Q:Y>0 I X=" ",$L(DIC)<29,$D(^DISV(DUZ,DIC))#2 S Y=+^(DIC) D SPACEBAR^DIC5 Q:Y>0 D DING G:DIC(0)["A" ASK D Q^DIC2 Q F ; Start regular lookup N DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS,%Y,%H,DISYS I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D . D INIT^DIC0 Q:$D(DIVAL(0)) . D SETVAL^DIC0 Q F1 S (DD,DS,DS(0),DS("DD"))=0 D SEARCH^DIC3 I $G(DTOUT)!(Y'<0) D Q^DIC2 Q I $P(DS(0),U,2)="?",(DIC(0)_$G(DICR(1,0)))'["A" D K G F1 I +DS(0)=2 S X=$P(DS(0),U,2) D K D G A1 . K DIVAL,DIALLVAL S DIVAL(0)=0,Y=-1,DIALLVAL=1 . D CHKVAL^DIC0,CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS) . Q D D K I Y<0,DIC(0)["A" D D^DIC0 W:DIC(0)["E" ! K:$D(DIROUT) DIROUT G ASK . Q:$G(DIROUT) . I DS(0),$P(DS(0),U,2)="" S:DIC(0)["Y"&($O(Y(0))) Y=0 D DING Q . Q:'($D(DS)#2) . I (DS(0)=0!($P(DS(0),U,2)="U")),DS("DD")=DS,(DO(2)["O"!($G(DIASKOK))!(DIC(0)["T")),DO(2)'["A",DO(2)'["P",DO(2)'["V",DO(2)'["D",DO(2)'["S",DIC(0)["L" D L^DICM . Q D Q^DIC2 Q ; ; DBLGRV S X=$E(X,2,999) S:'$D(DICR(1)) DICR=0 S %="B",DS=^DD(+DO(2),.01,0) D A^DICM K DO S DO="DUMMY" D P^DICM0 S DIC(0)="U"_DIC(0) D D^DICM I Y>0 G K^DICM ;RECURSIVE LOOKUP ON THE SECOND ` NOGOOD D DING G:DIC(0)["A" ASK D Q^DIC2 Q ; ; K K DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS I '$G(DICR),DIC(0)["T" K ^TMP($J,"DICSEEN") S ^TMP($J,"DICSEEN",DIFILEI)="" Q ; DING Q:DIC(0)'["Q"!(DIC(0)'["E") W:'$D(DUOUT) $C(7)_$S('$D(DDS):" ??",1:"") Q ; ; IX N DINDEX,DF S (DF,DINDEX,DINDEX("START"))=D G EN ; A K DIY,DIYX,DS I DIC(0)["A" D D^DIC0 Q NO S Y=-1 D Q^DIC2 Q ; ; DBS Entry points LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DISCREEN,DIWRITE,DILIST,DIMSGA) ; ;ENTRY POINT--return a list of entries from a file (SEA/TOAD) G IN^DICL ; FIND1(DIFILE,DIFIEN,DIFLAGS,DIVALUE,DIFORCE,DISCREEN,DIMSGA) ;SEA/TOAD ;ENTRY POINT--find a single entry in the file I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DICLERR S DICLERR=$G(DIERR) K DIERR N DIERN,DIFIND,DIPE,DITARGET N DIVALS M DIVALS=DIVALUE I $G(DIVALS)="" S DIVALS=$G(DIVALUE(1)) D FIND^DICF($G(DIFILE),$G(DIFIEN),"",$G(DIFLAGS)_"f",.DIVALUE,1,$G(DIFORCE),.DISCREEN,"","DITARGET") I $D(DIERR) S DIFIND="" E I $P($G(DITARGET(0)),U,3) K DITARGET S DIFIND="" D . I $O(DIVALS(1)) N I F I=1:0 S I=$O(DIVALS(I)) Q:'I D:DIVALS(I)]"" Q:'I . . I ($L(DIVALS)+$L(DIVALS(I)))>100 S DIVALS=DIVALS_"...",I="" Q . . S DIVALS=DIVALS_$P(", ^",U,DIVALS]"")_DIVALS(I) Q . D ERR^DICF4(299,$G(DIFILE),$G(DIFIEN),"",DIVALS) . Q E S DIFIND=+$G(DITARGET(1)) I DICLERR'=""!$G(DIERR) D . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA) Q DIFIND ; FIND(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DIVALUE,DINUMBER,DIFORCE,DISCREEN,DIWRITE,DILIST,DIMSGA) ;SEA/TOAD ;ENTRY POINT--in a file find entries that match a value G FINDX^DICF ; ; Error messages: ; 299 More than one entry matches the value(s) '|1|' ; 120 The previous error occurred when performing ; 8090 Pre-lookup transform (7.5 node) ; DIC0 DIC0 ;SFISC/TKW-Lookup routine utilities called by DIC ;16JAN2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; D ; Reset back to starting index for lookup. S D=DINDEX("START") K DINDEX S (DINDEX,DINDEX("START"))=D,DINDEX("WAY")=1 S:$D(DID(1)) DID(1)=2 N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M") D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVAL) Q ; SETVAL ; If custom lookup routine (like MTLU) comes in to entry point after ASK, we need to set up the lookup values. K DIVAL,DIALLVAL D CHKVAL I DIVAL(0) D CHKVAL1(DINDEX("#"),.DIVAL,DIC(0),DIC(0),.DIALLVAL) Q ; INIT ; Initialize variables at all entry points in ^DIC. I $D(DIFILEI)[0 D GETFILE(.DIC,.DIFILEI,.DIENS) Q:DIFILEI="" I '$D(@(DIC_"0)")),'$D(DIC("P")),$E(DIC,1,6)'="^DOPT(" S DIC("P")=$$GETP^DIC0(DIFILEI) I DIC("P")="" S Y=-1 D Q^DIC2 Q I $G(DO)="" K DO D GETFA^DIC1(.DIC,.DO) S (DINDEX,DINDEX("START"))=D,DINDEX("WAY")=1 D INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL) I DIC(0)["V" S DIASKOK=1 S Y=-1 I DIC(0)["Z" K Y(0) Q ; CHKVAL ; Check lookup values input by user. N I I $G(X)="" S X=$G(X(1)) S DIVAL(0)=0,DIVAL(1)=X F I=2:1:DINDEX("#") S DIVAL(I)=$G(X(I)) N J,DIOUT S DIOUT=0 F I=1:1:DINDEX("#") S J=$G(DIVAL(I)) I J]"" D Q:DIOUT . I DINDEX("#")>1 S X(I)=J . I J["^" S (DUOUT,DIOUT)=1,DIVAL(0)=0 Q . I J?1."?" K DIVAL S DIVAL(0)=0,X=$E(J,1,2),DIOUT=1 Q . S DIVAL(0)=DIVAL(0)+1 Q Q ; CHKVAL1(DIXNO,DIVAL,DIFLAGS,DIC0,DIALLVAL) ; Check for errors with values, flags,index. N DIERROR,I S DIALLVAL=1 D . I '$D(DIC0),DIFLAGS'["l" D Q:$G(DIERROR) . . S I=$O(DIVAL(99999),-1) I I>DIXNO S DIERROR=8093 Q . . S:DIXNO>1&(DIFLAGS["M") DIERROR=8095 Q . F I=1:1:DIXNO S DIVAL(I)=$G(DIVAL(I)) D:DIVAL(I)="" . . I DIFLAGS["X",DIFLAGS'["l" S DIERROR=8094 Q . . S DIALLVAL=0 Q . Q I $D(DIERROR) D . I '$D(DIC0) D ERR^DICF4(DIERROR) Q . K DIVAL S DIVAL(0)=0 Q:DIC0'["E" W $C(7),!,$$EZBLD^DIALOG(DIERROR) Q Q ; CHKVAL2(DIXNO,DIVAL,DIC0,DDS) ; Check lookup values for control characters or too long. N I,J,DIER S DIER="" F I=1:1:DIXNO S J=$G(DIVAL(I)) D:J]"" Q:DIER . I J'?.ANP S DIER=204 Q . I J?1.N.1".".N,($L($P(J,"."))>25!($L($P(J,".",2))>25)) S DIER=208 Q . I ($L(J)-255)>0 S DIER=209 . Q Q:'DIER D:DIC0["Q" . W $C(7) Q:DIC(0)'["E" . I '$D(DDS) W !,$$EZBLD^DIALOG(DIER) Q . N DDH S DDH=1,DDH(1,"T")=" ** "_$$EZBLD^DIALOG(DIER) . S DDC=7,DDD=1 D LIST^DDSU . Q K DIVAL S DIVAL(0)=0 Q ; KILL2 K DIVAL,DIALLVAL KILL1 K DIFILEI,DINDEX,DIMAXLEN,DIENS Q ; GETFILE(DIC,DIFILE,DIENS) ; Return file number, global references, IEN string and KEY fields data. S DIFILE="" I $G(DIC)="" Q I +$P(DIC,"E")'=DIC N DIDIC M DIDIC=DIC N DIC S DIDIC=$$CREF^DILF(DIDIC),DIDIC=$NA(@DIDIC),DIDIC=$$OREF^DILF(DIDIC) M DIC=DIDIC K DIDIC N DA I +$P(DIC,"E")=DIC D . S DIFILE=DIC,DIC=$G(^DIC(DIC,0,"GL")) Q:DIC]"" . S DIC=DIFILE,DIFILE="" Q E D . S DIFILE=$G(@(DIC_"0)")) I DIFILE]"" S DIFILE=+$P(DIFILE,U,2) Q . S DIFILE=+$G(DIC("P")) Q:DIFILE . ;I DIC["^DD(",'$D(@(DIC_"0)")) S DIFILE="" Q . S DIFILE=$$FILENUM^DILIBF(DIC) Q Q:DIFILE="" S DIENS="," I DIC(0)'["p" D SETIEN(DIC,DIFILE,.DIENS) Q:DIFILE="" S DIFILE(DIFILE,"O")=DIC S DIFILE(DIFILE)=$$CREF^DILF(DIC) N I S I=$O(^DD("KEY","AP",DIFILE,"P",0)) Q:'I S DIFILE(DIFILE,"KEY","IEN")=DIENS N F,X F F=0:0 S F=$O(^DD("KEY",I,2,F)) Q:'F S X=$G(^(F,0)) D . S DIFILE(DIFILE,"KEY",+$P(X,U,2),+$P(X,U,3),+X)="" Q Q ; SETIEN(DIC,DIFILE,DIENS) ; Set DIENS from global root N F,G,I,J,K,DIDA S F=$$FNO^DILIBF(DIFILE) I F="" S DIFILE="" Q S G=$G(^DIC(F,0,"GL")) I G="" S DIFILE="" Q S F=$P(DIC,G,2) S K=0 F I=1:2 S J=$P(F,",",I) Q:J="" S K=K+1,J(K)=J S DIDA="" F J=1:1:K S DIDA(K+1-J)=J(J) S DIENS=$$IENS^DILF(.DIDA) Q ; GETP(DISUB) ; Return DIC("P") for a subfile DIFILE. N DIFILE S DIFILE=$G(^DD(DISUB,0,"UP")) Q:'DIFILE "" N DIFIELD S DIFIELD=$O(^DD(DIFILE,"SB",DISUB,0)) Q:'DIFIELD "" Q $P($G(^DD(DIFILE,DIFIELD,0)),U,2) ; DSPH ; Display name of indexed fields when DIC(0)["T" (called from DIC1 & DIC2) Q:$G(DS(0,"HDRDSP",DIFILEI)) S DS(0,"HDRDSP",DIFILEI)=1 W ! N I S I=($G(DICR))*2 W:I ?I W " Lookup: " I $G(DICR) S I=$G(@(DIC_"0)")) I I]"" W $P(I,U)_" " F I=1:1:DINDEX("#") W DINDEX(I,"PROMPT")_$P(", ^",U,I1.9 S $P(DO,U)=$$FILENAME^DIALOGZ(+$P(DO,U,2)) ;**CCO/NI PROMPT FILE NAME and following line DO2 S DO(2)=$P(DO,U,2) I DO?1"^".E S $P(DO,U)=$$FILENAME^DIALOGZ(+DO(2)) I DO(2)["s",$D(^DD(+DO(2),0,"SCR")) S DO("SCR")=^("SCR") Q:$D(DIC("W")) Q:DO(2)'["I" Q:'$D(^DD(+DO(2),0,"ID")) S DIC("W")="" P ; Add code to DIC("W") to display identifiers on pointed-to files I DO(2)["P" D WOV,PTRID^DIC5(.DO,.DIC) Q N % S %=0 ; W F S %=$O(^DD(+DO(2),0,"ID",%)) D:%]"" Q:%="" . N X S X=^DD(+DO(2),0,"ID",%) Q:X="W """"" . I $L(DIC("W"))+$L(X)>224 D WOV S %="" Q . I DIC("W")="" S DIC("W")="N C,DINAME" . S DIC("W")=DIC("W")_" W "" "" "_X . Q Q ; WOV S DIC("W")="N DIFILEI,DIEN,DIGBL S DIFILEI=+DO(2),DIEN=Y,DIGBL=DIC D WOV^DICQ1" Q ; RENUM ; D GETFA(.DIC,.DO) I '$D(DF),X?.NP,^DD(+DO(2),.01,0)["DINUM",$D(@(DIC_"X)")) D Q:Y>0 . S Y=X D S^DIC3 I $T N DZ D ADDKEY^DIC3,GOT^DIC2 Q . S Y=-1 Q D F^DIC Q ; DT S DST=DST_$$DATE^DIUTL(%) ;**CCO/NI DATE FORMAT I '$D(DDS) W DST S DST="" Q ; Y ; Display a list of entries N DD,DDD,DDC,DDH,DIOUT S DIY="",DIOUT=0,DD=DS("DD") I DD=0,DIC(0)["T",DIC(0)["E" D DSPH^DIC0 F S DD=$O(DS(DD)) Q:'DD D Q:DIOUT . S DDH=DD-1,DIYX=0,DS("DD")=DD . I DIC(0)["E" W:'$D(DDS) !?5,DD,?9 D . . N Y S Y=+DS(DD) . . D E Q . I DIC(0)["Y" Q:DDDD Q:DD#5 . S DIOUT=1 . I $D(DDS) S DDD=2,DDC=5 D LIST^DDSU K DDD,DDC . I '$D(DDS) D . . I DS>DD W !,$$EZBLD^DIALOG(8087,$S(DIC(0)["T":"'^^' to exit all lists,",1:"")) ;**PATCH 122 . . N R S R(1)=$O(DS(0)),R(2)=DD W !,$$EZBLD^DIALOG(8088,.R) R DIY:$S($D(DTIME):DTIME,1:300) S:'$T DTOUT=1 Q ;** . I $G(DTOUT) W $C(7) S X="" Q . I DIY[U!($G(DUOUT)) S DUOUT=1,X=U D Q . . I DIY?1"^^".E,DIC(0)["T" S DIROUT=1 Q . . I DIY?1"^".E,DIC(0)["E",DIC(0)'["T" S DIROUT=1 Q . Q I DIY?1.N.1".".N D I DIY,DIY'>DD,$G(DS(DIY)) S Y=+DS(DIY) D GOT S DS(0)=1_"^"_+Y Q . S:($L($P(DIY,"."))>25!($L($P(DIY,".",2))>25)) DIY="-1" Q I $L(DIY)>25 S DIY=-1 N I S I=$S($G(DUOUT):"1^U",$G(DTOUT):"1^T",DIY?1."?":"1^?",DIY:1,1:"") I 'I,DIY]"",+$P(DIY,"E")'=DIY,'$G(DICR),DINDEX("#")=1 S I="2^"_DIY Q:'I S DS(0)=I,Y=-1 I DIY?1."?" D . I (DIC(0)_$G(DICR(1,0)))'["A",$D(DICRS) Q . N X,Y,DS D DSPHLP^DICQ(.DIC,.DIFILEI,.DINDEX,"?",1) K DIY,DIYX Q ; E S DST="" D . Q:DIC(0)["U" . I $O(DS(DD,0)) S DST=$$BLDDSP(.DS,DD) Q . S %=$S($G(DILONGX):DICR(DILONGX,"ORG"),$G(DINDEX("IXTYPE"))'="S":$P(X,U),1:"") . S %=%_$P(DS(DD),U,2,9)_$S($G(DIYX(DD)):DIY(DD),1:"") . I ($G(DITRANX)!($G(DICRS))),$G(DINDEX(1,"TRANOUT"))]"",%]"" D Q . . N X S X=% X DINDEX(1,"TRANOUT") S DST=$G(X) Q . I +$P(%,"E")=%,$D(DIDA) D DT Q . I $G(DICRS),$G(DINDEX("IXTYPE"))="R" D . . N F1,F2 S F1=$G(DINDEX(1,"FILE")),F2=$G(DINDEX(1,"FIELD")) . . I F1,F2 S %=$$EXT^DIC2(F1,F2,%,"h") . . Q . S DST=% Q I DIC(0)["s" S DIC(0)=$TR(DIC(0),"s") I $D(DS(DD,"K")) S %=$G(DIX) M DIX=DS(DD) S DIX=% S DIY=$S($G(DIYX(DD)):"",1:DIY(DD)) D WO^DIC2 Q ; BLDDSP(DS,DD,DINDXFL,DIYX,DIY,DICRS) ; Build display of index values N X,I S X="" F I=0:0 S I=$O(DS(DD,I)) Q:'I D . I $L(X)+$L(DS(DD,I))>240 Q . I I=1,$G(DINDXFL) S X=$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"") Q . I I=1,$G(DICRS) Q . S X=X_$P(" ^",U,I>1)_DS(DD,I) Q Q X ; GOT ; Set data for single entry selected by user. N I,J,K I DIY(DIY)="" S DIY(DIY)=$P($G(@(DIC_"Y,0)")),U) S:$D(DDS) DST=X_$P(DS(DIY),U,2,9)_$S($G(DIYX(DIY)):$G(DIY(DIY)),1:"") S K=$O(DIVPSEL("A"),-1) I K]"" S DIVPSEL(K)=Y I $G(DIFINDR) D Q . S:$D(DDS) DS(0,"DST")=DST . S DS(0,"Y")=+DS(DIY),DS(0,"X")=X_$P(DS(DIY),"^",2),DS(0,"DIYX")=$G(DIYX(DIY)),DS(0,"DIY")=DIY(DIY) . M DS(0,1)=DS(DIY) . Q I $G(DIYX(DIY)) K DIYX S DIY(DIY)=$P($G(@(DIC_"Y,0)")),U) D C^DIC2 Q ; OK ; S %=1 I $G(DS)=1 S DST=" ...OK" D Y^DICN W:'$D(DDS) ! I %>0 Q:%=1 D S X=$G(DIX),Y=-1 Q ;%=1=Yes, %=2=No . I $G(DICR) S DICR(DICR,31.2)=+Y ;Preserve IEN for future reference . I +$G(DS) K DS S (DS,DS(0),DS("DD"))=0 ;ReInit Display array . Q I %=0 W !?4,$$EZBLD^DIALOG(8040),! G OK ;User asked for Help I %=-1,$D(DTOUT) S DIROUT=1 ;User TIMED Out; DTOUT set in DICN I %=-1,'$D(DTOUT) S (DUOUT,DIROUT)=1 ;User single up-arrowed out BAD S Y=-1 I $G(%Y)?1"^^".E S (DIROUT,DUOUT)=1 S DS(0)=$S($G(DTOUT):"1^T",$G(DUOUT):"1^U",$G(%)=-1:"1^U",1:"1^") Q MIX ; N DID S DID=D_"^-1",DID(1)=2 N D S D=$P(DID,U) G IX^DIC ; ;#8042 Select |filename|: ;#8040 Answer with 'Yes' or 'No' DIC11 DIC11 ;SFISC/TKW-PROMPT USER FOR LOOKUP VALUES ;05:33 PM 11 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. PROMPT N DIOUT S (DIVAL(0),DIOUT)=0 F DISUB=1:1:DINDEX("#") D PR1 Q:DIOUT S X=$G(DIVAL(1)) I DINDEX("#")>1 M X=DIVAL D K X(0) ; W:$O(DIVAL(1)) ! . I X?1"^"1.E K X S X=$G(DIVAL(1)) Q Q ; PR1 S DIY=DIPRMT(DISUB),DIVAL(DISUB)="" N X I $G(DIY(DISUB))]"" S DIY=DIY_$S($D(DIY(DISUB,"EXT")):DIY(DISUB,"EXT"),1:DIY(DISUB))_"// " W DIY R X:$S($G(DTIME):DTIME,1:300) I '$T S (DIOUT,DTOUT)=1 W $C(7) K DIVAL S DIVAL(0)=0 Q I X'?.ANP D:DIC(0)["Q" S DISUB=DISUB-1 Q . W $C(7)," ",$$EZBLD^DIALOG(204),! Q I X?1.N.1"."1.N,($L($P(X,"."))>25!($L($P(X,".",2))>24)) D:DIC(0)["Q" S DISUB=DISUB-1 Q . W $C(7)," ",$$EZBLD^DIALOG(208),! Q I X="^"!($E(X)="^"&(DISUB>1)) S (DIOUT,DUOUT)=1 K DIVAL S DIVAL(0)=0,DIVAL(1)="^" Q I $L(X)>250 D:DIC(0)["Q" S DISUB=DISUB-1 Q . W $C(7)," ",$$EZBLD^DIALOG(209),! Q I X?1."?" K DIVAL S DIVAL(1)=$E(X,1,2),DIVAL(0)=0,DIOUT=1 Q I (X?1"`".NP)!(X=" ") K DIVAL S DIVAL(1)=X,(DIVAL(0),DIOUT)=1 Q W:DINDEX("#")>1 ! S DIVAL(DISUB)=X I X="",$G(DIY(DISUB))]"" S DIVAL(DISUB)=DIY(DISUB) S:DIC(0)'["O" DIC(0)=DIC(0)_"O" Q:DIVAL(DISUB)="" S DIVAL(0)=DIVAL(0)+1 S:$E(X)="^" (DIOUT,DUOUT)=1 Q ; GETPRMT(DIC,DO,DINDEX,DIPRMT) ; Build list of prompts for each lookup value N DICA I $D(DIC("A")) S DICA(1)=$G(DIC("A")) M DICA=DIC("A") N DISUB,I,L,P S L=0 F DISUB=1:1:DINDEX("#") D . I $G(DICA(DISUB))]"" D I DIPRMT(DISUB)]"" . . S DIPRMT(DISUB)="" ANOTHER . . I DISUB=1,DINDEX("#")>1,DICA(DISUB)=$$EZBLD^DIALOG(8199) Q ;**CCO/NI 'ANOTHER ONE:' . . S DIPRMT(DISUB)=DICA(DISUB) Q . E D . . S P=$S(DISUB=1:$P(DO,U),1:"") . . I DISUB=1,$G(DICA(DISUB))=$$EZBLD^DIALOG(8199) S P=$$EZBLD^DIALOG(8050)_P . . I DINDEX("#")=1,D'="B"&(DIC(0)["M")!(D="B"&(DO(2)'>1.9)) S DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P) Q . . N X S X=DINDEX(DISUB,"PROMPT") I X]"" D . . . I DISUB=1 Q:DINDEX("#")=1&(P[X!(X[P)) S P=P_" " . . . S P=P_X Q . . I DISUB=1 S DIPRMT(DISUB)=$$EZBLD^DIALOG(8042,P) . . E S DIPRMT(DISUB)=P_": " . . Q . S I=$L(DIPRMT(DISUB)) S:I>L L=I Q Q:DINDEX("#")=1 S I="",$P(I," ",L)="" F DISUB=1:1:DINDEX("#") S DIPRMT(DISUB)=$E(I,1,(L-$L(DIPRMT(DISUB))))_DIPRMT(DISUB) Q ; TRYADD(DIC,DIFILEI) ; Return 1 if user should be allowed to attempt to add record ; when lookup value `ien and .01 is a pointer. Q:DIC(0)'["L" 0 N % S %=$P($G(^DD(DIFILEI,.01,0)),U,2) I %["P"!(%["V") Q 1 Q 0 ; ; Error messages ; 204 The input value contains control characters. ; 208 Input value is an illegal number. ; 209 Input value is too long. ;8042 Select |1|: ;8050 Another ; DIC2 DIC2 ;SF/XAK/TKW-LOOKUP (CONT) ;06:31 PM 7 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. WO ; Display .01 field, Primary KEY values and Identifiers for an entry. I '$D(DST) N DST S DST=$G(DST)_" " D WR I $D(DIC("W")),$D(@(DIC_"Y,0)")) D:$D(DDS)&'$D(DDH("ID")) ID^DICQ1 I '$D(DDS) D . I $G(DST)]"" W DST," " . N DISAVEX M DISAVEX=Y N Y M Y=DISAVEX S DISAVEX=X N X S X=DISAVEX K DISAVEX . I $D(@(DIC_"Y,0)")) X DIC("W") . K DST Q Q WR ; Put .01 field into DST for display D:'$D(DO) GETFA^DIC1(.DIC,.DO) I '$D(DST) N DST I (DIC(0)["S"!(DIC(0)["s")),DIVAL(1)'=" " Q:" "[$G(DST)&('$D(DIX("K"))) D S Q S DST=$G(DST) I DO(2)["V",DIY?1.N1";"1.E S DST=DST_$$EXT(+DO(2),.01,DIY) D S Q I DIY?.N.1".".N,(DO(2)["P"!(DO(2)["D")),DIY D D S Q . I DO(2)["P" S DST=DST_$$EXT(+DO(2),.01,DIY) Q . N % S %=DIY D DT^DIC1 Q W1 I '$G(DIYX),DIY]"",((DST'[DIY)!($P(DST,DIY)]"")) S DST=DST_DIY S ; Put Primary KEY values into DST, display DST if not in ScreenMan I $D(DIX("K")),DIC(0)'["S" N I,F,% F I=0:0 S I=$O(DIX("K",I)) Q:'I F F=0:0 S F=$O(DIX("K",I,F)) Q:'F D . I DIY]"",F=.01 Q . I $G(DIX("F"))[("^"_F_"^") Q . S %=DIX("K",I,F) Q:%="" I $L(%)+$L(DST)>240 Q . S DST=DST_$P(" ^",U,DST]"")_% Q N A1 S A1=Y I '$D(DDS) W DST K DST Q H ; Display .01 and Primary KEY values if in ScreenMan I '$D(A1) N A1 S A1="T" S DDH=$G(DDH)+1,DDH(DDH,A1)=DST K DST Q ; EXT(DIFILE,DIFIELD,DIVAL,DIF) ; Return external value of field N DIERR,DISAV S DISAV=$G(DIVAL) I DISAV="" Q DISAV S DIF=$G(DIF) S:DIF="" DIF="F" S DIVAL=$$EXTERNAL^DIDU(DIFILE,DIFIELD,DIF,DIVAL,"DIERR") I $D(DIERR) S DIVAL=DISAV Q DIVAL ; PGM(DIC,DF,DIFILE) ; Return special lookup program name I DIC(0)["I"!($G(DF)]"") Q "" N DIPGM S DIPGM=$G(^DD(DIFILE,0,"DIC")) Q:DIPGM=""!(DIPGM?1"DI".E) "" Q U_DIPGM ; GOT I DIC(0)["E" D . N:'$D(DST) DST N DDH D WO . I $D(DDS),$D(DDH)>10 D LIST^DDSU K DDH("ID") . Q S Y=Y_"^"_$S(DIY="":X,$G(DIYX):X_DIY,1:DIY) I DIC(0)["E" D Q:Y<0 . I DO(2)["O"!($G(DIASKOK)) D OK^DIC1 Q . Q:DIC(0)'["T" . I $G(DICR) Q:'$G(DICRS)!(DICR'=1) D OK^DIC1 Q . D OK^DIC1 Q R D:'$G(DICR) I Y<0 D A^DIC S DS(0)="1^" Q . D ACT^DICM1 Q:Y<0 . Q:DINDEX("#")'>1!(DINDEX("START")'=DINDEX) . N I F I=1:1:DINDEX("#") I $D(DIX(I))#2 S X(I)=DIX(I) . Q I DIC(0)["Z" S Y(0)=@(DIC_"+Y,0)"),Y(0,0)=$$EXT(DIFILEI,.01,$P(Y(0),U)) ACT I DIC(0)'["F",$D(DUZ)#2 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_+Y I $D(@(DIC_"+Y,0)")) D:DIC(0)'["T" Q Q S Y=-1 D Q S DS(0)="1^" Q ; Q K DIDA,DID,DISMN,DINUM,DS,DF,DD,DIX,DIY,DIYX,DZ,DO,D,DIAC,DIFILE I '$G(DICR) K DIC("W"),DIROUT I DIC(0)["T" K ^TMP($J,"DICSEEN") Q ; G ; Display index values for a single looked-up entry I $D(DS(0,"DICRS")),'$D(DICRS) N DICRS S DICRS=1 I $D(DS(0,"DIDA")),'$G(DIDA) N DIDA S DIDA=1 I $D(DIDA),$P(DS(1),U,2,99)]"" N:'$G(DIASKOK) DIASKOK S DIASKOK=1 I DIC(0)["T",DIC(0)["E",'$D(DDS) D DSPH^DIC0 W ! S DIY=1,DIX=X I DIC(0)["E",DIC(0)'["U" D . I DIC(0)["D" Q:$P(DS(1,"F"),U,2)=.01 N DIENTIRE S DIENTIRE=1 . N D,% S (D,%)="" . I $G(DIDA),$P(DS(1),U,2,99)]"" S %=" partial match to:" . I $O(DS(1,0)) D . . I DINDEX("#")=1,'$G(DIDA) S D=%_$$BLDDSP^DIC1(.DS,1,1,.DIYX,.DIY,$G(DICRS)) Q . . S D=%_$$BLDDSP^DIC1(.DS,1,"","","",$G(DICRS)) Q . E I $G(DITRANX) D . . S D=X_$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"") . . I $G(DINDEX(1,"TRANOUT"))]"" N X S X=D X DINDEX(1,"TRANOUT") S D=$G(X) . . S:D]"" D=" "_D I $G(DIFINDER)["p",'$D(DDS) W ! . . Q . E I '$D(DICRS) D . . I $G(DIDA) S D=$P(DS(1),U,2,99) I D]"" S D=%_" "_$$DATE^DIUTL(X_D) W:'$D(DDS) ! Q ;**CCO/NI . . S D=$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"") . . I $G(DIFINDER)["p" S D=X_D W:'$D(DDS)&(DIC(0)'["T") ! Q . . I DIC(0)["T"!($G(DIENTIRE)) S D=X_D . . Q . S DST=$P(" ^",U,$D(DST)#2)_D . I '$D(DDS) W DST S DST="" . Q C S Y=$G(DIX) M DIX=DS(DIY) S DIX=Y I $O(DS(1)) K DIX("F") S Y=+DS(DIY),X=X_$P(DS(DIY),"^",2),DIYX=$G(DIYX(DIY)),DIY=DIY(DIY) D GOT Q ; ; DIC3 DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;28SEP2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; SEARCH ; Begin search through x-refs. I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O" . I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q . S DIC(0)=$TR(DIC(0),"X") Q I X?1"`".NP D ^DICM Q I $L(X)>DINDEX(1,"LENGTH"),'$G(DILONGX) D ^DICM Q N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M EXACT ; Find all exact matches to the lookup values S DISAVDS=DS,DIEXACTN=0 I $G(DILONGX) D ;G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D ;JUMPED AWAY FROM USING THIS INDEX, EVEN THOUGH IT MIGHT NEVER HAVE BEEN TRIED BEFORE . S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DILONGX,"ORG"),1,DINDEX(1,"LENGTH")) ;TRIM LOOKUP VALUE DOWN TO SIZE! I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4 I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0)) I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 . ; Set up variables for next index lookup . K DS,DUOUT . S (DS,DS(0),DS("DD"))=0 . S X=DIVAL(1) . Q I DISAVDS=0,DS=1,DIC(0)["O"!(DIC(0)'["E"),DIC(0)'["T" D Q:Y>0!($D(DIROUT)) ;Good IEN returned or user bailed out . I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q . S Y=+DS(1),DS("DD")=1 . I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q . D G^DIC2 Q ; PARTIAL ; Find all partial matches to the lookup values I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4 I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0)) . N DITYP S DITYP=$G(DINDEX(1,"TYPE")) . D . . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n" . . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1) . . Q . S DIX=$O(@(DIC_"D,DIX)")) . Q:DIX="" . I $P(DIX,X)'="" D Q:DIX="" . . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q . . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q . . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) ;DIC(0)["n" SO WE KEEP LOOKING FOR PARTIAL NUMERIC MATCHES . . S:$P(DIX,X)'="" DIX="" Q . S Y=0 F D MOREX Q:Y=-1!(DS(0)) . Q I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 . ; Set up variables for next index lookup . K DS,DUOUT . S (DS,DS(0),DS("DD"))=0 . S X=DIVAL(1) . Q ; M ; Find the next index. At end, display the rest I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) I DIC(0)["M" S DIOK=0 F D Q:DIOK . N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1 . S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) ;GRAB THE NEXT EXISTING CROSS-REF . S:$D(DID) DID(1)=DID(1)+1 . I D=""!(D=-1) S D="",DIOK=1 Q . I $D(@(DIC_"D)"))-10 Q . ; Check Index, build index info . D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) ;DINDEX=D. Check that it's OK I DIC(0)["M",D]"" G EXACT D:DIC(0)["M" D^DIC0 I DS=1 S DS("DD")=1 D G^DIC2 Q I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q I $G(DILONGX) S X=$E(DICR(DILONGX,"ORG"),1,30) I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q . S Y=-1 I $G(DICR)="" N DICR S DICR=0 . I $A(X)=34,X?.E1"""" D N^DICM Q . K DD D L^DICM Q D ^DICM Q ; ; MOREX ; Find more exact matches to lookup value DIX S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1 D MN Q:'$T D K Q:$G(DS(0)) I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1 Q ; MN N DZ S DZ=$S((DIC(0)["D"&(DINDEX="B")):1,$G(DINDEX("#"))>1:0,$G(@(DIC_"D,DIX,Y)")):1,1:0) S DIYX=0 D:'$D(DO) GETFA^DIC1(.DIC,.DO) I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D . N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I="" . Q S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q I D="B",'DZ,'$D(DO("SCR")),$L(DIX)<30,'$D(DIC("S")),'$D(@(DIC_"Y,-9)")),'$G(DINDEX("OLDSUB")) D ADDKEY I 1 Q D S I D . I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q . . N I S I=$S($G(DILONGX):DICR(DILONGX,"ORG"),1:DIX) . . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q . Q:DIC(0)["Y" . I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q . . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN) . . D ADDKEY Q . D ADDKEY . I DINDEX("FLISTD")["^.01^",'DZ S DIY="" . Q Q ; S D:'$D(DO) GETFA^DIC1(.DIC,.DO) I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U) E S DIY="" Q I '$D(DIC("S")),'$D(DO("SCR")) Q I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q I $G(DILONGX) N DI0NODE,DIVAL D . N % S %=DINDEX(1,"GET") . I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q . I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)") . N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI) . N DIEN S DIEN=Y_DIENS . S @% Q N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)")) I $D(DIVAL(1)),$D(DIVAL)=10 S DIVAL=DIVAL(1) ;*159 I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T I 1 Q ; SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q ; ADDKEY ; Put KEY values into output array for display S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD")) Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S" N DIKX,DII,DIFLD,DIERR,I M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX) K DIX("K") F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D . I DIFLD=.01,$G(DZ)=0 S DIY="" . S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q Q ; K ; Put an IEN into the DS array for display N DZ,I S DZ=$O(DS(0)) F I=DZ:1:DS I +$G(DS(I))=Y,DIC(0)'["C" S I=-1 Q I I'=-1,DIC(0)["T" D . Q:'$D(^TMP($J,"DICSEEN",DIFILEI)) . I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q . S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q I DS-DZ>100 D . N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1) . Q S DS=DS+1 D . S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I . S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 I DS#5-1!(DS=1)!(DIC(0)["Y") Q D Y^DIC1 Q DIC4 DIC4 ;SFISC/TKW-VA FileMan Lookup utilities ;5:59 AM 20 Sep 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EXACT ; Find next exact match on a compound index N DIFLAGS,DIFIELDS,DIWRITE,DIIENS,DIFORCE,DIERR,DISCR,DIQUIET,DIIX S DIFLAGS="lX" D GETPAR N DINDEX D FIND^DICF(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,.DIVAL,"*",.DIFORCE,.DISCR,$G(DIC("W")),"DS","DIERR",.DIIX,.DIC,.DIY,.DIYX) D:$G(DIERR) PROCERR Q ; PARTIAL ; Find next partial match on a compound index N DIFLAGS,DIFIELDS,DIWRITE,DIIENS,DIFORCE,DIERR,DISCR,DIQUIET,DIIX S DIFLAGS="l" D GETPAR K DIIX("DONE") N DINDEX I DIFLAGS'["Q",$G(DS("INT"))]"","VP"[DIIX(1,"TYPE") N I M I=DIVAL N DIVAL D . S (I,I(1),DIIX(1),DIIX(1,"FROM"),DIIX(1,"PART"))=DS("INT") . S DIIX(1,"TYPE")="F" M DIVAL=I K I Q D FIND^DICF(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,.DIVAL,"*",.DIFORCE,.DISCR,$G(DIC("W")),"DS","DIERR",.DIIX,.DIC,.DIY,.DIYX) D:$G(DIERR) PROCERR Q ; SET I $P(DS(0),U,2) D SETY Q S Y=-1 Q:'DS(0) D SETOUT Q ; SETOUT ; Set variables if user up-arrowed or timed out. S Y=-1 N I S I=$P(DS(0),U,2) I I="U",DIC(0)'["A" S DUOUT=1 S:I="T" DTOUT=1 Q ; SETY ; If entry was selected by user, set output variables. S Y=DS(0,"Y") S:$D(DDS) DST=DS(0,"DST") S (X,X(1))=DS(0,"X"),DIYX=DS(0,"DIYX"),DIY=DS(0,"DIY") N % S:$G(DIX)]"" %=DIX M DIX=DS(0,1) K DS(0),DIX("F") S:$D(%) DIX=% D GOT^DIC2 I Y<0 S DS(0)="1^" Q S DS(0)="1^"_+Y Q ; GETPAR ; Set parameters for Finder call D:DIFLAGS'["Q" . N I S I=0 I $A(X)=34,X?.E1"""" S I=1 . I I!(DIC(0)["U")!(DIC(0)["M")!($G(DICR)) S DIFLAGS=DIFLAGS_"Q" . Q S DIIENS=$S(DIC(0)["p":",",1:DIENS) I DIC(0)'["E" S DIQUIET=1 S (DIFORCE,DIFORCE(1))=1,DIFORCE(0)=DINDEX I $D(DIC("PTRIX")) M DIFORCE("PTRIX")=DIC("PTRIX") D:$G(DIC("S"))]"" . M DISCR("S")=DIC("S") . S I="S" F S I=$O(DIC(I)) Q:$E(I)'="S" S DISCR(I)=DIC(I) . Q I $D(DIC("V"))]"" M DISCR("V")=DIC("V") S DIFIELDS="@" M DIIX=DINDEX Q ; ADDIX(DIFILEI,Y,DINDEX,DIX,DISCREEN) ; Put index values into DIX variable for display N DISUB,DIVAL,DI0NODE,DIFILE S DI0NODE=$G(@DIFILEI(DIFILEI)@(Y,0)),DIX(1)="" M DIFILE=DIFILEI I $G(DINDEX("OLDSUB")) N DIO,DIN S DIN=0 F DIO=1:1:DINDEX("OLDSUB") D . S DIVAL="" . I $G(DISCREEN("X",DIO,"GET"))]"" D . . X DISCREEN("X",DIO,"GET") Q . E S DIN=$O(DINDEX(DIN)) I DIN,DIN'>DINDEX("#") S DISUB=DIN D GETVAL . S:DIVAL]"" DIX(DIO)=DIVAL Q Q:$G(DINDEX("OLDSUB")) F DISUB=1:1:DINDEX("#") D GETVAL S:DIVAL]"" DIX(DISUB)=DIVAL Q GETVAL ; Return index value in DIVAL I $G(DINDEX(DISUB,"TRANOUT"))]"" D Q . S DIVAL=DINDEX(DISUB) Q:DIVAL="" N X S X=DIVAL . X DINDEX(DISUB,"TRANOUT") S:X]"" DIVAL=X Q S @DINDEX(DISUB,"GET") Q:DIVAL="" I "VPSD"[DINDEX(DISUB,"TYPE")!(DISUB=1&($G(DS("INT"))]"")) D . I DISUB>1,"VP"[DINDEX(DISUB,"TYPE") Q . S DIVAL=$$EXT^DIC2(DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),DIVAL) Q Q ; IXCHK(DIFILEI,DINDEX,DIOK,DIALLVAL,DIVAL,DID) ; Build INDEX info, make sure indexed field not a pointer. S DIOK=0 N DIVALX S DIVALX=$G(DIVAL(1)) N DIXIEN S DIXIEN=+$O(^DD("IX","BB",DIFILEI,DINDEX,"")) I DIXIEN,$G(DID)="",$P($G(^DD("IX",DIXIEN,0)),U,14)'["L" Q I 'DIXIEN!('$O(^DD("IX",DIXIEN,11.1,"AC",1))) D Q . N DIFLAGS S DIFLAGS="hql" S:$G(DILONGX)!(DIC(0)["T") DIFLAGS="4l" . I +$P(DIVALX,"E")=DIVALX,DIC(0)["E" S DIFLAGS="4l" . D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX) . I +$P(DIVALX,"E")=DIVALX,$G(DINDEX(1,"TYPE"))="P" D Q ;22*70 IGNORE POINTERS IF YOU ARE LOOKING UP A NUMBER VALUE!! . .I DIC(0)["T",DIC(0)["E" S (DIOK,DIOK("T"))=1 ;22*70 . S DIOK=1 Q D INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL) S (DIALLVAL,DIOK)=1 N I F I=1:1:DINDEX("#") S:$G(DINDEX(I,"PART"))="" DIALLVAL=0 Q ; PROCERR ; Display errors generated from call to Finder. I DIC(0)'["E" K DIERR Q W $C(7) W:'$D(DDS) ! N A1,DDH,I,J S DDH=0 F I=1:1:+DIERR F J=0:0 S J=$O(DIERR("DIERR",I,"TEXT",J)) Q:'J D . I '$D(DDS) W DIERR("DIERR",I,"TEXT",J),! Q . S DDH=DDH+1,DDH(DDH)=DIERR("DIERR",I,"TEXT",J) Q K DIERR I '$D(DDS) W !! Q S A1="T" D LIST^DDSU Q ; DIC5 DIC5 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (utilities) ;24MAY2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. NODE75 ; Do after executing 7.5 node on DD, called from ^DIC I $D(X)#2 S (DIVAL,DIVAL(1))=X Q S Y=-1 Q:DIC(0)'["Q"!(DIC(0)'["E") W $C(7) Q:$D(DDS) W !,$$EZBLD^DIALOG(120,$$EZBLD^DIALOG(8090)) Q ; BYIEN1 ; Lookup record by IEN when user enters `n for a number 'n', called from ^DIC S Y=$E(X,2,30) I Y="" S Y=-1 Q N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% D S^DIC3 I '$T S Y=-1 Q N DD,DS,DZ S DS=1,DD=Y,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q ; BYIEN2 ; Lookup record by IEN when user enters a numeric lookup value, called from ^DIC Q:DO(2)<0!($D(DF)) N T S T=DINDEX(1,"TYPE") I $D(@(DIC_"X,0)")) D Q:Y>0 . N DD S DD=$D(^DD(DIFILEI,.001)) . I 'DD Q:T["N" I '$O(@(DIC_"""A["")")),$O(^("A["))]"" Q . N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% . S Y=X D S^DIC3 I '$T S Y=-1 Q . N DZ,DS,DIX,DIC5D S DIC5D=D,DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q:Y>0 . D DO^DIC1 S D=DIC5D I T["P"!(T["V"),DIC(0)'["U" S DISKIPIX=D Q ; SPACEBAR ; Lookup last record selected by this user when user enters space bar return. Called from ^DIC N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% D S^DIC3 I '$T S Y=-1 Q N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q ; KEEPON ; If DIC(0)["T", display entries found so far, then check for internal value if index is date, set, pointer, VP. Called from ^DIC3. I DS D Q:Y>0!($G(DTOUT))!($G(DIROUT)) . N I M I=X N X M X=I S I=D N D S D=I K I . I DS=1 D . . S DS("DD")=1 D G^DIC2 Q . E I $G(DS("DD"))'=DS D Y^DIC1 I '$D(DIROUT),$D(DUOUT) K DUOUT ;22*70 . K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 . S:DIC(0)["E" DS(0,"HDRDSP",DIFILEI)=1 . S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) . Q Q:DIC(0)["U" I DINDEX=DINDEX("START"),$G(DINDEX("#"))>1 Q N I M I=X N X M X=I S I=D N D S D=I K I D 1^DICM K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) Q ; PTRID(DO,DIC) ; Build code in DIC("W") to display Identifiers on pointed-to files N DIFILEI,DIGBL,DIOGBL S DIFILEI=+DO(2),DIOGBL=DIC F S DIFILEI=+$P($P($G(^DD(DIFILEI,.01,0)),U,2),"P",2) Q:'DIFILEI S DIGBL=$G(^DIC(DIFILEI,0,"GL")) Q:DIGBL="" D Q Q Q ; Build Identifier code for a single pointed-to file N DIGBL1 S DIGBL1=DIGBL I DIGBL[$C(34) S DIGBL1=$$CONVQQ^DILIBF(DIGBL) N N,O,% S N=$O(DIC("W",999999),-1) S O=$S(N:DIC("W",N),1:DIC("W")) N % S %="I '$G(DICR) S DIEN=+"_DIOGBL_"DIEN,0) I $D("_DIGBL_"DIEN,0)) S DIFILEI="_DIFILEI_",DIGBL="""_DIGBL1_""" D WOV^DICQ1" S DIOGBL=DIGBL I ($L(O)+$L(%))<230 D Q . I 'N S DIC("W")=DIC("W")_" "_% Q . S DIC("W",N)=DIC("W",N)_" "_% Q S N=N+1,DIC("W",N)=% I N=1 S DIC("W")=DIC("W")_" X DIC(""W"",1)" Q S DIC("W",N-1)=DIC("W",N-1)_" X DIC(""W"","_N_")" Q ; DICA DICA ;SEA/TOAD-VA FileMan, Updater, Engine ;18APR2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ADD(DIFLAGS,DIFDA,DIEN,DIMSGA) ; ; ADDX ; Branch in from UPDATE^DIE ; ENTRY POINT--add a new entry to a file ; subroutine, DIEN passed by reference I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DICLERR S DICLERR=$G(DIERR) K DIERR INPUT ; ; initialize input parameters & check N DIRULE S DIRULE=$$GETTMP^DIKC1("DICA") N DIFDAO S DIFLAGS=$G(DIFLAGS) I $TR(DIFLAGS,"EKSUY")'="" D Q . D ERR^DICA3(301,"","","",DIFLAGS),CLOSE S DIFDA=$G(DIFDA) I $D(@DIFDA)<10 D Q . D ERR^DICA3(202,"","","","FDA"),CLOSE S DIFDAO=DIFDA S DIEN=$G(DIEN) I DIEN="" S DIEN="DIDUMMY" N DIDUMMY PRE ; N DIOK S DIOK=1 D CHECK^DICA1(DIFLAGS,.DIFDA,DIEN,DIRULE,.DIOK) I $G(DIERR) D CLOSE Q I 'DIOK D ERR^DICA3(202,"","","","FDA"),CLOSE Q SEQ ; N DICHECK,DIENTRY,DIFILE,DIOUT1,DINEXT S (DIOUT1,DINEXT)="" F D Q:DIOUT1 . S DINEXT=$O(@DIRULE@("NEXT",DINEXT)) I DINEXT="" S DIOUT1=1 Q . X @DIRULE@("NEXT",DINEXT) FILES . ; . I $P($G(^DD($$FNO^DILIBF(DIFILE),0,"DI")),U,2)["Y" D Q:DIOUT1 ;Entries in file cannot be edited. . . S DIOUT1=DIFLAGS'["Y"&'$D(DIOVRD) . . I DIOUT1 D ERR^DICA3(405,DIFILE,"","",DIFILE) ENTRIES . ; . N DIDA,DIENP,DIOP,DIROOT,DISEQ . S DIDA=$P(DIENTRY,",") I +DIDA=DIDA Q . S DIENP=$$IEN(DIENTRY,"",DIRULE) . S DIOP=$E(DIDA,1,2) I DIOP'="?+" S DIOP=$E(DIOP) . S DISEQ=$P(DIDA,DIOP,2) FINDING . ; . ; Finding (?) or LAYGO/FInding (?+) nodes . I DIOP["?" D Q . . I DIOP="?+",DIENP[",," S @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT) Q . . N DIFIND,DIFORMAT,DIGET,DIINDEX,DIVALUE . . S DIFORMAT="B"_$S(DIFLAGS["E":"",1:"Q")_$S(DIOP="?+":"X",1:"") . . S DIGET=DIFDA . . I DIFLAGS["E",DIOP["?" S DIGET=DIFDAO . . I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE))#2 D . . . D GETKVALS(.DIVALUE,.DIINDEX) . . E S DIVALUE=$G(@DIGET@(DIFILE,DIENTRY,.01)) . . S DIFIND=$$FIND1^DIC(DIFILE,DIENP,DIFORMAT,.DIVALUE,$G(DIINDEX)) . . I $G(DIERR) S DIOUT1=1 Q . . I DIOP="?+",'DIFIND S @DIRULE@("NEXTADD",DINEXT)=@DIRULE@("NEXT",DINEXT) Q . . I 'DIFIND S DIOUT1=1 D Q . . . I $D(DIVALUE)=10 N I,Q S DIVALUE="",(I,Q)=0 F S I=$O(DIVALUE(I)) Q:'I D Q:Q . . . . Q:DIVALUE(I)="" . . . . S:DIVALUE]"" DIVALUE=DIVALUE_";" . . . . I $L(DIVALUE)+$L(DIVALUE(I))>252 D . . . . . S DIVALUE=$E(DIVALUE,1,252)_$E(DIVALUE(I),1,252-$L(DIVALUE))_"..." . . . . . S Q=1 . . . . E S DIVALUE=$G(DIVALUE)_$E(DIVALUE(I),1,251) . . . D ERR^DICA3(703,DIFILE,DIENTRY,"",DIVALUE) . . S @DIEN@(DISEQ)=DIFIND . . I DIOP="?+" S @DIEN@(DISEQ,0)="?" . . S @DIRULE@("IEN",DISEQ)=DIFIND . . I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE)) D SAVEK Q . . D SAVE . ; Adding (+) nodes . I '$G(DICHECK) S DICHECK=1 D ADDLF S:DIENP[",," DIENP=$$IEN(DIENTRY,"",DIRULE) I $G(DIERR) S DIOUT1=1 Q . D ADDING ; FILER ; file the data for the new records I '$G(DIERR),$D(@DIFDA) D . I '$G(DICHECK) D ADDLF Q:$G(DIERR)!'$D(@DIFDA) ;QUITS HERE WHEN KEY IS BAD! .K ^TMP("DIKK",$J,"L") D FILE^DIEF($E("S",DIFLAGS["S")_"U",DIFDA,"",DIEN) ;GFT Artf8720:recursive UPDATE^DIE call would look at KEY I '$G(DIERR),DIFLAGS'["S" K @DIFDAO I $G(DIERR)!(DIFLAGS["S"),DIFLAGS'["E" D . M @DIFDA=@DIRULE@("SAVE") D CLOSE Q ; ADDING ; N DIENEW,DIKEY I $L(DIENP,",")>2 S DIOK=$$VMINUS9^DIEFU(DIFILE,DIENP) I 'DIOK D Q . S DIOUT1=1 . D ERR^DICA3(602,DIFILE,$P(DIENP,",",$L(DIENP,",")-1)) S DIROOT=$$ROOT^DIQGU(DIFILE,DIENP) D DA^DILF(DIENTRY,.DIENEW) A1 S DIENEW=$$IEN(DIENTRY,$G(@DIEN@(DISEQ)),DIRULE) S DIKEY=$G(@DIFDA@(DIFILE,DIENTRY,.01)) I DIKEY="" D Q . S DIOUT1=1 D ERR^DICA3(202,"","","","FDA") S DIOK=$$LAYGO(DIFILE,.DIENEW,DIKEY) I 'DIOK S DIOUT1=1 D Q . I '$G(DIERR) D ERR^DICA3(405,DIFILE,"","",DIFILE) Q . N DIENS S DIENS="New entry" . I $L(DIENEW,",")>2 S DIENS=DIENS_" under record: "_DIENEW . N DI1 S DI1="LAYGO Node on the new value '"_DIKEY_"'" . D ERR^DICA3(120,DIFILE,DIENS,.01,DI1) D CREATE^DICA3(DIFILE,.DIENEW,DIROOT,DIKEY) ;THIS SHOULD SET DIERR S DIENEW=+DIENEW I 'DIENEW S DIOUT1=1 Q L -@(DIROOT_"DIENEW)") S @DIEN@(DISEQ)=DIENEW ;SET RETURN VALUE I DIOP="?+" S @DIEN@(DISEQ,0)="+" ;SET ZERO NODE IN IEN ARRAY S @DIRULE@("IEN",DISEQ)=DIENEW D SAVE Q ; LAYGO(DIFILE,DIEN,DIKEY) ; ; ADDING--return if LAYGO permitted ; function, all by value N DA,DIOK,DINODE,DIOUTS,X,Y,Y1 S DIOK=1,DINODE="",DIOUTS=0 F D I DIOUTS!'DIOK Q . S DINODE=$O(^DD(DIFILE,.01,"LAYGO",DINODE)) . I DINODE'>0 S DIOUTS=1 Q . I $D(^DD(DIFILE,.01,"LAYGO",DINODE,0))[0 Q . S X=DIKEY M DA=DIEN S Y=$P(DA,","),Y1=DA,DA=$P(DA,",") . I 1 X ^DD(DIFILE,.01,"LAYGO",DINODE,0) S DIOK=$T&'$G(DIERR) Q DIOK ; SAVE I DIFLAGS'["E" D . S @DIRULE@("SAVE",DIFILE,DIENTRY,.01)=@DIFDA@(DIFILE,DIENTRY,.01) K @DIFDA@(DIFILE,DIENTRY,.01) Q ; SAVEK ; Remove primary key field from FDA; save in ^TMP first if necessary N DIFLD S DIFLD=0 F S DIFLD=$O(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)) Q:'DIFLD D . Q:'^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD) . Q:$D(@DIGET@(DIFILE,DIENTRY,DIFLD))[0 . S:DIFLAGS'["E" @DIRULE@("SAVE",DIFILE,DIENTRY,DIFLD)=@DIFDA@(DIFILE,DIENTRY,DIFLD) . K @DIFDA@(DIFILE,DIENTRY,DIFLD) Q ; IEN(DIENTRY,DIENF,DIRULE) ; ; ADDING/FINDING--return translated IEN String ; function, DIENTRY passed by value N DIC,DIENEW,DIOP,DIP,DIPNEW,DISEQ S DIENEW="" S DIENF=$G(DIENF) S DIP="" F DIC=1:1 D I DIP="" Q . S DIP=$P(DIENTRY,",",DIC) I DIP="" Q . D . . I +DIP=DIP S DIPNEW=DIP Q IEN1 . . I DIC=1 S DIPNEW=DIENF Q . . S DIOP=$E(DIP,1,2) I DIOP'="?+" S DIOP=$E(DIOP) . . S DISEQ=$P(DIP,DIOP,2,9999) . . S DIPNEW=$G(@DIRULE@("IEN",DISEQ)) . S $P(DIENEW,",",DIC)=DIPNEW I DIENEW'="" S DIENEW=DIENEW_"," Q DIENEW ; CLOSE I DICLERR'=""!$G(DIERR) D . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA) K @DIRULE,^TMP("DIKK",$J) Q ; GETKVALS(DIVALUE,DIINDEX) ; Get primary key values and uniq index N DIFLD,DIKEY,DISQ K DIVALUE S DIKEY=$P(^TMP("DIKK",$J,"P",DIFILE),U),DIINDEX=$P(^(DIFILE),U,4) Q:DIINDEX=""!'DIKEY ; S DIFLD=0 F S DIFLD=$O(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD)) Q:'DIFLD D . S DISQ=^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD) Q:'DISQ . Q:$D(@DIGET@(DIFILE,DIENTRY,DIFLD))[0 . S DIVALUE(DISQ)=@DIGET@(DIFILE,DIENTRY,DIFLD) Q ; ADDLF ; Check key integrity I $D(^TMP("DIKK",$J,"L")),'$$CHECK^DIEVK(DIFDA,DIFLAGS,DIEN) Q ; ; Add records for LAYGO/Finding nodes which were not found N DINEXT S (DINEXT,DIOUT1)="" F S DINEXT=$O(@DIRULE@("NEXTADD",DINEXT)) Q:DINEXT="" D Q:DIOUT1 . N DIENP,DIFILE,DIENTRY,DIOP,DIROOT,DISEQ . X @DIRULE@("NEXTADD",DINEXT) . S DIENP=$$IEN(DIENTRY,"",DIRULE) . S DIOP="?+" . S DISEQ=$P($P(DIENTRY,","),DIOP,2) . D ADDING Q DICA1 DICA1 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor ;11:57 AM 6 Sep 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CHECK(DIFLAGS,DIFDA,DINUMS,DIRULE,DIOK) ; ; ENTRY POINT--check out the FDA ; subroutine, DIFLAGS passed by value N DIC,DIEN,DIFILE,DIFLD,DIN,DINODE,DINT,DINUM,DIOP N DIOUT1,DIOUT2,DIOUT3,DIRID,DIRIGHT,DISEQ,DITYPE,DIVAL N DIKEYEX FILES ; S DIFILE=0,DIOUT1=0 F D Q:DIOUT1!$G(DIERR) . S DIFILE=$O(@DIFDA@(DIFILE)) . I 'DIFILE S DIOUT1=1 Q . S DINODE=$G(^DD(DIFILE,.01,0)) . I DINODE="" D Q . . D ERR^DICA3($S('$D(^DD(DIFILE)):401,1:406),DIFILE) . I $P(DINODE,U,2)["W" D Q . . D ERR^DICA3(407,DIFILE) . S DIRID=$$RID^DICU(DIFILE) . ; . ;If we're using primary keys for lookup, get key info . S DIKEYEX=$D(^DD("KEY","F",DIFILE)) . I $G(DIFLAGS)["K",DIKEYEX D GETPKEY^DIEVK1(DIFILE) . ; IENS . ; . S DIEN="",DIOUT2=0 F D Q:DIOUT2!$G(DIERR) . . S DIEN=$O(@DIFDA@(DIFILE,DIEN)) . . I DIEN="" S DIOUT2=1 Q . . N DIDA D IEN^DICA2(.DIFILE,DIEN,.DIDA,DIRULE,.DIOK) Q:$G(DIERR) . . I 'DIOK S DIOUT1=1,DIOUT2=1 D Q . . . I $E(DIEN,$L(DIEN))'="," D ERR^DICA3(304,"",DIEN) Q . . . D ERR^DICA3(202,"","","","IENS") . . Q:'$$RID(DIFILE,DIEN,DIFDA,DIRID,DIFLAGS,DIKEYEX) . . I $D(@DIFDA@(DIFILE,DIEN,.001))#2 D . . . N DIENS S DIENS=@DIFDA@(DIFILE,DIEN,.001) . . . I $D(@DINUMS@(@DIRULE@("NUM")))[0 D . . . . S @DINUMS@(@DIRULE@("NUM"))=DIENS . . . S @DIRULE@("SAVE",$J,DIFILE,DIEN,.001)=DIENS . . . K @DIFDA@(DIFILE,DIEN,.001) VALUES . . ; . . I DIFLAGS'["E",$G(DIFLAGS)["U"!'DIKEYEX Q . . S DIFLD="",DIOUT3=0 F D Q:DIOUT3!$G(DIERR) . . . S DIFLD=$O(@DIFDA@(DIFILE,DIEN,DIFLD)) . . . I DIFLD="" S DIOUT3=1 Q . . . I $G(DIFLAGS)'["U",DIKEYEX D BLDFLD^DIEVK1(DIFILE,DIEN,DIFLD) Q:DIFLAGS'["E" . . . I $E(DIEN)="?",$E(DIEN,2)'="+" Q:DIFLD=.01&(DIFLAGS'["K") I DIFLAGS["K",$D(^TMP("DIKK",$J,"P",DIFILE,DIFILE,DIFLD))#2 Q . . . S DIVAL=$G(@DIFDA@(DIFILE,DIEN,DIFLD)) . . . D DTYP^DIOU(DIFILE,DIFLD,.DITYPE) . . . I DITYPE=5 S DINT=DIVAL CONVERT . . . ; . . . I DITYPE'=5 D Q:$G(DIERR) . . . . I DIEN["?"!(DIEN["+") D Q:$G(DIERR) . . . . . I "@"[DIVAL D Q . . . . . . I DIEN["?",$P($G(^DD(DIFILE,DIFLD,0)),U,2)["R" D Q . . . . . . . D ERR712(DIFILE,DIFLD) . . . . . . S DINT=DIVAL . . . . . I DIFLAGS["K",$E(DIEN)'="+",$P($G(^DD(DIFILE,DIFLD,0)),U,5,999)["DINUM",$D(^TMP("DIKK",$J,"P",DIFILE)),$D(^(DIFILE,DIFLD))[0 D Q . . . . . . D ERR^DICA3(520,DIFILE,"",DIFLD,"DINUMed") . . . . . N DA M DA=DIDA . . . . . N DIARG S DIARG="D0" . . . . . N DIMAX S DIMAX=$O(DA(""),-1) . . . . . N DIVAR F DIVAR=1:1:DIMAX S DIARG=DIARG_",D"_DIVAR . . . . . N @DIARG F DIVAR=0:1:DIMAX-1 S @("D"_DIVAR)=DA(DIMAX-DIVAR) . . . . . S:DIMAX @("D"_DIMAX)=DA . . . . . N DIDA D CHK^DIE(DIFILE,DIFLD,"N",DIVAL,.DINT) . . . . E D Q:$G(DIERR) . . . . . N DIVALFLG S DIVALFLG="RU"_$E("Y",DIFLAGS["Y") . . . . . D VAL^DIE(DIFILE,DIEN,DIFLD,DIVALFLG,DIVAL,.DINT) . . . . Q:$D(DINUM)[0 . . . . S @DINUMS@(@DIRULE@("NUM"))=DINUM K DINUM . . . S @DIRULE@("FDA",DIFILE,DIEN,DIFLD)=DINT CLEANUP ; I $G(DIERR)!'DIOK K @DIRULE Q K @DIRULE@("L"),@DIRULE@("NUM"),@DIRULE@("OP"),@DIRULE@("ROOT") K @DIRULE@("SEQ"),@DIRULE@("TEMP"),@DIRULE@("UP") S DIN=$NA(@DIRULE@("ORDER")),DIC=0,@DIRULE@("THE END")="" F S DIN=$Q(@DIN) Q:DIN=""!($P(DIN,",",3)'="""ORDER""") D . S DIC=DIC+1,@DIRULE@("NEXT",DIC)=@DIN K @DIRULE@("ORDER"),@DIRULE@("THE END") I DIFLAGS["E" S DIFDA=$NA(@DIRULE@("FDA")) Q ; RID(DIFILE,DIEN,DIFDA,DIRID,DIFLAGS,DIKEYEX) ; N DIC,DIK,DIOK,DIP,DIR ; ;Check required ids S DIP=$P(DIEN,","),DIOK=1 F DIC=1:1 S DIR=$P(DIRID,U,DIC) Q:DIR="" D . I DIR=.01 D . . I DIP'?1P.E . . E I DIP["+" D:"@"[$G(@DIFDA@(DIFILE,DIEN,.01)) . . . S DIOK=0 D ERR^DICA3(352,DIFILE,DIEN) . . E I DIFLAGS'["K" D:"@"[$G(@DIFDA@(DIFILE,DIEN,.01)) . . . S DIOK=0 D ERR^DICA3(351,DIFILE,DIEN) . E I DIP["+" D:"@"[$G(@DIFDA@(DIFILE,DIEN,DIR)) . . S DIOK=0 D ERR^DICA3(311,DIFILE,DIEN,DIR) . E D:"@"[$G(@DIFDA@(DIFILE,DIEN,DIR),0) . . S DIOK=0 D ERR712(DIFILE,DIR) ; ;Check that the FDA contains the appropriate key fields Q:'$G(DIKEYEX,1) DIOK ; ;If appropriate, ensure all primary and secondary keys are provided I DIFLAGS'["U",DIP["+" D . S DIR=0 F S DIR=$O(^DD("KEY","F",DIFILE,DIR)) Q:'DIR D . . D:"@"[$G(@DIFDA@(DIFILE,DIEN,DIR)) . . . S DIK=0 F S DIK=$O(^DD("KEY","F",DIFILE,DIR,DIK)) Q:'DIK D . . . . S DIOK=0 D ERR744^DIEVK1(DIFILE,DIR,DIK,DIEN) ; ;If appropriate, ensure at least one key field is provided E I $G(DIFLAGS)["K",$E(DIEN)="?",$E(DIEN,2)'="+"!($G(DIFLAGS)["U") D . S:'$$KFLD^DIEVK1(DIFILE,DIEN,DIFDA) DIOK=0 Q DIOK ; ERR712(DIFILE,DIFIELD) ; N DIFILNAM S DIFILNAM=$$FILENAME^DIALOGZ(DIFILE) S:DIFILNAM?." " DIFILNAM="#"_DIFILE ;**CCO/NI N DIFLDNAM S DIFLDNAM=$$FLDNM^DIEFU(DIFILE,DIFIELD) D ERR^DICA3(712,DIFILE,"",DIFIELD,DIFLDNAM,DIFILNAM) Q DICA2 DICA2 ;SEA/TOAD-VA FileMan: Updater, Pre-Processor Part 2 ;8:12 AM 10 Jun 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; IEN(DIFILE,DIEN,DIDA,DIRULE,DIOK) ; ; ENTRY POINT--return whether the IEN String is valid ; proc, DIEN passed by value I $G(DIFILE("C"))'=DIFILE D PARENTS^DIDU1(.DIFILE,DIRULE) I $E(DIEN,$L(DIEN))'="," D ERR^DICA3(304,"",DIEN) Q I DIFILE("L")+1'=$L(DIEN,",") D ERR^DICA3(205,"",DIEN,"",DIFILE) Q I $E(DIEN)=","!(DIEN[",,") D ERR^DICA3(307,"",DIEN) Q K @DIRULE@("TEMP") PIECES ; K DIDA N DICRSR,DIOUT S DIOUT=0 F DICRSR=1:1 D Q:DIOUT!$G(DIERR) . N DIPIECE S DIPIECE=$P(DIEN,",",DICRSR) . N DIRIGHT S DIRIGHT=$P(DIEN,",",DICRSR+1,99999) . I DIPIECE="" S DIOUT=1,DIOK=1 Q . D PIECE(.DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,.DIDA,DIRIGHT,.DIOK) . I $G(DIERR) S DIOK=0 Q . I 'DIOK D ERR^DICA3($S(DIOK=0:308,1:310),"",DIEN) Q . Q I $G(DIERR) Q ALLGOOD ; M @DIRULE@("SEQ")=@DIRULE@("TEMP") N DIN S DIN="S DIFILE="_DIFILE_",DIENTRY="""_DIEN_"""" S @DIRULE@("ORDER",@DIRULE@("OP"),DIFILE("L"),DIFILE,@DIRULE@("NUM"))=DIN Q ; PIECE(DIFILE,DIFDA,DIRULE,DICRSR,DIPIECE,DIDA,DIRIGHT,DIOK) ; ; IEN--return whether a piece of the IEN String is valid ; proc, DIF, DIOK, & DIRULE passed by ref N DICHECK,DIF,DIPREFIX,DIR,DISEQ S DIF=DIFILE(DICRSR) I DIPIECE'["+",DIRIGHT["+" S DIOK=0 Q FILING I +DIPIECE=DIPIECE,$E(DIPIECE)'="+" D Q . S DIOK=DIPIECE>0 I 'DIOK Q . S DIOK=DIRIGHT'["+"&(DIRIGHT'["?") I 'DIOK Q . S DIR=$G(@DIRULE@("ROOT",DIF,","_DIRIGHT)) . I DIR="" D . . S DIR=$$ROOT^DIQGU(DIF,","_DIRIGHT,1,1) . . S @DIRULE@("ROOT",DIF,","_DIRIGHT)=DIR . S DIOK=$P($G(@DIR@(DIPIECE,0)),U)'="" . I 'DIOK D ERR^DICA3(601,DIFILE,DIPIECE_","_DIRIGHT) Q . I DICRSR=1 S DIDA=DIPIECE . E S DIDA(DICRSR-1)=DIPIECE . I DICRSR'=1 Q . S @DIRULE@("OP")=4 . S @DIRULE@("NUM")=DIPIECE PREFIX S DIPREFIX=$E(DIPIECE,1,2) I DIPREFIX'="?+" S DIPREFIX=$E(DIPREFIX) I DIPREFIX'="+",DIPREFIX'="?",DIPREFIX'="?+" S DIOK=0 Q ; GOODPC I $P(DIPIECE,DIPREFIX,2,9999)?1N.N S DIOK=1 D Q . S DISEQ=$P(DIPIECE,DIPREFIX,2,999) . I +DISEQ'=DISEQ S DIOK=0 Q FIRSTPC . I DICRSR=1 D . . S @DIRULE@("OP")=$S(DIPREFIX="?":1,DIPREFIX="?+":2,1:3) . . S @DIRULE@("NUM")=DISEQ WHEREPC . S DICHECK="" . I $D(@DIRULE@("SEQ",DISEQ)) S DICHECK=$NA(@DIRULE@("SEQ")) . E I $D(@DIRULE@("TEMP",DISEQ)) S DICHECK=$NA(@DIRULE@("TEMP")) ILLEGAL . I DICHECK'="" D I 'DIOK Q . . I $O(@DICHECK@(DISEQ,""))'=DIPREFIX S DIOK="C" Q . . I $O(@DICHECK@(DISEQ,DIPREFIX,""))'=DIF S DIOK="C" Q . . I $G(@DICHECK@(DISEQ,DIPREFIX,DIF))'=DIRIGHT S DIOK="C" Q . I DICHECK="",'$D(@DIFDA@(DIF,DIPIECE_","_DIRIGHT)) S DIOK="C" Q LEARN . S @DIRULE@("TEMP",DISEQ,DIPREFIX,DIF)=DIRIGHT . I DICRSR=1 S DIDA=DIPREFIX . E S DIDA(DICRSR-1)=DIPREFIX ; BADPIEC S DIOK=0 Q DICA3 DICA3 ;SEA/TOAD-VA FileMan: Updater, Adder ;16FEB2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CREATE(DIFILE,DIEN,DIROOT,DIVALUE) ;If DIEN comes in with a leading number, use it as IEN N DIENP S DIENP=","_$P(DIEN,",",2,999) S DIEN=$P(DIEN,",") N DINEXT S DINEXT=$P($G(@(DIROOT_"0)")),U,3) I DINEXT="" D I $G(DIERR) S DIEN="" Q . N DIHEADER S DIHEADER=$$HEADER^DIDU2(.DIFILE,DIENP) . I '$G(DIERR) S @(DIROOT_"0)")=DIHEADER GETNUM ; N DINUM,DIFAUD S DINUM=DIEN'="",DIFAUD=0 I 'DINUM S DIEN=DINEXT\1 I $D(^DIA(DIFILE,"B")) S DIFAUD=DIFILE N DIFAIL,DIOUT S DIFAIL=0,DIOUT=0 F D I DIOUT!DIFAIL Q . I 'DINUM S DIEN=DIEN+1 I $D(@(DIROOT_"DIEN)")) Q ;**GFT LOOK BEFORE LOCKING . I DIFAUD,+$O(^DIA(DIFAUD,"B",DIEN_","))=DIEN!$D(^(DIEN)) Q ;**GFT DON'T PICK AN ALREADY-AUDITED NUMBER . I DIEN'>0 D ERR(202,DIFILE,DIEN,.01,"ASSIGNED IEN") S DIFAIL=1 Q ;ARTF10963 -- "The input parameter that identifies the ASSIGNED IEN is missing or invalid." . D LOCK^DILF(DIROOT_"DIEN)") ;**147 . I '$T S DIFAIL=DINUM Q:'DIFAIL D ERR(110,DIFILE,DIEN_DIENP) Q ;RECORD IS LOCKED ZERO . I $D(@(DIROOT_"DIEN,0)")) L -@(DIROOT_"DIEN)") D Q . . S DIFAIL=DINUM I 'DIFAIL Q ;COULDN'T DO DINUM! . . D ERR(302,DIFILE,DIEN_DIENP) ;ENTRY ALREADY EXISTS . S DIOUT=1 I DIFAIL S DIEN="" Q SETREC ; N DICAFILE M DICAFILE=DIFILE N DIFILE S @(DIROOT_"DIEN,0)")=DIVALUE D LOCK^DILF(DIROOT_"0)") ;**147 S $P(^(0),U,3,4)=DIEN_U_($P(@(DIROOT_"0)"),U,4)+1) I L -@(DIROOT_"0)") S DIEN=DIEN_DIENP D XA^DIEFU(DICAFILE,DIEN,.01,DIVALUE,"") D INDEX^DIKC(DICAFILE,DIEN,.01,"","SC") Q ; PROOT(DIFILE,DIEN) ; ; ENTRY POINT--return the global root of a subfile's parent ; extrinsic function, all passed by value N DIENP S DIENP=$P(DIEN,",",2,999) Q $NA(@$$ROOT^DILFD($$PARENT(DIFILE),DIENP,1)@(+DIENP)) ; PARENT(DIFILE) ; ; ENTRY POINT--return the file number of a subfile's parent ; extrinsic function, all passed by value Q $G(^DD(DIFILE,0,"UP")) ; SUBFILE(DIFILE) ; ; ENTRY POINT--return whether the file is a subfile ; extrinsic function, passed by value Q $D(^DD(DIFILE,0,"UP"))#2 ; ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ; ; error logging procedure N DIPE N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI)) D BLD^DIALOG(DIERN,.DIPE,.DIPE) Q DICATT DICATT ;SFISC/GFT,XAK-MODIFY FILE ATTR ;25MAY2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. I $D(DIAX) S %=2 E S %=$$SCREEN^DIBT("^D SCREENQ^DICATT") Q:%=U S %=2-% G ^DICATTD:%=1 Q:%<2 ;JUMP TO THE SCREENMAN EDITOR S DLAYGO=1 D D^DICRW Q:Y<0 I $P($G(^DD(+Y,0,"DI")),U)["Y",($P(@(^DIC(+Y,0,"GL")_"0)"),U,4)) W !!,$C(7),"DATA DICTIONARY MODIFICATIONS ON ARCHIVE FILES ARE NOT ALLOWED!" Q I '$D(DIC) D DIE^DIB Q:'$D(DG) S DIC=DG S:$D(DIAX) DIAXDIC=+$P(@(DIC_"0)"),U,2) EN ; K I S Q="""",I(0)=DIC,B=+$P(@(DIC_"0)"),U,2),S=";" B ; K DA,J,DIU0,DDA S A=B,DICL=0,J(0)=B,DDA="" M ; I $G(Z)["W",A-B G B W !!! K O,DQ,DIC,DIE,DG,M G Q^DIB:$D(DTOUT) S O=1,E=0,DIC(0)="ALEQIZ",DIC="^DD("_A_"," S:$D(DICS) DIC("S")=DICS S DIC("W")="S %=$P(^(0),U,2) I % W $P("" (multiple)^ (word-processing)"",U,$P(^DD(+%,.01,0),U,2)[""W""+1)" I $P(^DD(A,.01,0),U,2)["W" S DIC(0)="AEQZ",DIC("B")=.01 E I $D(DA),$D(^DD(A,DA,0)),'$P(^(0),U,2),$P(^(0),U,4)'?.P S E=DA D ^DIC S:$P(Y,U,3) DDA="N" I Y<0 G B:A-B,Q^DICATT2 ;IF NO FIELD IS CHOSEN, POP UP. IF AT TOP LEVEL OF FILE, QUIT OUT SV I '$P(Y,U,3) S DIU0=A,O(1)=$P(^DD(A,+Y,0),U,1,2),O(2)=$S($D(^(.1)):$P(^(.1),U),1:""),DDA="E" D SV^DICATTA S DDA(1)=A S DIAC="AUDIT",DIFILE=A D ^DIAC S O=+% K DIAC,DIFILE SKP S (D0,DA)=+Y,DA(1)=A,DIE=DIC,M=Y(0),T=$P(M,U,2) S:T["C"!(T["W") O=0 S DR=$P(".01:.1;",U,DUZ(0)="@"!'$F(T,"X"))_$P("1.1;",U,T'["C")_$S(DUZ(0)="@"&(T'["C"):"1.2;",1:"")_$S(T["C":"8;",1:"8:9;10:")_"11;20:29" S O=$S($P(Y,U,3):0,1:1_U_$P(M,U,2,99)),F=$P(M,U) K DIC,DQI S X=0 F S X=$O(^DD(A,DA,1,X)) Q:X'>0 I +^(X,0)=B,$P(^(0),B,2)?1"^"1.A S DQI=$P(^(0),U,2) G MULTIPLE:T I O D Q:$D(DTOUT) I '$D(DA) G N:$P(O,U,4)?.P,^DICATT4 ;IF DELETING THE FIELD, CLEANUP IN 'DICATT4' UNLESS IT WAS A COMPUTED FIELD .N DICASPEC S DICASPEC=$P(^DD(A,DA,0),U,2) .D DIE ;EDIT THE CHARACTERISTICS OF A SINGLE-VALUED FIELD .I '$D(DA) S DDA="D" Q .I DICASPEC'=$P(^DD(A,DA,0),U,2),$G(^DD(B,0,"DIK"))]"" D ..N A D EN2^DIKZ(B,"",^("DIK")) ;Recompile CROSS-REFS if auditing changes G TYPE^DICATT2 ; MULTIPLE ;EDIT THE CHARACTERISTICS OF A MULTIPLE FIELD S DR=".01;8;9;10:11;20:29" D DIE I '$D(DA) S DDA="D" S DQ(+T)=0 G NEW^DICATT4 S X=$P($P(M,U,4),";"),M=^DD(A,DA,0),E=$P(M,U),A=+T,DICL=DICL+1,J(DICL)=A,Y=$E(Q,+X'=X),I(DICL)=Y_X_Y I E'=F S ^(0)=E_" SUB-FIELD^"_$P(^DD(A,0),U,2,9) K ^(0,"NM") S ^("NM",E)="" G 5:$P(M,U,2)["W",N ;NOW WE ARE DOWN TO LOWER-LEVEL MULTIPLE ; ; E S DE=^DD(A,E,0) W $P(DE,U) Q ; P S DI=DIU0 D:$D(O(1)) .I '$D(DA) S DA=D0 D DIPZ^DIU0 Q .I $D(^DD(DI,DA,0)),O(1)'=$P(^(0),U,1,2) D DIPZ^DIU0 Q .I $D(^(.1)),O(2)'=$P(^(.1),U) D DIPZ^DIU0 Q K DIU0 Q ; N D:DDA]"" AUDIT^DICATT22(DDA(1),D0,DDA) ;FINISH THIS FIELD, GO BACK TO RE-ASK ANOTHER FIELD D:$D(DIU0) P S DIZZ=$S(('O&$D(DIZ)):DIZ,1:$P(O,U,2,3)) G M ; X W $C(7)," '",F,"' DELETED!" S DDA=$S(DDA="":"D",1:"") S DIK="^DD(A,",DA(1)=A D ^DIK G N ; CHECK G:$P(^DD(A,DA,0),U,2)']"" X:$D(DTOUT) G NO^DICATT2 ; DIE ; N I,J,DICATTED,A,B S DICATTED=1 D ^DIE ;'DA' VARIABLE IS KILLED IF USER KILLS THE FIELD BY DELETING THE LABEL Q ; ; ; 0 S C=$P(O,U,5,99) G @N ;COME HERE FROM 2 PLACES IN DICATT2. GO DEPENDS ON DATA TYPE (1-9) 1 ; 2 G ^DICATT0 3 ; 4 G ^DICATT6 5 S W="0;1",(Z,DIZ)="W^",C="Q",V=1,L=1 G ^DICATT2:O,SUB^DICATT1 6 G ^DICATT3 ;COMPUTED 7 G ^DICATT5 8 G VP^DICATT4 9 S (Z,DIZ)="K^",V=0,C="K:$L(X)>245 X D:$D(X) ^DIM",L=245 S:$P(^DD(A,DA,0),U,4)]"" W=$P(^(0),U,4) G ^DICATT2:O,SUB^DICATT1 ; SCREENQ ; W !,"'YES' will invoke the ScreenMan editor.",!,"The same questions are asked in both screen & scrolling mode." DICATT0 DICATT0 ;SFISC/GFT,XAK-DATES, NUMERIC ;1/7/2009 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 17 ;Per VHA Directive 2004-038, this routine should not be modified. G @N ; DIE K Y S DP=0 F S DL=1,DP=$O(DQ(DP)) Q:DP="" S:$D(DE(DP)) DG(DP)=DE(DP) S DP=-1 D DQ^DIED K DQ,DICATTZ G CHECK^DICATT:$D(Y)!$D(DTOUT),@(N_0) ; 1 S %DT="E",DQ="^I X'?1""DT"".NP D ^%DT S X=Y K:Y<0 X",DQ(1)="EARLIEST DATE (OPTIONAL)^D^^1"_DQ,DQ(0,2)="S:'$L(X) Y=""CAN""",DQ(3)="LATEST DATE^RD^^3"_DQ_" I $D(X),XX",1),DE(3)=$P($P(C,"K:",2),P,1) S DQ(4)="CAN DATE BE IMPRECISE (Y/N)^S^Y:YES;N:NO;^4^Q",DE(4)=$E("YN",$P(C,Q,2)["X"+1),DQ(4,3)="E.G., WOULD 'FEB, 1980' BE ALLOWED?" S DQ(5)="CAN TIME OF DAY BE ENTERED (Y/N)^S^Y:YES;N:NO;^5^S:X=""N"" (DG(7),DG(6))=X K:X=""N"" DQ(6)" S DQ(6)="CAN SECONDS BE ENTERED (Y/N)^S^Y:YES;N:NO;^6^S DG(6)=X",DE(6)=$E("NY",$P(C,Q,2)["S"+1) S DE(5)=$E("NY",$P(C,Q,2)["T"+1),DQ(5,3)="CAN USER ENTER TIME ALONG WITH DATE, AS IN 'JULY 20@4:30'?" S DQ(7)="IS TIME REQUIRED (Y/N)^S^Y:YES;N:NO;^7^Q",DQ(7,3)="MUST USER ENTER TIME ALONG WITH DATE",DQ(0,6)="I X=""N"" S Y=U,DQ=DQ+1",DE(7)=$E("NY",$P(C,Q,2)["R"+1) S DICATTZ=1 G DIE ; 10 S C="S %DT=""E"_$E("S",DG(6)="Y")_$E("T",DG(5)="Y")_$E("X",DG(4)="N")_$E("R",DG(7)="Y")_""" D ^%DT S X=Y K:" F X=1,3 G ND:'$D(DG(X)) S Y(X)=$S(DG(X):DG(X)\10000+1700,1:DG(X)) I DG(X)#100 S Y(X)=DG(X)#100_"/"_Y(X) I $E(DG(X),4,5) S Y(X)=+$E(DG(X),4,5)_"/"_Y(X) I DG(1)]"" S M="Type a date between "_Y(1)_" and "_Y(3)_".",C=C_DG(3)_P_DG(1)_">X) X" G ED ND S C=C_"Y<1 X" ED S Z="D^",L=DG(5)="Y"*5+7,DG(6)="" G H ; 2 K DG S DQ("A1")="!(X'["".""&($L(X)>15))!(X["".""&($L($P(+X,"".""))+$L($P(+X,""."",2))>15)) X" S DQ(1)="INCLUSIVE LOWER BOUND^R^^1^K:+X'=X"_DQ("A1"),DQ(2)="INCLUSIVE UPPER BOUND^R^^2^K:X",2) G DIE 20 I DG(1)>DG(2) W $C(7),"??" G 2 S M="Type a "_$P("number^dollar amount",U,DG(3)="Y"+1)_" between "_DG(1)_" and "_DG(2)_", "_DG(5)_" decimal digit"_$E("s",DG(5)'=1)_"." S C="K:+X'=X",T=DG(5)+1,Z="!(X?.E"_P_T_"N.N)" I DG(3)="Y",DA-.001 S C="S:X[""$"" X=$P(X,""$"",2) K:X'?"_$P(".""-""",U,DG(1)<0)_".N."_P_".2N",Z="" S C=C_"!(X>"_DG(2)_")!(X<"_DG(1)_")"_Z_" X",L=$L(DG(2)\1)+T-(T=1),Z="NJ"_L_","_DG(5)_U H S DIZ=Z G ^DICATT1 DICATT1 DICATT1 ;SFISC/GFT,XAK-NODE AND PIECE, SUBFILE ;21APR2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; I DA=.001 S W=" " G 2 S (DG,W)=$P(O,U,4) G M:W="" S T=0,DP=DA,Y=$P(W,";"),N=$P(W,";",2) D MX S L=L-T D MAX I T+3<$G(^DD("STRING_LIMIT"),255) S W=DG G ^DICATT2 D TOO G NO^DICATT2 M K DE,DG W !,"WILL "_F_" FIELD BE MULTIPLE" S %=2 D YN^DICN I % S V=%=1 G BACK:%<0,SUB W !,"FOR A GIVEN ENTRY, WILL THERE BE MORE THAN 1 "_F,!," ON FILE AT ONCE?" G M E ; S V=0,DE(3)=$S($D(^(3)):^(3),1:""),T=0,DP=E,N=$P($P(DE,U,4),";",2) D MX S L=T SUB S:$P(DIZ,"^")["K" V=1 S T=0 F Y=0:1 Q:'$D(^DD(A,"GL",Y+1)) D MAX:'V I T>245!$D(^DD(A,"GL",Y,0))!V S Y=$S(+Y=Y:Y+1,1:$C($A(Y)+1)) G SB:DUZ(0)'="@" W !!,"SUBSCRIPT: ",Y,"// " R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=Y I X'?.ANP W !?5,$C(7),"Control Characters are not allowed." G SUB I +X'=X G BACK:X[U,DICATT1^DIQQQ:X["?" I X?1P.E!(X[",")!(X[":")!(X[S)!(X[Q)!(X["=") G SUB I Y'=X S Y=X D MAX I T+5>$G(^DD("STRING_LIMIT"),255) D TOO G SUB SB S W=Y,X=0 G V:V,U:$D(^DD(A,"GL",W,0)) PIECE S Y=1,P=0 PC S X=$O(^DD(A,"GL",W,X)) I X'="" S P=$P(X,",",2),Y=$S(Y>P:Y,1:P+1) G PC S X=-1 I P S Y="E"_Y_","_(L+Y-1) E F Y=1:1 Q:'$D(^(Y)) S P=Y I DUZ(0)="@" W !,"^-PIECE POSITION: ",Y,"// " R P:DTIME S:'$T DTOUT=1 G CHECK^DICATT:$D(DTOUT) S:P="" P=Y G PQ:P["?" I P?1"E"1N.N1","1N.N S N=$P(P,",",2)-$E(P,2,9)+1 G USED:N'0,P<100,P\1=P G USED S W="" I X'[U W $C(7),"??" G SUB BACK G CHECK^DICATT:$D(DTOUT),TYPE^DICATT2 ; PQ W " TYPE A NUMBER FROM 1 TO 99" I Y=1 W !?9,"OR AN $EXTRACT RANGE (E.G., ""E2,4"")" E W !?15,"CURRENTLY ASSIGNED:",! S Y="" F P=0:0 S Y=$O(^DD(A,"GL",W,Y)) Q:Y="" S P=$O(^(Y,0)) I $D(^DD(A,P,0)) W ?11,$S(Y:"PIECE ",1:"")_Y,?22,"FIELD #"_P_", '"_$P(^(0),U,1)_"'",! G PIECE ; USED S W=W_S_P,X=P G DE:'$D(^(X)) U W !,$C(7),X_" ALREADY USED FOR "_$P(^DD(A,$O(^(X,0)),0),U,1) G SUB ; MAX S N=0 F T=L:0 S N=$O(^DD(A,"GL",Y,N)) Q:N="" S DP=$O(^(N,0)) D MX S N=-1 Q MX I N?1"E".E S T=T+$P(N,",",2)-$E(N,2,9)+1 Q:'N S P=$P(^DD(A,DP,0),U,2),W=$S(P["J":$P(P,"J",2),P["P":9,P["N":14,P["D":7,1:0) G W:W I P["S" F P=1:1 S X=$L($P($P($P(^(0),U,3),";",P),":",1)) S:X>W W=X G W:'X S W=$P(^(0),"$L(X)>",2),W='W*30+W W S T=T+W+1 Q ; V I $D(^DD(A,"GL",W)) W $C(7),!?9,"CAN'T STORE A "_$S($P(DIZ,U)["K":"MUMPS",1:"MULTIPLE")_" FIELD IN AN ALREADY-USED SUBSCRIPT!" G SUB I $P(Z,U)'["K" S W=W_S_0 S:$P(DIZ,U)["K" W=$P(W,";")_";E1,245" DE I $D(DE) S ^DD(A,DA,0)=F_U_$P(DE,U,2,3)_U_W_U_$P(DE,U,5,99),DIK="^DD(A,",DA(1)=A,^(3)=DE(3),^("DT")=DT D IX1^DIK G N^DICATT 2 S:$P(Z,U)["K" V=0,W=W_";E1,245",M="This is Standard MUMPS code." G ^DICATT2 ; TOO W $C(7),!," TOO MUCH TO STORE AT THAT SUBSCRIPT!" DICATT2 DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;4APR2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; S T=$E(Z) G CHECK^DICATT:$D(DTOUT) F P="I","O","L","x" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2) 1 K DS S:$P(Z,U)'["K" V=W[";0" S P=0,N=DICL,DQ=4,DP=6,DQI=" S:$D(X) DINUM=+X",DREF=$F(O,DQI)-1=$L(O),DE(7,0)="NO",DG(7)="N" S:T="*" T=$S($P(Z,U)["S":"S",1:"P") G 1^DICATT22:DA=.001 G W:T="W" S:$D(DTIME)[0 DTIME=300 I T'["F",T'["S",T'["K",'O!DREF S:DREF DE(7,0)="YES",DG(7)="Y" S F Y=4:1:6 S DQ(Y)=$P($T(DQ+Y),";",3)_F_$P($T(DQ+Y),";",4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q" I 'V,DA-.01!'N Q S DG(5)="Y",DE(4,0)="NO",DP=-1,DL=1 I T["P"!(T["N") S DE(5,0)="YES" I O S DE(6,0)=$E("NY",$P(O,U,2)["M"+1) S:$P(O,U,2)["R" DE(4,0)="Y" I DA=.01,N S P=$O(^DD(J(N-1),"SB",A,0)) S:P="" P=-1 S Y=$P(^DD(J(N-1),P,0),U,2),DE(5,0)=$E("YN",Y["A"+1) K Y S DIFLD=-1 D RE^DIED K DQ,DIFLD G:$D(Y) N^DICATT:$P(Z,U)["X",CHECK^DICATT I $D(DTOUT) K DTOUT G CHECK^DICATT S:DG(5)="N" T=T_"A" I DG(4)="Y",$P(Z,U)'["R" S Z="R"_Z I $D(DG(6)),DG(6)="Y",$P(Z,U)'["M" S Z="M"_Z G S DIZ=Z G ^DICATT22 Q ; K T,B,A,J,DA,DIC,E,DR,W,S,Q,P,N,V,I,L,F,DQI,DIK,C,Z,Y,DE,O,DICS,DICL,DDA Q ; W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"L"),U)_$E("L",%=2)_U G WINDOW W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT" W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES." W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT" W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W ; ; WINDOW S %=2-(Z["x"!'O) W !,"SHALL ""|"" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS" D YN^DICN G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"x"),U)_$E("x",%=1)_U G G W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT MAY HAVE ""|"" CHARACTERS" W !?3,"IN IT (SUCH AS HL7 MESSAGES) THAT NEED TO DISPLAY EXACTLY AS THEY ARE STORED." W !,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT WITH ANYTHING" W !?3,"THAT IS DELIMITED BY ""|"" CHARACTERS INTERPRETED AS VARIABLE TEXT.",! G WINDOW ; ; ; X ; W " (FIELD DEFINITION IS NOT EDITABLE)" I N=4 K DIRUT D LENGTH(A,DA) I $D(DIRUT) K DIRUT G N^DICATT S T=$E(^DOPT("DICATT",N,0)),Y=^DD(A,DA,0),Z=$TR($P(Y,U,2),"MR")_U_$P(Y,U,3),W=$P(Y,U,4),C=$P(Y,U,5,99) S:Z["K" V=0 G N^DICATT:N=6,1 ; LENGTH(DI,DIFIELD) ; N DIR,DICY,Y,X,A0,B0,A1,A2 S DICY=$G(^DD(DI,DIFIELD,0)) I $P(DICY,U,2)'["F" Q S A0=250,A1=$P($P($P(DICY,U,4),";",2),"E",2) I A1 S A2=$P(A1,",",2) I A2 S A0=A2-A1+1,DIR("?",1)="Data is stored by '$E"_A1_"'" S DIR("A")="MAXIMUM LENGTH OF '"_$P(DICY,U)_"'",DIR(0)="N^1:"_A0,DIR("B")=$$FL^DIQGDDU(DI,DIFIELD) S DIR("?")="THIS MAXIMUM WILL BE USED FOR OUTPUT PURPOSES, BUT WILL NOT BE PART OF THE INPUT CHECK FOR THE FIELD" D ^DIR Q:'Y N F S X=$P(DICY,U,2),F=$F(X,"J") I F Q:+$E(X,F,99)=Y F Q:$E(X,F)'?1N S X=$E(X,1,F-1)_$E(X,F+1,99) S X=$TR(X,"J")_"J"_Y,$P(^DD(DI,DIFIELD,0),U,2)=X I $D(DDA) S DDA="E",A0="LENGTH^.23",A1=DIR("B"),A2=Y D IT^DICATTA Q ; NO ; W !,$C(7)," " I $P(Z,U)["K"&(DUZ(0)'="@") G N^DICATT TYPE K Y,M,DE,DIE,DQ,DG G Q^DIB:$D(DTOUT) S N=0,DQI=DICL+9,Y=^DD(A,DA,0),F=$P(Y,U),Z="" W !!,"DATA TYPE OF ",F,": " I 'O R X:DTIME S:'$T DTOUT=1 G X^DICATT:X[U!'$T S:DUZ(0)'="@" DIC("S")="I Y-9" S:DA=.001 DIC("S")="I Y<4!(Y=7)" G NEW F N=9:-1:5,1:1:4 Q:$P(Y,U,2)[$E("DNSFWCPVK",N) W $P(^DOPT("DICATT",N,0),U) G X:$P(Y,U,2)["K"&(DUZ(0)'="@") G X:$P(Y,U,2)["X",6^DICATT:N=6 R "// ",X:DTIME S:'$T DTOUT=1 G N^DICATT:X[U!'$T,0^DICATT:X="" S DIC("S")="I Y-6,Y-9"_$P(",Y-5",U,N\2-2!(A=B)!(DA-.01)!$O(^DD(A,DA))>0),DIC("S")=DIC("S")_$S(N=7:",Y-8",N=8:",Y-7",1:"") NEW I 'O,X=" ",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" W " <",$C(7) D E^DICATT W " DUPLICATED>" S DIZ=$S($D(DIZ):DIZ,1:DIZZ) G E^DICATT1 S DIC(0)="QEI",DIC="^DOPT(""DICATT""," D ^DIC I Y>0 S:N-Y&O M="",O=$P(O,U,1,2)_U_U_$P(O,U,4) S N=+Y G 0^DICATT I 'O,X["?",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" D DICATT^DIQQQ,E^DICATT W ", JUST HIT THE SPACE KEY" G TYPE ; DQ ;; ; ; ; ;;IS ; ENTRY MANDATORY ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER DICATT22 DICATT22 ;SFISC/GFT-CREATE A SUBFILE ;28MAY2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; G M:V I P,$D(^DD(J(N-1),P,0)) S I=A_$E("I",$P(^(0),U,2)["I") D P I O,DA=.01,'N S I=$P(@(I(0)_"0)"),U,2) D P 1 ; S %=$L(F)+$L(W)+$L(C)+$L(Z) I %>242 W $C(7),!?5,"Field Definition is TOO LONG by ",%-242," characters!" G TYPE^DICATT2 I T["P",$D(O)=11,+$P($P(O(1),U,2),"P",2)'=+$P(Z,"P",2) S X=$P(O(1),U,2),DA(1)=A X:$D(^DD(0,.2,1,3,2)) ^(2) S ^DD(A,DA,0)=F_U_Z_U_W_U_C S:$P(Z,U)["K" ^(9)="@" D SDIK,I G N^DICATT ; Q W $C(7),!,"NUMBER MUST BE BETWEEN ",A," & ",%+1," AND NOT ALREADY IN USE" M S %=$P(A,"."),DE=%_"."_+$P(A,".",2)_DA I +DE'=DE!$D(^DD(DE)) F DE=A+.01:.01:%+.7,%+.7:.001:%+.9,%+.9:.0001 Q:DE>A&'$D(^DD(DE)) I DUZ(0)="@" W !,"SUB-DICTIONARY NUMBER: "_DE_"// " R DG:DTIME S:'$T DTOUT=1 G:DG=U!'$T ^DICATT2 S:DG]"" DE=DG G Q:+DE'=DE!(DEDE!$D(^DD(DE)) S I=DE,^(I,0)=F_" SUB-FIELD^^.01^1",^(0,"UP")=A,^("NM",F)="",%X="^DD("_A_","_DA_")",@%X@(0)=F_"^^^"_W D P S W=$P(W,";") D SDIK S:+W'=W W=""""_W_"""" S DICATT22=DA,(N,DICL)=N+1,I(N)=W,J(N)=DE,DA=.01,^DD(DE,DA,0)=F_U_Z_"^0;1^"_C,%Y="^DD("_DE_",.01)" VARPOINT I T["V" D . N I,FI,FD,P . S FI=$QS(%X,1),FD=$QS(%X,2) . S I=0 . F S I=$O(@%X@("V",I)) Q:'I S P=+$G(^(I,0)) K:P ^DD(P,0,"PT",FI,FD) . M @%Y@("V")=@%X@("V") K @%X@("V") POINT I T["P" F %=12,12.1 I $D(@%X@(%)) S @%Y@(%)=@%X@(%) K @%X@(%) K %X,%Y I T'["W" D .S ^DD(DE,DA,1,0)="^.1",^(1,0)=DE_"^B",DIK=W_",""B"",$E(X,1,30),DA)" .F %=DICL-1:-1 S DIK=I(%)_$E(",",1,%)_"DA("_(DICL-%)_"),"_DIK I '% S ^(1)="S "_DIK_"=""""",^(2)="K "_DIK S:T["V" ^(3)="Required Index for Variable Pointer" Q D SDIK,I S DICL=DICL-1 D AUDIT(DA(1),.01,"N") S DA=DICATT22 K DICATT22 ;AUDIT THE NEW .01 FIELD AT THE LOWER LEVEL G N^DICATT ; AUDIT(DIFILE,DIFIELD,DITYPE) ; N DDA,DA,B0,A0 S DDA(1)=DIFILE,DA=DIFIELD,DDA=$G(DITYPE,"E") D AUDT^DICATTA Q ; ; ; I I $P(O,U,2,99)'=$P(^DD(J(N),DA,0),U,2,99) S:$D(M)#2 ^(3)=M S M(1)=0 K DR,DG,DB,DQ,DQI,^DD(U,$J),^UTILITY("DIVR",$J) EGP ;K ^DD(DA(1),DA,.009) ; GET RID OF FOREIGN-LANGUAGE HELP MESSAGE WHEN THE BASIC ENGLISH ONE IS BEING RE-EDITED?? S DIE=DIK,DR=$S(DUZ(0)="@":"3;4",1:3)_$P(";21",U,'O) D I T="W" K DE .N I,J,T .D ^DIE I $D(M)>9,O S V=DICL,DR=$P(Z,U),Z=$P(Z,U,2) D ;It's not clear that we need these variables set, now we are calling DIVR^DIUTL 12/01 V .N D0 S DI=J(N) D DIPZ^DIU0 Q:$D(DTOUT)!'$D(DIZ) ;NEEDS 'DI' & 'DA' .D DIVR^DIUTL(A,DA) K DR,M Q ; ; P F Y="S","D","P","A","V" S:I[Y I=$P(I,Y)_$P(I,Y,2)_$P(I,Y,3) S:T[Y I=I_Y S ^(0)=$P(^(0),U)_U_I_U_$P(^(0),U,3,99) Q ; SDIK N %X S DA(1)=J(DICL),DIK="^DD("_DA(1)_"," I O K ^DD(DA(1),"RQ",DA) W !,"...." G IX1^DIK DICATT3 DICATT3 ;SFISC/COMPUTED FIELDS ;6MAY2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; K DIRUT,DTOUT D COMP I $P(^DD(A,DA,0),U,2)["C" G N^DICATT S DTOUT=1 G CHECK^DICATT ; COMP N DIR,DICOMPX,DISPEC,DICMIN,DIL,DIJ,DIE,DIDEC S DISPEC=$P($G(^DD(A,DA,0)),U,2) S DIR(0)="FU",DIR("A")="'COMPUTED-FIELD' EXPRESSION" I O,$D(^DD(A,DA,9.1)) S DIR("B")=^(9.1) S DIR("?")="^D DICATT3^DIQQ" D ^DIR Q:$D(DIRUT) I $D(DIR("B")),DIR("B")=Y G GETTYPE K DICOMPX S DICOMPX="" S DICMIN=Y,DQI="Y("_A_","_DA_",",DICMX="X DICMX",DICOMP="?I" D ^DICOMP I '$D(X) W $C(7)," ...??" G 6 I DUZ(0)="@" W !,"TRANSLATES TO THE FOLLOWING CODE:",!,X,! I Y["m" W !,"FIELD IS 'MULTIPLE-VALUED'!",! I O,$D(^DD(A,DA,9.01))!(DICOMPX]"") D ACOMP S DISPEC=$E("D",Y["D")_$E("B",Y["B")_"C"_$S(Y'["m":"",1:"m"_$E("w",Y["w"))_$S(Y["p":"p"_$S($P(Y,"p",2):+$P(Y,"p",2),1:""),1:"")_$S(Y'["B":"",1:"J1") S ^DD(A,DA,0)=F_U_DISPEC_"^^ ; ^"_X,^(9)=U,^(9.1)=DICMIN,^(9.01)=DICOMPX F Y=9.2:0 Q:'$D(X(Y)) S ^(Y)=X(Y),Y=$O(X(Y)) K X,DICOMPX GETTYPE K DIR S DIR(0)="SBA^S:STRING;N:NUMERIC;B:BOOLEAN;D:DATE;m:MULTIPLE;p:POINTER;mp:MULTIPLE POINTER" S DIR("A")="TYPE OF RESULT: " S DIR("B")=$P($E(DIR(0),$F(DIR(0),$$TYPE(DISPEC)_":"),99),";") D ^DIR I $D(DIRUT) G END S DISPEC=$TR(Y,"SN") I Y="B"!(Y="D") D P(Y) G END I Y["p" D POINT G END S DIJ="",DIE=$P($P(O,U,2),"J",2) F J=0:0 S N=$E(DIE) Q:N?.A S DIE=$E(DIE,2,99),DIJ=DIJ_N S DIDEC=$P(DIJ,",",2),DIL=$S(DIJ:+DIJ,1:8) S:Y'="N" DIDEC="" I DISPEC["m" D P(DISPEC) G END D DEC:Y="N" I '$D(DIRUT) D LEN END I O S DI=A D PZ^DIU0 Q D SDIK^DICATT22 6 Q ;leave this here ; ; DEC N DG,O,M FRAC K DIR S DIR("A")="NUMBER OF FRACTIONAL DIGITS TO OUTPUT: " I DIDEC]"" S DIR("B")=DIDEC S DIR("?")="Enter the number of decimal digits that should normally appear in the result." S DIR(0)="NAO^0:14:0" D ^DIR Q:$D(DIRUT) S DIDEC=Y S DG=" S X=$J(X,0,",M=$P(^DD(A,DA,0),DG),%=M_DG_DIDEC_")"'=^(0)+1 W !,"SHOULD VALUE ALWAYS BE INTERNALLY ROUNDED TO ",DIDEC," DECIMAL PLACE",$E("S",DIDEC'=1) D YN^DICN G FRAC:'% Q:%'>0 S ^DD(A,DA,0)=M_$P(DG_DIDEC_")",U,%) S S DQI="Y(",O=$D(^(9.02)),X=^(9.1) K DICOMPX,^(9.02) Q:'$D(^(9.01)) F Y=1:1 S M=$P(^(9.01),";",Y) Q:M="" S DICOMPX(1,+M,+$P(M,U,2))="S("""_M_""")",DICOMPX="" Q:Y<2 I X'["/",X'["\" Q:X'["*" Q:Y<3 D ^DICOMP Q:$D(X)-1 S %=2-O W !,"WHEN TOTALLING THIS FIELD, SHOULD THE SUM BE COMPUTED FROM",!?7,"THE SUMS OF THE COMPONENT FIELDS" D YN^DICN I %=1 S ^DD(A,DA,9.02)=X_" S Y=X" S:%<1 DIRUT=1 Q ; LEN K DIR S DIR(0)="NAO^1::0",DIR("A")="LENGTH OF FIELD: ",DIR("B")=DIL S DIR("?")="Maximum number of character expected to be output." D ^DIR Q:$D(DIRUT) D P($P(DISPEC,"J")_"J"_Y_$E(",",DIDEC]"")_DIDEC_DIE) Q ; POINT K DIR S DIR(0)="P^1:QEF",DIR("A")="POINT TO WHAT FILE" S DIR("S")="I $$OKFILE^DICOMPX(Y,""W"")" S X=$P($P(^DD(A,DA,0),U,2),"p",2) I 'X S X=$P($P(O,U,2),"p",2) I X,$D(^DIC(+X,0)) S DIR("B")=$P(^(0),U) D ^DIR I '$D(DIRUT) S $P(DISPEC,"p",2)=+Y D P(DISPEC) Q ; P(C) S $P(^DD(A,DA,0),U,2)="C"_$TR(C,"C^") Q ; ACOMP ;SET/KILL ACOMP NODES N X,I I $G(^DD(A,DA,9.01))]"" S X=^(9.01) X ^DD(0,9.01,1,1,2) I DICOMPX]"" S X=DICOMPX X ^DD(0,9.01,1,1,1) Q ; TYPE(S) ; Q $S(S["D":"D",S["B":"B",S["mp":"mp",S["m":"m",S["p":"p",S'["J":"S",S[",":"N",1:"S") ;figure out TYPE OF RESULT DICATT4 DICATT4 ;SFISC/XAK-DELETE A FIELD ;12:39 PM 7 Mar 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. DIEZ S DI=A,DA=D0 D DIPZ^DIU0 K ^DD(A,0,"ID",D0),^DD(A,0,"SP",D0) EN I $O(@(I(0)_"0)"))>0 D .N X,T,Y,Z,MUL .S MUL=+$P(O,U,2) .S %=1,Y=$P(O,U,4),X=$P(Y,";"),Y=$P(Y,";",2),Z=$S(+X=X:X,1:""""_X_"""")_")",E="^("_Z .I $O(^DD(A,"GL",X,""))="" S T="K ^(M,"_Z G F .I Y S T="U_$P("_E_",U,"_(Y+1)_",999) K:"_E_"?.""^"" "_E S:Y>1 T="$P("_E_",U,1,"_(Y-1)_")_U_"_T .E S X=+$E(Y,2,4),Y=+$P(Y,",",2) Q:'X!'Y S T="$E("_E_",1,"_(X-1)_")_$J("""","_(Y-X+1)_")_$E("_E_","_(Y+1)_",999)" .S T="I $D(^(M,"_Z_")#2 S "_E_"="_T F .I '$D(DIU(0)) W $C(7),!,"OK TO DELETE '",$P(M,U),"' FIELDS IN THE EXISTING ENTRIES" D YN^DICN I %-1 D:'$D(DIU) DELXRF(A,D0) Q KILLIX .I $D(DICATT4M) D S M="" F S M=$O(^DD(J(0),0,"IX",M)) Q:M="" I $O(^(M,MUL,0)) K @(I(0)_""""_M_""")") ..D INDEX^DIKC(J(0),"","","","KiRW"_MUL) .E D:'$D(DIU) DELXRF(A,D0,1,J(0)) .S M="",X=DICL,Y=I(0) I $D(DQI) K @(I(0)_""""_DQI_""")") L .S O="M" S:X O=O_"("_X_")" S Y=Y_O,M=M_"F "_O_"=0:0 S "_O_"=$O("_Y_")) Q:"_O_"'>0 " .S X=X-1 I X+1 S Y=Y_","_I(DICL-X)_"," G L .S M=M_"X T"_$P(" W "".""",U,$S('$D(DIU(0)):1,DIU(0)["E":1,1:0)) .X M ;HERE'S THE LOOP WHERE WE KILL THE VALUES! N Q:$D(DIU)!$D(DICATT4M) G N^DICATT ; NEW ;Delete the data in the multiple S DICATT4M=$NA(^DD(A,D0)) S DICATT4M("SB")=$NA(^DD(A,"SB",+$P(O,U,2),D0)) S ^DD(A,D0,0)=O,^DD(A,"SB",+$P(O,U,2),D0)="" D DICATT4 K @DICATT4M,@DICATT4M("SB"),DICATT4M ; ;Kill the DD globals and go back to N^DICATT D KDD G N^DICATT ; VP ; VARIABLE POINTER S DA(2)=DA(1),DA(1)=DA,DICATT=DA I $D(DICS) S DICSS=DICS K DICS V S DA(2)=A,DA(1)=DICATT,DIC="^DD("_A_","_DICATT_",""V"",",DIC("P")=".12P",DIC(0)="QEAMLI",DIC("W")="W:$S($D(^DIC(+^(0),0)):$P(^(0),U)'=$P(^DD(DA(2),DA(1),""V"",+Y,0),U,2),1:0) ?30,$P(^(0),U,2)" D ^DIC S DIE=DIC K DIC I Y>0 S DA=+Y,Z="P",DR=".01:.04;"_$S($P($G(^DD(+$P(Y,U,2),0,"DI")),U,2)["Y":".06///n",1:".06T")_";S:DUZ(0)'=""@"" Y=0;.05;I ""n""[X K ^DD(DA(2),DA(1),""V"",DA,1),^(2) S Y=0;S DIE(""NO^"")=""BACK"";1;2;" S:$P(Y,U,3) DIE("NO^")="" I Y>0 D ^DIE K DIE W ! S:$D(DTOUT) DA=DICATT G CHECK^DICATT:$D(DTOUT),V S Z="V^",DIZ=Z,C="Q",L=18,DA=DICATT,DA(1)=A S:$D(DICSS) DICS=DICSS K DICSS,DR,DIE,DA(2),DICATT G CHECK^DICATT:$D(DTOUT)!(X=U),^DICATT1 Q HELP ; W !?5,"Enter a MUMPS statement that sets DIC(""S"") to code that sets $T." W !?5,"Those entries for which $T=1 will be selectable." I Z?1"P".E D Q . W !?5,"The naked reference will be at the zeroeth node of the pointed to" . W !?5,"file, e.g., ^DIZ(9999,Entry Number,0). The internal entry number" . W !?5,"of the entry that is being processed in the pointed to file will be" . W !?5,"in the variable Y." W !?5,"The variable Y will be equal to the internally-stored code of the item" W !?5,"in the set which is being processed." Q KDD ; I '$D(DIANC) S X=A F S DIANC(X)="" Q:$D(^DD(X,0,"UP"))[0 S X=^("UP") S DQ=$O(DQ(0)),X=0 I DQ="" S DQ=-1 K DIANC Q D KIX(.DIANC,DQ) F S X=$O(^DD(DQ,"SB",X)) Q:'X S DQ(X)=0 N DIFLD S DIFLD=0 F S DIFLD=$O(^DD(DQ,DIFLD)) Q:'DIFLD D . I $D(^DD(DQ,DIFLD,9.01)) S X=^(9.01),Y=DIFLD D KACOMP . D KTRB(.DIANC,DQ,DIFLD) . S X=$P($G(^DD(DQ,DIFLD,0)),U,2) I X'["P",X'["V" Q . I X["P" S X=+$P(X,"P",2) K:X ^DD(X,0,"PT",DQ,DIFLD) Q . F %=0:0 S %=$O(^DD(DQ,DIFLD,"V",%)) Q:'% S X=+$G(^(%,0)) K:X ^DD(X,0,"PT",DQ,DIFLD) . Q K DQ(DQ),^DD(DQ),^DD("ACOMP",DQ),^DDA(DQ) S Y=0 F S Y=$O(DIANC(Y)) Q:'Y K ^DD(Y,"TRB",DQ) D DELXR(DQ) S Y=0 F S Y=$O(^DIE("AF",DQ,Y)) Q:Y="" S %=0 F S %=$O(^DIE("AF",DQ,Y,0)) Q:%="" K ^(%),^DIE(%,"ROU") S Y=0 F S Y=$O(^DIPT("AF",DQ,Y)) G KDD:Y="" S %=0 F S %=$O(^DIPT("AF",DQ,Y,0)) Q:%="" K ^(%),^DIPT(%,"ROU") ; KIX(DIANC,DIFIL) ; N F,NM S F=0 F S F=$O(DIANC(F)) Q:'F D . S NM="" F S NM=$O(^DD(F,0,"IX",NM)) Q:NM="" K:$D(^(NM,DIFIL)) ^(DIFIL) Q KACOMP N DA,I,% S DA(1)=DQ,DA=Y X ^DD(0,9.01,1,1,2) Q ; KTRB(DIANC,DIFIL,DIFLD) ;Kill 5 node of triggered field ;Also kill "TRB" nodes here if triggered field is in another file N %,F,DITFLD,DITFIL,DIXR,DIXR0 S DIXR=0 F S DIXR=$O(^DD(DIFIL,DIFLD,1,DIXR)) Q:'DIXR S DIXR0=$G(^(DIXR,0)) D:$P(DIXR0,U,3)="TRIGGER" . S DITFIL=$P(DIXR0,U,4),DITFLD=$P(DIXR0,U,5) Q:'DITFIL!'DITFLD . S %=0 . F S %=$O(^DD(DITFIL,DITFLD,5,%)) Q:'% I $P($G(^(%,0)),U,1,3)=(DIFIL_U_DIFLD_U_DIXR) D Q .. K ^DD(DITFIL,DITFLD,5,%) Q:DITFIL=DIFIL!$D(DIANC(DITFIL)) .. S F=DITFIL .. F K ^DD(F,"TRB",DIFIL) S F=$G(^DD(F,0,"UP")) Q:'F!$D(DIANC(+F)) Q DELXR(DIFIL) ;Delete the Key and Index file entries for file DIFIL Q:'$G(DIFIL) N DA,DIK ; ;Kill keys on file DIFIL S DIK="^DD(""KEY""," S DA=0 F S DA=$O(^DD("KEY","B",DIFIL,DA)) Q:'DA D ^DIK ; ;Kill indexes on file DIFIL S DIK="^DD(""IX""," S DA=0 F S DA=$O(^DD("IX","AC",DIFIL,DA)) Q:'DA D ^DIK Q ; DELXRF(DIFIL,DIFLD,DIFLG,DITOPFIL) ;Delete Keys and Indexes on field ;If DIFLG=1, also delete the Indexes from the data global. Q:'$G(DIFIL)!'$G(DIFLD) N DA,DIK ; ;Execute the kill logic for all indexes defined on the field ;for all entries in the file. I $G(DIFLG) D . S:$G(DITOPFIL)="" DITOPFIL=$$FNO^DILIBF(DIFIL) . D:DITOPFIL INDEX^DIKC(DITOPFIL,"",DIFLD,"","RKW"_DIFIL) ; ;Kill keys on file/field S DIK="^DD(""KEY""," S DA=0 F S DA=$O(^DD("KEY","F",DIFIL,DIFLD,DA)) Q:'DA D ^DIK ; ;Kill indexes on file/field S DIK="^DD(""IX""," S DA=0 F S DA=$O(^DD("IX","F",DIFIL,DIFLD,DA)) Q:'DA D ^DIK Q DICATT5 DICATT5 ;SFISC/XAK-POINTERS ;12:04 PM 25 Jan 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. 7 K DIC S Y="",%=$P(O,U,3),DIC(0)="EFQIZ" S:$P(O,U,2)["P"&$L(%) Y=$S($D(@("^"_%_"0)")):$P(^(0),U),1:"") W !,"POINT TO WHICH FILE: " W:Y]"" Y_"// " R X:DTIME S:'$T DTOUT=1 G CHECK^DICATT:X=U!'$T I Y]"",X="" S X=Y,DIC(0)=DIC(0)_"O" S DIC=1,DIC("S")="I Y'=1.1 S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %" D ^DIC K DIC,DIFILE,DIAC G:Y<0 7:X["?",T S X=^(0,"GL"),DE=Y G 77 T K DIC G CHECK^DICATT:$D(DTOUT),NO^DICATT2 77 S DIFILE=+Y,DIAC="LAYGO" D ^DIAC S %=0 S:'DIAC!($P($G(^DD(DIFILE,0,"DI")),U,2)["Y") %=2 K DIFILE,DIAC P I % W !,$C(7) D A W !,"WILL NOT " D B E S %=1+$S($P(O,U,2)["'":1,$P(O,U,2)']"":1,1:0) W !,"SHOULD " D A W ! D B,YN^DICN G T:%<1 S Z="P"_+DE_$E("'",%=2)_X,C="Q",L=9,E=X G H:DUZ(0)'="@" D S G T:X=U,H S ; S D=$S($D(^DD(A,DA,12.1)):^(12.1),1:""),%=2-(D]""),P=$S($D(^(12)):^(12),1:""),I=$S($D(^(12.2)):^(12.2),1:"") W !,"SHOULD '"_$P(DE,U,2)_"' ENTRIES BE SCREENED" D YN^DICN S:%<0 X=U Q:X=U I '% W !?5,"Answer YES if there is a condition which should prohibit",!?5,"selection of some entries." G S I %=2 K ^(12.1),^(12),^(12.2) Q G M ;W !,"ENTER A TRUTH-VALUED EXPRESSION WHICH MUST BE TRUE OF ANY ENTRY POINTED TO:",!?4 I I]"" W I_"// " W:$X>35 !?4 R X:DTIME S:'$T DTOUT=1 G T:X=U!'$T S:X="" X=I I X="" G M:DUZ(0)="@",S K DG,K S ^(12.2)=X,K=100,DQI="Y(",DG(K)=K,K(1,1)=K,(DLV,DLV0)=K,J(K)=+DE,I(K)=E,K=0 D EN^DICOMP G S:'$D(X) I $D(X)>1!(X[" ^DIC") W $C(7),!,"TOO COMPLICATED!" G S S I=0 I 'DBOOL W $C(7),!?8,"WARNING-- THIS DOESN'T LOOK LIKE A TRUTH-VALUED EXPRESSION" D0 S I=$F(X,E_"D0",I) I I S X=$E(X,1,I-3)_"Y"_$E(X,I,999) G D0 Q S I=$F(X,"""",I) I I S X=$E(X,1,I-1)_""""_$E(X,I,999),I=I+1 G Q S (D,X)="S DIC(""S"")="""_X_" I X""" G E:DUZ(0)'="@" M W !,"MUMPS CODE THAT WILL SET 'DIC(""S"")': " W:D]"" D S Y=D D:D]"" RW^DIR2 G S:X="@" I D']"" R X:DTIME S:'$T DTOUT=1 Q:X=U!'$T I X="" S X=D G S:X="" I X?."?" D HELP^DICATT4 G M D ^DIM:'$T I '$D(X) S X="" G S I X'["DIC(""S"")" W $C(7),!,?8,"WARNING - Screen Does Not Contain DIC(""S"")" E W !,"EXPLANATION OF SCREEN: " W:P]"" P_"// " R %:DTIME S:'$T %=U,DTOUT=1 S:%="" %=P G S:%=U I %?.P W !?5,$C(7),"An explanation must be entered." G E I $D(^DD(A,DA,12.1)) S:X'=^(12.1) M(1)=0 S ^DD(A,DA,12)=%,^(12.1)=X,Z="*"_Z S:Z?1"*P".E C=X_" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X" Q H S DIZ=Z G ^DICATT1 ; A W "'ADDING A NEW "_$P(DE,U,2)_" FILE ENTRY' (""LAYGO"")" Q B W "BE ALLOWED WHEN ANSWERING THE "_F_"' QUESTION" Q Q DICATT6 DICATT6 ;SFISC/XAK-SETS,FREE TEXT ;2013-01-16 11:41 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. G @N ; 3 S Z="",L=1,P=0,Y="INTERNALLY-STORED CODE: " P S P=P+1,C=$P($P(O,U,3),S,P) W !,Y W:C]"" $P(C,":",1)_"// " R T:DTIME G T:'$T I T_C]"" G P:T="@" S:T="" T=$P(C,":",1) S X=T,L=$S($L(X)>L:$L(X),1:L) D C I $D(X) W " WILL STAND FOR: " W:C]"" $P(C,":",2),"// " R X:DTIME G:'$T T S:X="" X=$P(C,":",2) D C I $D(X) G TOO:$L(Z)+$L(T)+$L(X)+$L(F)>235 S Z=Z_T_":"_X_S G P:X]"",T G T:Z=""!'$D(X) S (DIZ,Z)="S^"_Z I DUZ(0)="@" S DE="^"_F D S^DICATT5 K DE G CHECK^DICATT:$D(DTOUT)!(X=U) S C="Q" G H ; C I X["?",P=1 K X W !,"For Example: Internal Code 'M' could stand for 'MALE'",! Q I X[":"!(X[U)!(X[S)!(X[Q)!(X["=") K X W $C(7),!,"SORRY, ';' ':' '^' '""' AND '=' AREN'T ALLOWED IN SETS!",! Q I X'?.ANP W !,$C(7),"Cannot use CONTROL CHARACTERS!" K X Q ; TOO W $C(7),!,"TOO MUCH!! -- SHOULD BE 'POINTER', NOT 'SET'" T W ! G NO^DICATT2:'$D(X) S DTOUT=1 G CHECK^DICATT ; 4 K DG,DE,M S L=$G(^DD("STRING_LIMIT"),255)-5,P=$P($P($P(^DD(A,DA,0),U,4),";",2),"E",2) I P S M=$P(P,",",2) I M S L=M-P+1 S DL=1,DP=-1,DQ(1)="MINIMUM LENGTH^NR^^1^K:X\1'=X!(X<1) X",DQ(2)="MAXIMUM LENGTH^RN^^2^K:X\1'=X!(X>"_L_")!(DG(1)>X) X" S T="",L=1,P=" X",DQ(3)="(OPTIONAL) PATTERN MATCH (IN 'X')^^^3^S X=""I ""_X D ^DIM S:$D(X) X=$E(X,3,999) I $D(X) K:X?.NAC X",DQ(3,3)="EXAMPLE: ""X?1A.A"" OR ""X'?.P""" G DIED:'O,DG:C'?.E1"K:$L".E1" X" S T=$P(C,"K:$L",1),DE(2)=+$P(C,"$L(X)>",2),DE(1)=+$P(C,"$L(X)<",2) S Y=0,I=0,Z=$P(C,")!'(",2,99) I Z="" K:'DE(2) DE(2) G DG L S I=I+1,X=$E(Z,I) G L:X'?.P,DG:X="" I X=Q S Y='Y G L G L:Y I X="(" S L=L+1 G L:X'=")" S L=L-1 G L:L S DE(3)=$E(Z,1,I-1),P=$E(Z,I+1,999) DG S:$D(^DD(A,DA,3)) M=^(3) F L=1,2,3 S:$D(DE(L)) DG(L)=DE(L) DIED K Y S DM=0 D DQ^DIED K DQ,DM G CHECK^DICATT:$D(DTOUT)!($D(Y)) S Y=DG(1),L=DG(2),X=$S(L=Y:L,1:Y_"-"_L) I L"_L_"!($L(X)<"_Y_")"_X_P Z S (DIZ,Z)="FJ"_L_U H G ^DICATT1 DICATTA DICATTA ;SFISC/YJK-DD AUDIT ;11JUN2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; SV ;From DICATT & DICATTD F %=1:1 S A0=$P($$I,",",%) Q:A0="" I $D(^DD(A,+Y,A0)) S ^UTILITY("DDA",$J,A,+Y,A0)=^(A0) K %,A0 Q ; ; ; ; AUDT ; N OLD,NEW S B0=DDA(1) I DDA="E" D B G QQ S A0="LABEL^.01" I DDA["D" S OLD=$P(^UTILITY("DDA",$J,B0,DA,0),U) E S NEW=$P(^DD(B0,DA,0),U) D ADD(.OLD,.NEW) G QQ ; B S A0="",A1=^UTILITY("DDA",$J,B0,DA,0),A2=^DD(B0,DA,0) S A3=1,A5="LABEL^TYPE^TYPE",B3=".01^.25^.25" F %=1:1:3 I $P(A1,U,%)'=$P(A2,U,%) S $P(A0,",",A3)=$P(A5,U,%),$P(A4,",",A3)=$P(B3,U,%),$P(B1,"^",A3)=$P(A1,U,%),$P(B2,"^",A3)=$P(A2,U,%),A3=A3+1 I $P(A1,U,5,99)'=$P(A2,U,5,99) S $P(A0,",",A3)="INPUT TRANSFORM",$P(B1,"^",A3)=$P(A1,U,5,99),$P(B2,"^",A3)=$P(A2,U,5,99),$P(A4,",",A3)=.5 I A0]"" S A0=A0_"^"_A4,A1=B1,A2=B2 D ADD(A1,A2) K B3,A1,A2,A3,A4,A5 D B1($$I) Q ; ; I() Q "0,.1,3,4,8,8.5,9,9.1,10,AUDIT,AX" ; ; ; B1(B1) F B2=2:1 S %=$P(B1,",",B2) Q:%="" S:$D(^UTILITY("DDA",$J,B0,DA,%)) A1=^(%) S:$D(^DD(B0,DA,%)) A2=^(%) I $D(A1)!$D(A2) S %=$S(%="AUDIT":1.1,%="AX":1.2,1:%),A0=$S($D(^DD(0,%,0)):$P(^(0),U,1),1:"")_"^"_% D P Q ; ; DDAUDITQ(FILE) ;ALWAYS DO DD AUDIT Q 1 ;F Q:'$G(^DD(FILE,0,"UP")) S FILE=^("UP") ;Q $G(^DD(FILE,0,"DDA"))="Y" ; ; ; UPDATED(FILE,FIELD) I $D(^DD(FILE,FIELD,0)) S ^("DT")=DT S ^DD(FILE,0,"DT")=DT F Q:'$G(^DD(FILE,0,"UP")) S FILE=^("UP") S ^DD(FILE,0,"DT")=DT,$P(^DIC(FILE,"%MSC"),U)=$$NOWINT^DIUTL Q ; ; P ;From ^DIAUTL & B1 above I $D(A1),'$D(A2) S DDA="D" D ADD(A1) K A1 Q I '$D(A1),$D(A2) S DDA="N" D ADD(,A2) K A2 Q I A1'=A2 S DDA="E" D ADD(A1,A2) K A1,A2 Q ; ; ; ; ADD(OLD,NEW) D UPDATED(B0,DA) I '$$DDAUDITQ(B0) K %D Q ;%D is return variable. If it is not there, we are not auditing. N B3,%T I '$D(^DDA(B0,0)) S %=$P(^DIC(J(0),0),U),^DDA(B0,0)=$S(B0=J(0):%,1:%_" ("_$P(^DD(B0,0),U,1)_")")_" DD AUDIT^.6I" F B3=$P(^(0),U,3):1 I '$D(^(B3)) L +^DDA(B0,B3):0 Q:$T S $P(^(0),U,3,4)=B3_U_($P(^(0),U,4)+1),^(B3,0)=DA L -^DDA(B0,B3) S %T=$$NOWINT^DIUTL,^DDA(B0,"D",%T,B3)="",^DDA(B0,"E",DUZ,B3)="",^DDA(B0,"B",DA,B3)="",^DDA(B0,B3,0)=DA_U_DDA_U_%T_U_DUZ_U_A0_U_B0 S:$G(OLD)]"" ^(1)=OLD S:$G(NEW)]"" ^(2)=NEW S %D=B3 Q ;RETURNS %D ; ; IT ;From DIU3, DIU31, DICATT2 S B0=DI,DDA="E" D ADD(A1,A2) G QQ ; IT1 ;From DIU31 S B0=DI D B1(",3,4,12.1") G QQ ; XS ;From DICE I $P(^DD(J(N),DA,1,DQ,0),U,3)["TRIG"!($P(^(0),U,3)["BULL") S DDA="TE" Q:'$D(^(3)) S ^UTILITY("DDA",$J,J(N),DA,3)=^(3) Q S %=0 F B1=1:1 S %=$O(^DD(J(N),DA,1,DQ,%)) Q:+%'>0 S ^UTILITY("DDA",$J,J(N),DA,B1)=^(%) K B1,% Q ; XA ;From DICE, DICE0, DIKD, DICD S B0=J(N),DA=DL,A0="CROSS REFERENCE^1" I DDA["T" S DDA="E" D G QQ TR .K A1,A2 S:$D(^DD(B0,DA,1,DQ,3)) A2=^(3) S:$D(^UTILITY("DDA",$J,B0,DA,3)) A1=^(3) Q:'$D(A1)&'$D(A2) .D ADD($G(A1),$G(A2)) Q S %=0 D I % D ADD(,) I $G(%D)>0 S B1=$S(DDA["D":1.1,1:2.1),A0="^DD(B0,DA,1,DQ," D XL CK .K A1,A2 F B1=1:1:3 S:$D(^DD(B0,DA,1,DQ,B1)) A1=^(B1) S:$D(^UTILITY("DDA",$J,B0,DA,B1)) A2=^(B1) I $D(A1)!$D(A2) D Q:% C ..I ($D(A1)&'$D(A2))!('$D(A1)&$D(A2)) S %=1 Q ..S:A1'=A2 %=1 QQ S DDA="" K B0,%D,B1,B2,%,A0,A1,A2,^UTILITY("DDA",$J) Q ; ; ; ; XL Q:$G(%D)'>0 S %=0 F B2=1:1 S %=$O(@(A0_%_")")) Q:+%'>0 S ^DDA(B0,%D,B1,B2,0)=^(%) S B2=B2-1,%=$S(B1=1.1:.601,1:.602),^DDA(B0,%D,B1,0)="^"_%_"^"_B2_"^"_B2_"^"_DT I DDA["E",B1=2.1 S B1=1.1,A0="^UTILITY(""DDA"",$J,B0,DA," G XL K %,B2 Q DICATTD DICATTD ;SFISC/GFT-SCREEN-MODE 'MODIFY FILE ATTRIBUTES' ;13MAY2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N DG,DLAYGO,DIC,DICATTB,DICATTA,DICATTF,DA,DDA K ^UTILITY("DICATTD",$J),^UTILITY("DDA",$J) ;auditing S DLAYGO=1 D D^DICRW Q:Y<0 I $P($G(^DD(+Y,0,"DI")),U)["Y",$P(@(^DIC(+Y,0,"GL")_"0)"),U,4) W !!,$C(7),"DATA DICTIONARY MODIFICATIONS ON ARCHIVE FILES ARE NOT ALLOWED!" Q I '$D(DIC) D DIE^DIB Q:'$D(DG) S DIC=DG LOCK S (DA,DICATTB,DICATTA)=+$P(@(DIC_"0)"),U,2) L +^DICATTD(DA):1 E W !!,"SOMEONE ELSE IS EDITING THIS FILE" Q ;N.B.--There is no such Global DDA S DDA="" ;DD auditing ASKLOOP F K DICATTF D M I $S('$D(DICATTF):1,'$D(^DD(DICATTA)):1,DICATTF-.01:0,1:$P(^DD(DICATTA,DICATTF,0),U,2)["W") Q:DICATTA=DICATTB S DICATTA=DICATTB END L -^DICATTD(DICATTB) Q ; M N DICATTVP,DICATTDK,DICATT2N,DICATTMN,DICATTDW,DDSERROR,DICS,DICATTSC N DICATT2,DICATT4,DICATT3,DICATT3N,DICATTL,DICATTLN,DICATT5,DICATT5N,DICATT5P N O,DIU0,I,J,DR,A,DQ N DDSFILE,DIMSG,DUOUT,DTOUT,DDSPAGE,DDSPARM,DDSSAVE,DICATTNW FIELD W !!! K DIC,O,^UTILITY("DICATTD",$J) ;clean WP buffer S DIC(0)="ALEQIZ",DIC="^DD("_DICATTA_"," S:$D(DICS) DIC("S")=DICS S DIC("W")="S %=$P(^(0),U,2) I % W $P("" (multiple)^ (word-processing)"",U,$P(^DD(+%,.01,0),U,2)[""W""+1)" I $P(^DD(DICATTA,.01,0),U,2)["W" S DIC(0)="AEQZ",DIC("B")=.01 D ^DIC K DIC I Y<0 K DICATTF Q ;look-up NEWFIELD I $P(Y,U,3) S DICATTNW=1 S:$D(DDA) DDA="N" E S DIU0=DICATTA,O(1)=$P(^(0),U,1,2),O(2)=$G(^(.1)) I $D(DDA) D .N A S A=DIU0 S DDA="E" D SV^DICATTA S:$D(DDA) DDA(1)=DICATTA S DICATTF=+Y D GET MUL I DICATT2 D Q:'DICATTA!'$D(^DD(DICATTA)) G FIELD ;If it's multiple... .N DICATT2N,DDSPAGE,DDSPARM,DDSSAVE .S DDSPARM="S",DDSPAGE=10 D DDS ;...we do Page 10 .I $G(DDSSAVE) S DICATTA=+$G(DICATT2) ;Go down into multiple unless they aborted with F1-Q DDS K DDSSAVE,DIMSG S DDSPARM="S",DA="",DR="[DICATT]",DDSFILE=1 D ^DDS ;invoke SCREENMAN! Q:'$D(^DD(DICATTA,DICATTF,0)) S DICATT2N=$P(^(0),U,2) I DICATT2N="",DICATTF-.01 D DELFLD^DICATTDK(DICATTA,DICATTF) Q ;delete field VERIFY I '$D(DTOUT),'$D(DIMSG),$D(DDSSAVE) D N^DICATTDE I 'DICATT2N,'$G(DICATTNW),$D(DICATTMN) D DIVR^DIUTL(DICATTA,DICATTF) ;re-verify fields Q ; GET ; K DICATT2N,DICATT3N,DICATT5N,DICATTLN,DICATT5P S DICATT2=$P(^DD(DICATTA,DICATTF,0),U,2),DICATT3=$P(^(0),U,3),DICATT4=$P(^(0),U,4),DICATT5=$P(^(0),U,5,99) I $D(^DD(DICATTA,DICATTF,"V")) D GET^DICATTD8 ;Variable-pointer Q ; PRE ;PRE-ACTION of first block N DIAC,DIFILE I DICATTF=.01 D REQ^DDSUTL(1,"DICATT",1,1) ;for now I DICATT2["C" D CUNED^DICATTD6(DICATT2) I DICATT2["W" F X=18 D UNED(X) S X=1 I DICATTF=.01,DICATTA-DICATTB S X=2 D UNED^DDSUTL(20.5,"DICATT",1,X) ;2 means REACHABLE but not EDITABLE S DIAC="AUDIT",DIFILE=DICATTB D ^DIAC I %-1 D UNED(3) ;check AUDIT ACCESS I DUZ(0)'="@" D ;only programmers can... .D UNED(4),UNED(99) ; ..edit AUDIT CONDITION, XECUTABLE HELP, or ... .I DICATT2["X" D X,UNED(1),UNED(2) ;edit LABEL of 'X' field, or ... .I $$TYPE=9 D UNED(20) ;edit a MUMPS type .F I=4,5 D UNED^DDSUTL(I,"DICATTVP",8,1) ;build VARIABLE-POINTER SCREEN .F I=16,17 D UNED^DDSUTL(I,"DICATTM",3,1) ;specify location of .F I=76,76.1 D UNED^DDSUTL(I,"DICATTS",4,1) ;...data Q:DICATT2'["X" X I DICATT2'["F" D UNED(20) D HLP^DDSUTL("NOTE THAT THIS FIELD'S DEFINITION IS NOT EDITABLE") Q D UNED^DDSUTL(20,"DICATT",1,2) ;FREE-TEXT DATA TYPE REACHABLE BUT NOT EDITABLE F I=68,70 D UNED^DDSUTL(I,"DICATT4",2.4,1) ;MINIMUM LENGTH & PATTERN MATCH NOT EDITABLE S DICATT5="$L(X)>"_$$FL^DIQGDDU(DICATTA,DICATTF) Q ; UNED(I) D UNED^DDSUTL(I,"DICATT",1,1) Q ; NUMBER ; D IJ^DIUTL(DICATTA) S Y=" File #"_J(0) F I=1:1 Q:'$D(J(I)) S Y=" Sub-File #"_J(I)_" of"_Y S Y="Field #"_DICATTF_" in"_Y I $P($G(^DD(DICATTA,DICATTF,0)),U,2) S Y="Multiple "_Y S Y=$J("",78-$L(Y)\2)_Y Q ; TYPE() ;Figure out TYPE from the second piece of the zero node I DICATT2="" Q "" N N F N=9:-1:5,1:1:4,100 I DICATT2[$E("DNSFWCPVK",N) Q S:N=100 N=4 Q N ; SCREEN ; N N I DICATTF=.001 S DIR("S")="I Y<4!(Y=7)" Q S N=$$TYPE I N="" S:DUZ(0)'="@" DIR("S")="I Y-9" Q I N=6 S DIR("S")="I Y=6" Q ;can't change a COMPUTED FIELD's type S DIR("S")="I Y-6,Y-9"_$P(",Y-5",U,N\2-2!'$D(^DD(DICATTA,0,"UP"))!(DICATTF-.01)!($O(^DD(DICATTA,DICATTF))>0))_$S(N=7:",Y-8",N=8:",Y-7",1:"") Q ; BRANCH ;given X=TYPE F I=31,32 D REQ^DDSUTL(I,"DICATT2",2.2,X=2) ;UPPER BOUND & LOWER BOUND if we are doing a NUMERIC F I=68,69 D REQ^DDSUTL(I,"DICATT4",2.4,X=4&(DICATT2'["X")) ;MAX LENGTH & MIN LENGTH if we are doing a FREE TEXT (but not if UNEDITABLE) I X=9 G ^DICATTD9 I DICATT4="",DICATTF>.001 D UNED^DDSUTL(20.5,"DICATT",1,X=5) ;W-P doesn't ask MULTIPLE K DICATTSC S DDSSTACK="2."_X Q ;For types 1-8, go to PAGE 2.1 - 2.8 ; CHNG I DICATT5N=DICATT5 K DICATTMN ;No DICATTMN means no change D:$D(DICATTMN) PUT^DDSVALF(98,"DICATT",1,DICATTMN) ;HELP-PROMPT prompted Q ; DICATTD0 DICATTD0 ;GFT/GFT - CREATE WORD-PROCESSING ATTRIBUTES IN SCREENMAN ;01:06 PM 9 Jan 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; WORD(DICT) ;DICT=21 or 23 for DESCRIPTION and TECHNICAL DESCRIPTION N DIC,DUOUT,DTOUT,DICR,DIWETXT D DICR I $D(@DICR)=0 M @DICR=^DD(DICATTA,DICATTF,DICT) S DICATTDW(DICT)=1 I $D(@DICR)=0 S @DICR@(0)=0 S DIWETXT="Editing '"_$P(^DD(DICATTA,DICATTF,0),U)_"' "_$P(^DD(0,DICT,0),U) S DIC=$P(DICR,")")_"," D EN^DIWE I $D(DUOUT)!$D(DTOUT) K @DICR,DICATTDW(DICT) W $$EZBLD^DIALOG(8077) S DDSCHG=1 Q ; DICR S DICR="^UTILITY(""DICATTD"",$J,DICT)" Q ; ; FILEWORD ;when we're done N DICT,DICR D DICR F DICT=21,23 D .I $D(DICATTDW(DICT)) K ^DD(DICATTA,DICATTF,DICT) M ^DD(DICATTA,DICATTF,DICT)=@DICR Q DICATTD1 DICATTD1 ;SFISC/GFT- DATE,TIME ;2 FEB 2009 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 11 ;Per VHA Directive 2004-038, this routine should not be modified. ; EARLY ; S Y=">X" G Y ; LATEST ; S Y="DT DDSERROR=1 Q .S Z=Y D ^%DT I YX) X" E I $D(DICATTMN(21)) S DICATTMN="Type a date not earlier than "_DICATTMN(21)_".",DICATT5N=DICATT5N_DICATT5N(21)_">X X" E S DICATT5N=DICATT5N_"X<1 X",DICATTMN="(No range limit on date)" S DICATTLN=$$G(24)=1*5+7 S DICATT2N="D",DICATT3N="" S X=DICATT5N K DICATT5N S DICATT5N=X ;get rid of those damn subscripts CHNG I DICATT5N=DICATT5 K DICATTMN ;No DICATTMN means no change D:$D(DICATTMN) PUT^DDSVALF(98,"DICATT",1,DICATTMN) Q ; G(I) N X Q $$GET^DDSVALF(I,"DICATT1",2.1,"I","") DICATTD2 DICATTD2 ;SFISC/GFT-NUMERIC FIELD ;1/7/2009 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 11 ;Per VHA Directive 2004-038, this routine should not be modified. ; POST2 ;check NUMERIC N L,D,DD,Z,T S DD=$$G(34),D=$$G(33),Y=$$G(31) Q:Y="" S L=$$G(32) Q:L="" I L"_L_")!(X<"_Y_")"_Z_" X",DICATTLN=$L(L\1)+T-(T=1)+(L<0),DICATT2N="NJ"_DICATTLN_","_DD,DICATT3N="" CHNG I DICATT5N=DICATT5 K DICATTMN ;No DICATTMN means no change D:$D(DICATTMN) PUT^DDSVALF(98,"DICATT",1,DICATTMN) Q ; G(I) N X Q $$GET^DDSVALF(I,"DICATT2",2.2,"I","") DICATTD3 DICATTD3 ;GFT/GFT - Set of Codes ;09:06 AM 21 Jan 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Y(ORDER,CM) ; S Y=$P($P(DICATT3,";",ORDER),":",CM) Q C ; N C F C=":",";","=","""" I X[C D HLP^DDSUTL("SORRY -- '"_C_"' NOT ALLOWED IN SET VALUES!") K X Q Q ; POST3 ; N I,X,F K DDSBR,DDSERROR S F=$$GET^DDSVALF(1,"DICATT",1,"I","") ;we need FIELD LABEL to check total length of "0" node S DICATTLN=1,DICATT3N="" F X=35:2:59 S I=$$G(X) D I $D(DDSERROR) G ERROR .I I="" Q:$$G(X+1)="" S DDSERROR=1,DDSBR=X D H("THERE MUST BE A CODE FOR '"_$$G(X+1)_"'!") Q .I $D(F(I)) S DDSERROR=1,DDSBR=X D H("CAN'T HAVE TWO IDENTICAL CODES!") Q .S X(X)=I,F(I)="" .I $L(I)>DICATTLN S DICATTLN=$L(I) .S I=$$G(X+1) I I="" S DDSERROR=1,DDSBR=X+1 D H("'"_X(X)_"' MUST MEAN SOMETHING!") Q .I $L(DICATT3N)+$L(X(X))+$L(I)+$L(F)>235 S DDSERROR=1,DDSBR=X D H("TOO MUCH!! TO STORE THAT MUCH, BUILD A NEW FILE AND USE A POINTER!") Q .S DICATT3N=DICATT3N_X(X)_":"_I_";" S DICATT2N="S",DICATT5N="Q" S DICATTMN=$$GET^DDSVALF(98,"DICATT",1,"I","") ;says we have a change BRANCH I '$D(DICATTSC),DUZ(0)="@" S DICATTSC=3,DDSBR="65^DICATT SCREEN^6" Q D SCREEN Q ; G(I) N X Q $$GET^DDSVALF(I,"DICATT3",2.3,"I","") ; H(I) N X S X(1)=I,X(2)="$$EOP" D HLP^DDSUTL(.X) Q ; ERROR S DDSBR=DDSBR_"^DICATT3^2.3" Q ; SCREEN ; I DUZ(0)'="@" Q I $$S(66)]"" S DICATT5N(12.1)=$$S(66),DICATT5N(12)=$$S(67),DICATT2N="*"_DICATT2N Q ; S(I) Q $$GET^DDSVALF(I,"DICATT SCREEN",6,"I","") DICATTD4 DICATTD4 ;GFT/GFT - FREE TEXT FIELDS;14NOV2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PRE4 ;PATTERN MATCH default N I,Z,X,L,YY S DICATT5P=" X",YY=0,I=0,L=1,Y="",Z=$P(DICATT5,")!'(",2,99) Q:Z="" L S I=I+1,X=$E(Z,I) G L:X'?.P Q:X="" I X="""" S YY='YY G L G L:YY I X="(" S L=L+1 G L:X'=")" S L=L-1 G L:L S Y=$E(Z,1,I-1),DICATT5P=$E(Z,I+1,999) Q ; POST4 ;check FREE TEXT N L,A1,A2 S L=$$G(69) Q:L="" E S A1=$P($P(DICATT4,";",2),"E",2) I A1 S A2=$P(A1,",",2) I A2,A2-A1+1DICATTA&'$D(^DD(DE)) S Y=DE Q ; CHKDIC ; N % S %=$P(DICATTA,".") I XX!$D(^DD(X)) K X Q Q DICATTD6 DICATTD6 ;GFT/GFT - Computed Field;12:54 PM 21 Mar 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;78 = COMPUTED EXPRESSION ;79 = TYPE OF RESULT ;80 = NUMBER OF FRACTIONAL DIGITS ;81 = ROUNDED? ;82 = TOTALLING SUMS ;83 = LENGTH ;83.1 = POINT TO FILE ; VAL6 ;validate COMPUTED EXPRESSION (78) Q:X="" N A,DA,I,J,DQI,DICMX,DICM,DICOMP,DICOMPX,XSAVE S DQI="Y("_DICATTA_","_DICATTF_",",XSAVE=X D DICOMP I '$D(X) S DDSBR=78 D PUT^DDSVALF(78,,,DDSOLD) Q I DUZ(0)="@" K DQI S DQI(1)="TRANSLATES TO THE FOLLOWING CODE:",DQI(2)=X D HLP^DDSUTL(.DQI) S DICATT5=X,DICM=Y["m" F I=80:1:83 D UNED^DDSUTL(I,"DICATT6",2.6,DICM) ;If multiple, don't ask other questions D UNED^DDSUTL(83.1,"DICATT6",2.6,Y'["p") K DICATT5N M DICATT5N=X S DICATT5N(9)="^",DICATT5N(9.1)=XSAVE,DICATT5N(9.01)=DICOMPX ;remember all the stuff in DICATT5N array TYPE S DICATT2N=$S(Y["D":"D",Y["B":"B",1:"")_"C"_$S('DICM:$S(Y["B":"J1",1:"J"),1:"m"_$E("w",Y["w"))_$S(Y["p":"p"_$S($P(Y,"p",2):+$P(Y,"p",2),1:""),1:"") I DICATT2N="CJ" D ;may be numeric for TOTALLING .K DICOMPX .F Y=1:1 S %=$P(DICATT5N(9.01),";",Y) Q:'% S DICOMPX(1,+%,+$P(%,U,2))="S("""_%_""")" .Q:Y<2 I DICATT5'["/",DICATT5'["\" Q:DICATT5'["*"!(Y<3) .S DQI="Y(",X=XSAVE D DICOMP .I $D(X)=1 S DICATT5N(9.02)=X_" S Y=X" D CUNED(DICATT2N) ;Re-prompt TYPE D UNED^DDSUTL(82,"DICATT6",2.6,'$D(DICATT5N(9.02))) ;If no components, don't ask 'SUMS' question Q ; CUNED(S) ;also called by DICATTD D PUT^DDSVALF(79,"DICATT6",2.6,$$TYPE^DICATT3(S)) N DICUNED F DICUNED=18,3,4,6,7,8,98,99 D UNED^DDSUTL(DICUNED,"DICATT",1,1) ;Make 'MANDATORY?',etc. uneditable Q ; DICOMP S A=DICATTA,DA=DICATTF,DICOMPX="",DICOMP="I",DICMX="X DICMX" D IJ^DIUTL(A) D ^DICOMP Q ; ; BR79 ;branch from TYPE N A,S D UNED^DDSUTL(83.1,"DICATT6",2.6,X'["p") S A="" I X["p" S A=$P($G(DICATT2N),"p",2) S:'A A=$P(DICATT2,"p",2) S:A A=$P($G(^DIC(+A,0)),U) D PUT^DDSVALF(83.1,,,A) S S=X["D"!(X["B")!(X["m")!(X["p") F A=80:1:83 D UNED^DDSUTL(A,"DICATT6",2.6,S) I S D PUT^DDSVALF(A,,,"") ;for DATE, BOOLEAN POINTER, & MULTIPLE, don't ask other questions I $$G(79)="" D PUT^DDSVALF(83,,,8) ;default length of field=8 Q:X="N" F A=80,81,82 D PUT^DDSVALF(A,,,""),UNED^DDSUTL(A,"DICATT6",2.6,1) Q ; ; POST6 ;POST ACTION of Page 2.6 N T,I I $$G(82)=0 K DICATT5N(9.02) S T=$$G(79) F I="D","B","m","mp","p" I T=I S:T["p" T=T_$$G(83.1) S DICATT2N="C"_T G CHNGD S I="" I T="N" S I=$$G(80) ;if numeric, get fractional digits S DICATT2N="CJ"_$$G(83) ;length of field S T=" S X=$J(X,0," S DICATT5N=$S($D(DICATT5N)#2:DICATT5N,1:$P(DICATT5,T)) I I D .S DICATT2N=DICATT2N_","_I .I $$G(81) S DICATT5N=DICATT5N_T_I_")" CHNGD S DICATTMN="" D UNED^DDSUTL(20.5,"DICATT",1,1) ;don't ask multiple S DICATT4N=" ; " ;Computed Field is stored nowhere! Q ; G(I) Q $$GET^DDSVALF(I,"DICATT6",2.6,"I","") DICATTD7 DICATTD7 ;SFISC/GFT-POINTERS ;03:29 PM 15 Dec 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; POST7 ; N F S F=$$G(84) S DICATTMN=$G(^DD(DICATTA,DICATTF,3)) S DICATT2N="P",DICATT5N="Q",DICATTLN=9,DICATT2N="P"_F_$E("'",'$$G(85)) I F,$D(^DIC(F,0,"GL")) S DICATT3N=$P(^("GL"),U,2) BRANCH I '$D(DICATTSC),DUZ(0)="@" S DICATTSC=7,DDSBR="65^DICATT SCREEN^6" Q D SCREEN^DICATTD3 I $G(DICATT5N(12.1))]"" S DICATT5N=DICATT5N(12.1)_" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X" Q ; G(I) Q $$GET^DDSVALF(I,"DICATT7",2.7,"I","") DICATTD8 DICATTD8 ;SFISC/GFT;12:19 PM 13 Dec 2001;VARIABLE POINTER FIELDS ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; GET ; K DICATTVP F DA=0:0 S DA=$O(^DD(DICATTA,DICATTF,"V",DA)) Q:'DA I $D(^(DA,0)) D .F DR=1:1:6 S DICATTVP(DA,DR)=$P(^(0),U,DR) .I $G(^(1))]"" S DICATTVP(DA,7)=^(1) .I $G(^(2))]"" S DICATTVP(DA,8)=^(2) Q ; Y(I,J) ;defaults for Page 2.8 S Y=$G(DICATTVP(I,J)) Q ; PRE8 ;PRE-ACTION for Page 8 F I=1:1:5 D P(I) I $P($G(^DD(+$$GET^DDSVALF(DICATTVP+90,"DICATT8",2.8,""),0,"DI")),U,2)["Y" D PUT(3,"n"),UNED^DDSUTL(3,,,1,"") ;ARCHIVE File can't be LAYGO'd Q ; P(FLD) ; D PUT(FLD,$G(DICATTVP(DICATTVP,$$V(FLD)))) Q ; V(FLD) Q $E(24678,FLD) ;Field 1 is .02, etc ; DICS ; I DUZ(0)'="@" S DIC("S")="I Y-1.1 Q:'$L($G(^(0,""RD""))) I $TR(DUZ(0),^(""RD""))'=DUZ(0)" Q S DIC("S")="I Y-1.1" Q ; POST8 ;POST-ACTION for Page 8 N I,Y F I=1:1:5 S Y=$$GET^DDSVALF(I,"DICATTVP",8,"",""),DICATTVP(DICATTVP,$$V(I))=Y I DICATTVP(DICATTVP,7)="" S DICATTVP(DICATTVP,8)="" ;if no SCREEN, no EXPLANATION F I=1:1:5 D PUT(I,"") ;clean out the screen S DICATTLN=18 ;so 'IS THIS FIELD MULTIPLE' will be asked -- a V-P field can be expected to take up 18 bytes of storage Q ; G(I) Q $$GET^DDSVALF(I,"DICATT8",2.8,"I","") ; PUT(I,VAL) D PUT^DDSVALF(I,"DICATTVP",8,VAL,"I","") Q ; POSTVP ; N I,S,ERR D RECALL^DILFD(1,DICATTB_",",DUZ) ;we've looked up other files, so remember this one S DICATTMN="",DICATT2N="V",DICATT3N="",DICATT5N="" F I=91:1:97 S DICATTVP(I-90,1)=$$G(I) F I=91.1:1:97.1 S S=$$G(I) I S]""!$D(DICATTVP(I-90.1,3)) S DICATTVP(I-90.1,3)=S ;ORDER F I=0:0 S I=$O(DICATTVP(I)) Q:'I D I $D(ERR) Q .I '$G(DICATTVP(I,1)) K DICATTVP(I) Q .I $D(I(1,DICATTVP(I,1))) S ERR="DUPLICATE FILE NUMBER" Q .S I(1,DICATTVP(I,1))="" .I $G(DICATTVP(I,2))="" S ERR="MESSAGE REQUIRED" Q .I '$G(DICATTVP(I,3)) S ERR="ORDER NUMBER REQUIRED" Q .I $D(I(3,DICATTVP(I,3))) S ERR="DUPLICATE ORDER NUMBER" Q .S I(3,DICATTVP(I,3))="" .I $G(DICATTVP(I,4))="" S ERR="PREFIX REQUIRED" Q .I DICATTVP(I,4)["""" S ERR="BAD PREFIX" Q .I $D(I(4,DICATTVP(I,4))) S ERR="DUPLICATE PREFIX" Q .S I(4,DICATTVP(I,4))="" .S S=$G(DICATTVP(I,7))]"",DICATTVP(I,5)=$E("ny",S+1) .I S,$G(DICATTVP(I,8))="" S ERR="SCREEN MUST HAVE EXPLANATION" Q I '$D(ERR) Q S DDSBR=90+I,S(1)="ERROR IN VARIABLE-POINTER SPECIFICATIONS, FILE "_$G(DICATTVP(I,1)),S(2)=ERR,S(3)="$$EOP" D HLP^DDSUTL(.S) Q ; FILE ;come here from ^DICATTDE N I,DIK,DA F I=0:0 S I=$O(^DD(DICATTA,DICATTF,"V","B",I)) Q:'I K ^DD(+I,0,"PT",DICATTA,DICATTF) ;delete old POINTED-TOs K ^DD(DICATTA,DICATTF,"V") ;all other cross_references are with the subfile I $G(DICATT2N)'["V" Q ;stop now if field is no longer V-P! S DA=0 F I=1:1 S DA=$O(DICATTVP(DA)) Q:'DA D .S DICATTVP(DA,5)=$E("ny",$G(DICATTVP(DA,7))]""+1) .F DIK=1:1:6 S $P(^DD(DICATTA,DICATTF,"V",I,0),U,DIK)=$G(DICATTVP(DA,DIK)) .F DIK=7,8 I $D(DICATTVP(DA,DIK)) S ^(DIK-6)=DICATTVP(DA,DIK) S ^DD(DICATTA,DICATTF,"V",0)="^.12P^",DA(2)=DICATTA,DA(1)=DICATTF S DIK="^DD("_DICATTA_","_DICATTF_",""V""," D IXALL^DIK Q DICATTD9 DICATTD9 ;SFISC/GFT ;10:55 AM 26 Jan 2001;MUMPS FIELDS ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; 2 S DICATT2N="K",DICATT3N="" S DICATT5N="K:$L(X)>245 X D:$D(X) ^DIM",DICATTLN=245 S DICATTMN="Enter Standard MUMPS code" D CHNG D PUT^DDSVALF(7,,,"@","") ;no WRITE ACCESS Q ; CHNG I DICATT5N=DICATT5 K DICATTMN ;No DICATTMN means no change D:$D(DICATTMN) PUT^DDSVALF(98,"DICATT",1,DICATTMN) Q ; DICATTDD DICATTDD ;GFT/GFT - Multiple Fields;12:02 PM 8 Apr 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; MULMAKE(DICATTD,TYPE) ;DICATTD=sub-dictionary number, TYPE 1-9 ;only called from DICATTDE N F,DA,DIK,I,J,DIC S F=$$G(1),^DD(DICATTD,0)=F_" SUB-FIELD^^.01^1" S ^(0,"UP")=DICATTA,^("NM",F)="" S ^DD(DICATTD,.01,0)=F_"^^^0;1" I TYPE-5 D ;build a "B" x-ref unless this is a W-P multiple .S ^DD(DICATTD,.01,1,0)="^.1",^(1,0)=DICATTD_"^B" .S:+DICATT4S'=DICATT4S DICATT4S=""""_DICATT4S_"""" .S DIK=DICATT4S_",""B"",$E(X,1,30),DA)" .D IJ^DIUTL(DICATTA) S I=$O(I(""),-1) .F DA=I:-1:0 S DIK=I(DA)_$E(",",''DA)_"DA("_(I+1-DA)_"),"_DIK .S ^DD(DICATTD,.01,1,1,1)="S "_DIK_"=""""",^(2)="K "_DIK .I TYPE=8 S ^(3)="Required for Variable Pointer" S DA=.01,DA(1)=DICATTD,(DIC,DIK)="^DD("_DICATTD_"," D IX1^DIK S $P(^DD(DICATTA,DICATTF,0),U,2)=DICATTD ;K DICATT2N S ^DD(DICATTA,"SB",DICATTD,DICATTF)="" Q ; MULEDIT S G=$$G(1) I G="" G ^DICATTDK:$D(DICATTDK) S DDSBR=1,DDSERROR=1 Q S $P(^DD(+DICATT2,0),U)=G_" SUB-FIELD" K ^(0,"NM") S ^("NM",G)="" S DR=".01////"_G F X=5,7,8 D 0 DIE S DICATTED=1,DA=DICATTF,DA(1)=DICATTA,(DIC,DIE)="^DD(DICATTA," D ^DIE D FILEWORD^DICATTD0 Q ; 0 S T=$T(@X),G=$TR($$G(X),";") Q:G="@" S:G="" G="@" S DR=DR_$P(T,";",2,3)_"////"_G Q 5 ;;8 7 ;;9 8 ;;10 ; G(I) N X Q $$GET^DDSVALF(I,"DICATT MUL",10,"I","") DICATTDE DICATTDE ;GFT/GFT -- END screen edit;24MAY2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; LAYGODEF ;should user see 'ADDING NEW'? N % I DICATTF=.01,$G(^DD(DICATTA,0,"UP")) S Y=^("UP"),%=$O(^DD(Y,"SB",DICATTA,0)) I %,$P($G(^DD(Y,%,0)),U,2)["A" S Y="NO" Q S Y="YES" Q ; POST ;This is the DATA VALIDATION of the DICATT FORM N DICATT1N,DICATTM,DICATT4N,DICATT4S,DICATTED,X,T,G,DIC,DIE,DR,DA K DDSBR,DDSERROR I DICATT2 G MULEDIT^DICATTDD VP I $$G(20)=8 D POSTVP^DICATTD8 I $D(DDSBR) S DDSERROR=1,DDSBR=DDSBR_"^DICATT8^2.8" Q S DICATT1N=$$G(1) I DICATT1N="" G ^DICATTDK:$D(DICATTDK) S DDSBR=1,DDSERROR=1 Q I DICATT1N=$$G(2) S DDSERROR=1,DDSBR=1 D HLP^DDSUTL("NAME AND TITLE MUST BE DIFFERENT") Q I $G(DICATTLN) D I $D(DDSERROR) D HLP^DDSUTL("YOUR REDEFINITION OF THE FIELD WOULD CAUSE TOO MUCH DATA STORAGE!") Q .N W,DP,N,A,L,Y .S A=DICATTA,DP=DICATTF,W=$P(^DD(A,DP,0),U,4),Y=$P(W,";"),N=$P(W,";",2),T=0,L=DICATTLN Q:W="" .D MX^DICATT1 TOOMUCH .I $$MAX^DICATTDM(L-T,Y)>($G(^DD("STRING_LIMIT"),255)-4) S DDSERROR=1,DDSBR=20 NEW I DICATT4="",'$D(DICATT4N) D I $D(DDSERROR) D HLP^DDSUTL("DATA-STORAGE INFO INCOMPLETE") Q .I DICATTF=.001 S DICATT4N=" " Q .S G=$$G(20) I G=6 S DICATT4N=" ; " Q .I G=5!$$G(20.5) D Q:$D(DDSERROR) S DICATT4N=DICATTM(76)_";0" Q ;Note that we can $$GET the defaulted values for storage, even if user has not seen Pages 3 or 4 ..F T=76,76.1 S DICATTM(T)=$$GET^DDSVALF(T,"DICATTS",4,"","") I DICATTM(T)="" S DDSERROR=1,DDSBR="76^DICATTS^4" Q .S G=$$GET^DDSVALF(16,"DICATTM",3,"",""),T=$$GET^DDSVALF(17,"DICATTM",3,"","") .I G=""!(T="") S DDSERROR=1,DDSBR="16^DICATTM^3" Q .S DICATT4N=G_";"_T Q S X=^DD(DICATTA,DICATTF,0) D I $D(DDSERROR) D HLP^DDSUTL("FIELD DEFINITION IS TOO LONG!") Q ;Can't fit it into the zero node .S T=$L(DICATT1N)+$L($S($D(DICATT2N):DICATT2N,1:$P(X,U,2)))+$L($S($D(DICATT3N):DICATT3N,1:$P(X,U,3)))+$L($S($D(DICATT4N):DICATT4N,1:$P(X,U,4)))+$L($S($D(DICATT5N)#2:DICATT5N,1:$P(X,U,5,999))) .I T>($G(^DD("STRING_LIMIT"),255)-13) S DDSERROR=1 FILE ;Everything's good! We're gonna file it I $D(DICATT4N) S $P(^DD(DICATTA,DICATTF,0),U,4)=DICATT4N I DICATT4N'?.P S DICATT4S=$P(DICATT4N,";"),^DD(DICATTA,"GL",DICATT4S,$P(DICATT4N,";",2),DICATTF)="" ;new Piece 4 I $D(DICATTM),$D(DICATT4S) D Q ;make a MULTIPLE .N TYPE S TYPE=$$G(20) .D MULMAKE^DICATTDD(DICATTM(76.1),TYPE) WP .I TYPE=5 N DICATTA,DICATTF S:'$D(DICATT2N) DICATT2N="W" ;so we'll bounce back up from W-P multiple .S DICATTA=DICATTM(76.1),DICATTF=.01,DICATTMN="" D CHANGED ;make the .01 Field of the new multiple CHANGED S X=$E("R",$$G(18)) I DICATT2["R"'=$L(X)!$D(DICATTMN) D .S DICATTMN="" K ^DD(DICATTA,"RQ",DICATTF) I X["R" S ^(DICATTF)="" .I '$D(DICATT2N) S DICATT2N=$TR(DICATT2,"R") I DICATT2["W" S DICATT2N="W" .S DICATT2N=X_DICATT2N_$E("I",$G(DICATT2)["I") .S %=$P(DICATT2,"P",2) I % K ^DD(+%,0,"PT",DICATTA,DICATTF) ;remove old PT node .F %=DICATTA:0 S ^DD(%,0,"DT")=DT Q:'$D(^("UP")) S %=^("UP") Q:'$D(^DD(%)) .S %=$P(DICATT2N,"P",2) I % S ^DD(+%,0,"PT",DICATTA,DICATTF)="" COMPUTED .I DICATT2N["C" D ..N DICOMPX,A,DA ..S A=+$P(DICATT2,"p",2) I A,$D(^DD(A,0)) K ^(0,"PTC",DICATTA,DICATTF) ..S A=+$P(DICATT2N,"p",2) I A,$D(^DD(A,0)) S ^(0,"PTC",DICATTA,DICATTF)="" ..S (DA(1),A)=DICATTA,DA=DICATTF,DICOMPX=$G(DICATT5N(9.01)) K ^DD(A,DA,9.02) D ACOMP^DICATT3 .I DICATTF=.01 D ..I DICATTA=DICATTB D Q ...I $D(^DIC(DICATTA,0,"GL")),$D(@(^("GL")_"0)")) D UP2("",DICATT2N) ..S Y=$$GET^DDSVALF(2,"DICATTMUL",5,"I","") I Y?1N S DICATT2N=$E("M",Y=1)_DICATT2N ..S DR=$$GET^DDSVALF(1,"DICATTMUL",5,"I","") ..I $G(^DD(DICATTA,0,"UP")) S Y=^("UP"),%=$O(^DD(Y,"SB",DICATTA,0)) I Y,%,$D(^DD(Y,%,0)) D UP2(DR,DICATT2N) ;Reset the MULTIPLE field at the higher level .S $P(^DD(DICATTA,DICATTF,0),U,2)=DICATT2N PIECE3 .I $D(DICATT3N) S $P(^(0),U,3)=$G(DICATT3N) .I $D(DICATTVP) D FILE^DICATTD8 SCREEN S %=$$GET^DDSVALF(65,"DICATT SCREEN",6,"I",""),X=$P(^DD(DICATTA,DICATTF,0),U,2) I %=0!(%="NO")!(X'["P"&(X'["S")) K ^(12),^(12.1) F %=8:0 S %=$O(DICATT5N(%)) Q:'% S ^DD(DICATTA,DICATTF,%)=DICATT5N(%) I $D(DICATT5N)#2 S $P(^(0),U,5,99)=DICATT5N S DR="50////^S X=DT" F X=1:1:8 D 0 D DIE EGP ;K ^DD(DICATTA,DICATTF,.009) ;**CCO/NI WHEN FIELD CHANGES, KILL OFF ITS HELP TRANSLATIONS S DR="Q",X=98 D 0,DIE S DR="Q",X=99 D 0,DIE D FILEWORD^DICATTD0 MUMPS I $P(^DD(DICATTA,DICATTF,0),U,2)["K" S ^(9)="@" ;**151 AUDIT I $G(DICATT2)]"",$P(^(0),U,2)'=DICATT2,$G(^DD(DICATTB,0,"DIK"))]"" D EN2^DIKZ(DICATTB,"",^("DIK")) ;Recompile CROSS-REFS if auditing changes RESET D GET^DICATTD ;now that we have filed, the NEW is OLD, in case they keep editing! Q Q ; UP2(A,X) N T,Y ;A=0 if NO LAYGO X=SPECIFIER S Y=$P(^(0),U,2),Y=$TR(Y,"SDPV") F T="S","V","P","D" I X[T S Y=Y_T Q I A?1N S Y=$TR(Y,"A")_$E("A",DR=0) S $P(^(0),U,2)=Y Q ; 0 S T=$T(@X),G=$TR($$G(X),";") Q:G="@"!(G="^") S:G="" G="@" S DR=DR_$P(T,";",2,3)_"////"_G Q ;Re-file NAME, TITLE, etc. Delete if they are now gone. Leave "@" alone 1 ;;.01 2 ;;.1 3 ;;1.1 4 ;;1.2 5 ;;8 6 ;;8.5 7 ;;9 8 ;;10 98 ;;3 99 ;;4 ; DIE S DICATTED=1,DA=DICATTF,DA(1)=DICATTA,(DIC,DIE)="^DD(DICATTA," D ^DIE Q ; N ; S DA=DICATTF I $G(DDA(1))]"" S:$G(DICATTA) DDA(1)=DICATTA S:'$D(^DD(DDA(1),DA)) DDA="D" D AUDT^DICATTA I $D(DIU0) N DI D IJ^DIUTL(DICATTA),P^DICATT Q ; G(I) N X Q $$GET^DDSVALF(I,"DICATT",1,"I","") DICATTDK DICATTDK ;SFISC/GFT-DELETE FIELD ;25MAY2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;FROM ^DICATTDE KILL N M,DI,DA,DQ,DICL,D0,DIU,DQI,S,Q,O,X,DICATT4M I $D(DDA) S DDA="D" ;'DELETE' flag for Auditing S S=";",Q="""" MAYBGONE S (A,DA(1))=DICATTA,(D0,DA)=DICATTF I '$D(^DD(A,DA)) Q D IJ^DIUTL(A) S DICL=$O(J(""),-1),DQ="" F S DQ=$O(^DD(0,.01,"DEL",DQ)) Q:DQ="" I $D(^(DQ,0)) X ^(0) I S DDSERROR=1,DDSBR=1 H 3 G Q ;Delete checks S O=^DD(A,D0,0),M=$P(O,U),X=0 F S X=$O(^DD(A,DA,1,X)) Q:'X I +^(X,0)=DICATTB,$P(^(0),DICATTB,2)?1"^"1.A S DQI=$P(^(0),U,2) ;HMMMMM remember that this field cross-referenced top level MUL I $G(DICATT2) D ;Delete a multiple field .K ^DD(A,"GL",$P($P(O,U,4),";")) ;SO EN+4^DICATT4 KNOWS TO DELETE THE ENTRIES CORRECTLY .S DQ(+DICATT2)=0 NEW .S DICATT4M(0)=$NA(^DD(A,D0)) ;from NEW^DICATTD4 .S DICATT4M("SB")=$NA(^DD(A,"SB",+$P(O,U,2),D0)) .S ^DD(A,D0,0)=O,^DD(A,"SB",+$P(O,U,2),D0)="" .D ^DICATT4 .K @DICATT4M(0),@DICATT4M("SB") .D KDD^DICATT4 ;Kill the DD globals below ENTRIES E I $P(O,U,2)'["C"," "'[$P(O,U,4) S DICATT4M=1 D ^DICATT4 D DELFLD(DICATTA,DICATTF) D N^DICATTDE Q Q ; DELFLD(DICATTA,DA) ;ALSO FROM ^DICATTD W $C(7),!,"FIELD DELETED!" S:$D(DDA) DDA=$E("D",DDA="") N A,D0,DIC,DIK,O,M S (DIC,DIK)="^DD(DICATTA,",DA(1)=DICATTA,DA=DICATTF AUD S:$D(DDA) ^UTILITY("DDA",$J,DICATTA,DA,0)=$G(^DD(DICATTA,DA,0)) D ^DIK Q ; ; ; ; POST9 ;POST-ACTION OF FIELD 99, 'ARE YOU SURE YOU WANT TO DELETE THE ENTIRE FIELD?' I 'X D Q ;IF THEY DON'T ANSWER "YES", REPAINT FIELD LABEL AND QUIT .S X=$P(^DD(DICATTA,DICATTF,0),U) .I $G(DICATT2) D PUT^DDSVALF(1,"DICATT MUL",10,X) Q .D PUT^DDSVALF(1,"DICATT",1,X) S DICATTDK=1,DDACT="EX" ;FORCE EXIT FROM SCREENMAN D REQ^DDSUTL(20,"DICATT",1,0) NOREQ ;(not sure anyone uses this entry point yet) D REQ^DDSUTL(67,"DICATT SCREEN",6,0) D REQ^DDSUTL(31,"DICATT2",2.2,0) D REQ^DDSUTL(32,"DICATT2",2.2,0) D REQ^DDSUTL(68,"DICATT4",2.4,0) D REQ^DDSUTL(69,"DICATT4",2.4,0) D REQ^DDSUTL(78,"DICATT6",2.6,0) Q ; DICATTDM DICATTDM ;GFT/GFT - SUBSCRIPT AND PIECE-POSITION FOR STORAGE OF SINGLE-VALUED DATA IN SCREENMAN ;16JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; SUBDEF ;EXECUTABLE DEFAULT for FIELD 16 (SUBSCRIPT) S Y=$O(^DD(DICATTA,"GL",""),-1) ;find the highest subscript now used for storage of this File's data I $$CHKSUB(Y,1) Q NXT I Y S Y=Y+1 Q ;get a new subscript F Y=+$O(^DD(DICATTA,"GL","A"),-1):1 Q:'$D(^(Y)) Q ; PIECDEF ; I $E($G(DICATT2N))="K" S Y="E1,245" Q S Y=$$G(16) I Y]"" S Y=$$P(Y) Q ; P(Y) ;given SUBSCRIPT Y, return PIECE prompt N P,X,% S X=0,%=1,P=0 PC S X=$O(^DD(DICATTA,"GL",Y,X)) I X'="" S P=$P(X,",",2),%=$S(%>P:%,1:P+1) G PC I P S %="E"_%_","_(DICATTLN+%-1) E S %=$O(^(99999),-1)+1 Q % ; SUBHELP ; S Y=$E($G(DICATT2N))="K" D UNED^DDSUTL(17,"DICATTM",3,Y) N X,Y,T S X(1)="Enter name of MUMPS Global subscript where this Field's data will be stored." S X(2)="Already assigned:" S Y="",T=3 F S Y=$O(^DD(DICATTA,"GL",Y)) Q:Y="" S X(T)=$G(X(T))_$J(Y,9) I $L(X(T))>66 S T=T+1 D HLP^DDSUTL(.X) Q ; CHKSUB(X,DISHORT) ;used as INPUT TRANSFORM for Fields 16 (SUBSCRIPT) & 76 (MUL SUBSCRIPT) X is the subscript name. DISHORT says 'don't go beyond 250' N M S M=$$GET^DDSVALF(20.5,"DICATT",1,"","") ;'Is this field Multiple?' I $D(^DD(DICATTA,"GL",X)),M Q "Another Field is already stored at '"_X_"'" I $D(^(X,0)) Q "A multiple field is already stored at '"_X_"'" I '$G(DICATTLN) Q 1 ;if we do not have a current length for the field, we are OK S M=$S($G(DISHORT):250,1:$G(^DD("STRING_LIMIT"),255)-5) I $$MAX(DICATTLN,X)>M Q "Too much to store at the '"_X_"' subscript" Q 1 ; MAX(L,Y) ;given L=length of new data, Y=subscript name N T,A,DP,N,W S A=DICATTA,DP=DICATTF D MAX^DICATT1 Q T ;returns maximum length of subscript's data ; CHKPIEC(P) ; N N,S S S=$$G(16) I S="" Q S ;must have subscript I P?1"E"1.N1","1.N S N=$P(P,",",2)-$E(P,2,9)+1 G USED:N'<$G(DICATTLN) Q "Can't be less than "_DICATTLN I P>0,P<100,P?.N,+P=P G USED Q "" USED I $D(^DD(DICATTA,"GL",S,P)) Q "Already used for '"_$P(^DD(DICATTA,$O(^(P,0)),0),U)_"'" I P["E",$O(^(0)) Q "Can't store by $EXTRACT in the same subscript with $PIECES" Q 1 ; PIECHELP ; N X,G,Y,P,T S X(1)="Type a number from 1 to 99" S G=$$G(16) Q:G="" I '$D(^DD(DICATTA,"GL",G)) S X(1)=X(1)_" or an $EXTRACT range such as ""E2,4""." Q S X(1)=X(1)_".",X(2)="Currently assigned: ",Y="",T=2 F S Y=$O(^DD(DICATTA,"GL",G,Y)) Q:Y="" S P=$O(^(Y,0)) I $D(^DD(DICATTA,P,0)) S X(T)=$G(X(T))_$J(Y,7) I $L(X(T))>66 S T=T+1 D HLP^DDSUTL(.X) Q ; POST ;POST-ACTION of Page 3 N % S %=$$CHKPIEC($$G(17)) I '% S DDSBR=% K % S %(1)=DDSBR,DDSBR=16 D H(.%) Q ; H(%) S %($O(%(""),-1)+1)="$$EOP" D HLP^DDSUTL(.%) Q ; G(I) Q $$GET^DDSVALF(I,"DICATTM",3,"","") DICD DICD ;SFISC/XAK-DISP,SELECT,DELETE,EDIT XREF ;11:26 AM 18 Aug 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K DICD S (DA,DL)=+Y D CHIX I 'DQ D ^DICE G Q D RD G:$D(DIRUT) Q I Y["C" D ^DICE G Q I Y["E" D EDT^DICE G Q D DEL G Q ; DEL I DH(DQ,4) D R Q:'$D(DICD) S DQ=DICD I $D(DH(DQ,3)) W !?5,$C(7),"This cross-reference cannot be deleted.",! Q ASK S %=2 W !,"Are you sure that you want to delete the CROSS-REFERENCE " D YN^DICN Q:(%<0)!(%=2) I %=0 W !?7,"Answer YES if you want to delete the Cross-Reference." G ASK W !," ...OK",! K:I["SOUNDEX" ^DD(DI,0,"LOOK"),^("QUES") S ^DD(J(N),DL,1,0)="^.1",X=^(DQ,2),Y=$P(I,U,2) I Y?1A.E,+I=J(0),I'["MNEM",I'["MUM" K @(I(0)_"Y)") G DDD G DDD:X="Q"!$F(I,"BUL") I $P(I,U,3)]"",I'["MUM",I'["TRIG" D DD G DDD S %=1 W "DO YOU WANT THE INDIVIDUAL CROSS-REFERENCE VALUES DELETED" D YN^DICN Q:%<1 D DD:%=1 DDD I $D(DDA) S DDA="D" D XA^DICATTA S DIK="^DD(J(N),DL,1,",DA(1)=DL,DA(2)=J(N),DA=DQ D ^DIK K DIK,DA S DA=DL D DIEZ^DIU0 D I $D(^DD(J(0),0,"DIK")) S X=^("DIK"),Y=J(0),DMAX=^DD("ROU") D EN^DIKZ Q ; CHIX ; K DH S DQ=0,X="CURRENT CROSS-REFERENCE" F Y=0:1 S DQ=$O(^DD(DI,DA,1,DQ)) Q:DQ'>0 S DH(DQ)=^(DQ,0),DH(DQ,4)=Y S:$D(^(3)) DH(DQ,3)=^(3) W !! I 'Y S DQ=0 W "NO ",X Q I Y=1 W X_" IS " S DQ=$O(DH(0)) D L Q:'$D(DICD) S %=2 W !,"WANT TO "_DICD_" IT" D YN^DICN S:%=-1 DICDF=1 S:%=1 DICD=DQ Q D M Q:'$D(DICD) S %=2 W !,"WANT TO "_DICD_" ONE OF THEM" D YN^DICN Q:%-1 R R !,"WHICH NUMBER: ",X:DTIME Q:U[X I X\1'=X!'$D(DH(X)) D M G R S DICD=X,I=DH(X) Q M W !,"CURRENT CROSS-REFERENCES:" F J=0:0 S J=$O(DH(J)) Q:J'>0 W !?8,J,?14 S DQ=J D L Q ; L S I=DH(DQ),X=$P(I,U,3) S:X="" X="REGULAR" W X G E:X["BULL" I X["TRIGGER" S %=+$P(I,U,4),(%F,Y)=+$P(I,U,5) W " OF " D WR^DIDH:$D(^DD(%,Y,0)),N Q W " '",$P(I,U,2),"' INDEX OF " I +I=J(0) W "FILE" W:'$T $P(^DD(+I,0),U) N W:$D(DH(DQ,3)) !?14,"("_DH(DQ,3)_")" Q ; E F %="CREA","DELE" S %=%_"TE VALUE" I $D(^DD(DI,DA,1,DQ,%)),^(%)'="NO EFFECT" W " ("_^(%)_")" D N Q ; DD ; N DIKJ,DA,DV,DH,Y,DCNT,DIK S DIKJ=$J K ^UTILITY("DIK",$J) S J=J(N),^($J)=$H,^($J,J,DL,1)=X,Y=$P(^DD(DI,DL,0),U,4),^UTILITY("DIK",$J,J,DL)=$P(Y,";",1),Y=$P(Y,";",2),^(DL,0)="S X=$"_$S(Y:"P(^(X),U,"_Y_")",1:"E(^(X),"_+$E(Y,2,9)_","_$P(Y,",",2)_")") I $D(^DD(J,DL,1,DQ,"DIK")) S ^UTILITY("DIK",$J,J,DL,1)="D RCR",^(1,0)=X K Y,DA,DV,DH S DH(1)=J(0) F Y=1:1:N S DV(J(Y-1),1)=I(Y),DV(J(Y-1),1,0)=J(Y) D WAIT S DIK=DIU,DA=0,DCNT=0 G CNT^DIK1 ; KOLD K DIR S DIR(0)="Y",DIR("A")="DO YOU WANT TO EXECUTE THE OLD KILL LOGIC NOW",DIR("?",1)="Enter 'YES' to execute the original kill logic now.",DIR("?")="Otherwise, enter 'NO'." D ^DIR K DIR I 'Y!$D(DIRUT) K DTOUT,DUOUT,DIRUT,DIROUT Q N DA W !!,"Executing old kill logic...",! S X=A1(2) D DD Q WAIT ; W !,"..." W $P("HMMM^EXCUSE ME^SORRY","^",$R(3)+1),", ",$P("THIS MAY TAKE A FEW MOMENTS^LET ME PUT YOU ON 'HOLD' FOR A SECOND^HOLD ON^JUST A MOMENT PLEASE^I'M WORKING AS FAST AS I CAN^LET ME THINK ABOUT THAT A MOMENT","^",$R(6)+1)_"..." Q ; RD ; N DQ,DH W ! S DIR(0)="SAO^E:EDIT;D:DELETE;C:CREATE",DIR("A")="Choose E (Edit)/D (Delete)/C (Create): " S DIR("?",1)="Enter 'E' to edit an existing X-reference",DIR("?",2)=" 'D' to delete it",DIR("?")=" 'C' to create a new X-reference." D ^DIR K DIR Q ; Q D Q^DICE K DICD,DDA Q DICE DICE ;SFISC/GFT-CREATE AN XREF ;17DEC2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S %=2,DCOND="CROSS-REFERENCE" W !,"WANT TO CREATE A NEW ",DCOND," FOR THIS FIELD" D YN^DICN G Q:%-1 N F DQ=1:1 Q:'$D(^DD(DI,DA,1,DQ)) W !,"CROSS-REFERENCE NUMBER: "_DQ_"// " R X:DTIME S:'$T DTOUT=1 G Q:'$T S:X="" X=DQ G NQ:X'?.N!'X,X:$D(^(X)) S DQ=X S DH=0,DIC="^DOPT(""DICR"",",DIC(0)="EQA",DIC("B")=1,DIC("S")="I 1"_$P(",Y-4",U,DUZ(0)'="@")_$P(",Y-5",U,$D(^DD(J(N),0,"LOOK"))>0)_$P(",Y-7",U,'$D(^XMB(3.6))) S:$P($G(^DD($$FNO^DILIBF(J(N)),0,"DI")),U)="Y" DIC("S")=DIC("S")_",Y-4,Y-6,Y-7" D ^DIC K DIC D QQ S Y=+Y G X:Y<0,6^DICE0:Y=6,^DICE7:Y=7 ;1=REGULAR 2=KWIC 3=MNEMONIC 4=MUMPS 5=SOUNDEX 6=TRIGGER 7=BULLETIN G A:'N W !,"WANT TO ",DCOND," WHOLE FILE BY THIS FIELD" D YN^DICN G X:%<1 I %=1 S DH=N G A F DH=N-1:-1 Q:'DH S %=1 W !,"WANT TO "_DCOND_" "_$P(^DD(J(N-DH),0),U,1)_" BY THIS FIELD" D YN^DICN G X:%<1,A:%=1 A S %=1,DIK="" I Y=1!(Y=4) W !,"WANT ",DCOND," TO BE USED FOR LOOKUP AS WELL AS FOR SORTING" D YN^DICN G X:%<1 I %=2 S DIK="A" I Y=2 S DIKWIC="(,.?! '-/&:;)" W !,"PARSE ON THE FOLLOWING CHARACTERS: ",DIKWIC,"//" R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T S:X]"" DIKWIC=X I X["""" S X="?" I Y=2,X]"",X'?1P.P!(X?1"?"."?") W !?5,"Please enter the punctuation marks (except quotes) which will be used to ",!?5,"separate the words in this field." G A I Y=3 F I=0:0 S I=$O(^DD(J(N-DH),.01,1,I)) G X:I=""!(DL=.01&'DH) I $D(^(I,0)) S DE=$P(^(0),U,2) G CKF:DE?1U.UN I Y=4 D M G:$D(DIRUT) Q S:$D(XX(1)) X(1)=XX(1) S:$D(XX(2)) X(2)=XX(2) K XX ;GFT MODIFIED NEXT 6 LINES: INDEX MUST BE UPPER-CASE, START WITH PROPER LETTER, AND NOT BE A DUPLICATE N DISTART S DISTART=$S(Y-1&(Y-3)!(DA-.01):67,1:66) ;START WITH "B" OR "C" IX F X=DISTART:1 S DE=DIK_$C(X) D I $D(DE) G CKF:DUZ(0)'="@" W !,"INDEX: ",DE,"// " R X:DTIME S:'$T DTOUT=1 S:X]"" DE=X G Q:X[U!'$T D G IX:'$D(DE) Q .I $D(^DD(J(N-DH),0,"IX",DE))!$D(^DD("IX","BB",J(N-DH),DE)) K DE Q ;SUBROUTINE CALLED TWICE! KILLS 'DE' IF NO GOOD CAN'T ALREADY EXIST .I DE'?1U.UN K DE Q .I DIK="A" K:DE'?1"A".E DE Q .E I DE?1"A".E K DE CKF W !,"..." S DREF=Y D ^DICE0 W ! D DSC,DIEZ^DIU0,F G Q ; F S X=^DD(J(N),DA,1,DQ,1),%=1 I DREF=1!(DREF=4)!$D(^("CONDITION")),@("$O("_DIU_"0))>0") D G:'% F . W !!,"DO YOU WANT TO CROSS-REFERENCE EXISTING DATA NOW" . S %=0 D YN^DICN Q:% . W !!,"Enter 'YES' to execute the new set logic now." . W !,"Otherwise, enter 'NO'." D DD^DICD:%=1 I $D(DDA),DDA="" S DDA="N" D XA^DICATTA K % Q ; M N Y,DQ F I=1,2 S DIR(0)=".1,"_I D Q:$D(DTOUT)!$D(DUOUT) . F D ^DIR Q:$D(DTOUT)!$D(DUOUT) I X]"" S XX(I)=X Q K DIR Q ; Q D QQ K DE,DB,DREF,DCOND,DICOMPX,I,DQ,DA,DH,DIK,DIC,N,DL,J,X,Y,A,XX Q ; EDT ; I DH(DQ,4) D R^DICD Q:'$D(DICD) S DQ=DICD I $D(DDA) S DDA="E" D XS^DICATTA W ! F A0=1:1:2 S A1(A0)=^DD(J(N),DA,1,DQ,A0) S A0=DI,DR=$S(DUZ(0)="@"&($P(DH(DQ),U,3)["MUMPS"):"1:3;10;666",DUZ(0)="@"&($P(DH(DQ),U,3)]""):"3;10;666",1:"3;10") D ED ;NOREINDEX PATCH 167 F A0=1:1:2 I A1(A0)'=^DD(J(N),DA,1,DQ,A0) S ^("DT")=DT,DREF=4 D DIEZ^DIU0,KOLD^DICD,F,D^DICD Q K A0,A1 I $D(DDA) D XA^DICATTA Q ; ED S:$D(DA(1))#2 A1(3)=DA(1) S DICD=DL,DA(2)=A0,DA(1)=DA,DA=DQ,DIE="^DD("_DA(2)_","_DA(1)_",1," D DIE K DIE,DR S DL=DICD,DQ=DA,DA=DA(1) S:$D(A1(3)) DA(1)=A1(3) K DICD Q ; DIE N J,N,DI,A1 D ^DIE Q DSC S A0=J(N),DR="3;4///"_DT_";10" D ED K A0 Q ; NQ I X'[U D HLP G N X W $C(7),"??" G Q ; QQ K ^UTILITY("DICE",$J),DBOOL,DLAY,DQI,DICOMPX,DIN,DCNEW,DFLD,DREF,DENEW,DLOC,DSUB,DHI,DOLD,DNEW,%X,V Q HLP ; Traditional Cross Reference Help - Called From NQ ; SF-CIOFO/SO 1/12/00 W ! W !,?5,"You may use the number shown if you are the custodian of the file this" W !,?5,"cross-reference is in. If you are not the custodian of the file, you" W !,?5,"should select a number that corresponds with a numberspace for which you" W !,?5,"have custody. Questions regarding numberspace custody may be referred" W !,?5,"to: DBA@FORUM.VA.GOV",! Q DICE0 DICE0 ;SFISC/GFT,XAK-XREF'S ;5/24/94 2:21 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S ^DD(J(N),DA,1,0)="^.1",^(DQ,0)=J(N-DH)_U_DE,X=I(0) F Y=N:-1:DH+1 S X=X_"DA("_Y_"),"_I(N+1-Y)_"," S X=X_""""_DE_""",",Y=",DA)" F %=1:1:DH S Y=",DA("_%_")"_Y D @DREF ;I DE'="B" K DICOMPX S DE(0)=Y(0) D COND^DICE4 S Y(0)=DE(0) I $D(DCOND) S ^(1)=X_" I X S X=DIV "_^DD(J(N),DA,1,DQ,1),^(2)=X_" I X S X=DIV "_^(2),^("CONDITION")=DCOND(0) S DIK="^DD(J(N),",DA(1)=J(N) D IX1^DIK I $D(^DD(J(0),0,"DIK")) S X=^("DIK"),Y=J(0),DMAX=^DD("ROU") D EN^DIKZ Q ; 1 S Y="$E(X,1,30)"_Y,^(2)="K "_X_Y S ^DD(J(N),DA,1,DQ,1)="S "_X_Y_"=""""" Q ; 2 S ^(0)=^(0)_"^KWIC",^(1)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2,^DD(""KWIC"")'[I S "_X_"I"_Y_"=""""" S ^(2)="S %1=1 F %=1:1:$L(X)+1 S I=$E(X,%) I """_DIKWIC_"""[I S I=$E($E(X,%1,%-1),1,30),%1=%+1 I $L(I)>2 K "_X_"I"_Y K DIKWIC Q ; 3 D 1 S ^(1)="S:'$D("_X_Y_") ^(DA)=1",^(2)="I $D("_X_Y_"),^(DA) K ^(DA)",^(0)=^(0)_"^MNEMONIC" Q ; 4 S ^(0)=^(0)_"^MUMPS",^(1)=X(1),^(2)=X(2) K X Q ; 5 S ^(0)=^(0)_"^SOUNDEX",X=X_"X_I"_Y,Y="S I=$E(X,1,27) D SOU^DICM ",^(1)=Y_"S "_X_"=""""",^(2)=Y_"K "_X,(^DD(J(N),0,"LOOK"),^("QUES"))="SOUNDEX" Q ; 6 ; D ^DICE1 G Q:U[X S ^UTILITY("DICE",$J,0)="^^TRIGGER^"_DIN_U_DENEW,^("FIELD")=DCNEW F DIK=1,2 D ^DICE2 G M^DICATT:$D(DTOUT),Q:U=X I '$D(^DD(DIN,DENEW,9))!($G(^(9))="") S %=2 W !!,"WANT TO PROTECT THE '",DNEW,"' FIELD, SO THAT",!,"IT CAN'T BE CHANGED BY THE 'ENTER & EDIT' ROUTINE" D YN^DICN G QQ:%<0 S:%=1 ^(9)=U ; X ; S DA=DL,%Y="^DD("_DI_","_DL_",1,"_DQ_",",%X="^UTILITY(""DICE"",$J," I @("$O("_%Y_"0))>0") W $C(7),!!,"HEY, WHILE WE WERE TALKING, SOMEONE ELSE CREATED CROSS-REFERENCE #"_DQ_"!!!" G Q D %XY^%RCR,DSC^DICE,DIEZ^DIU0 I $D(DDA) S DDA="N" D XA^DICATTA D:$D(^DD(J(0),0,"DIK")) D^DICD D QQ S DIK="^DD("_DI_","_DL_",1,",(DA,DREF)=DQ,DA(1)=DL,DA(2)=DI,@(DIK_"0)=U_.1") D IX1^DIK W !,"...CROSS-REFERENCE IS SET" S %=2 I @(DIK_DREF_",1)'=""Q"""),@("$O("_DIU_"0))>0") W !!,"DO YOU WANT TO RUN THE CROSS-REFERENCE FOR EXISTING ENTRIES NOW" D YN^DICN I %=1 S X=^DD(DI,DL,1,DQ,1) D DD^DICD Q G Q^DICE QQ G QQ^DICE DICE1 DICE1 ;SFISC/XAK-TRIGGER LOGIC ;10:24 AM 9 Jul 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FIELD S %=DI,%F=DL,DOLD=$P(^DD(DI,DL,0),U) W !!,"WHEN THE " D WR^DIDH R "IS CHANGED,",!,"WHAT FIELD SHOULD BE 'TRIGGERED': ",X:DTIME Q:U[X I X?1."?" S DIC="^DD("_DI_",",DIC(0)="QE",DIC("S")="S %=$P(^(0),U,2) I %'[""C""&(%'[""W"")",DIC("W")="W:$P(^(0),U,2) "" (multiple)""" D ^DIC K DIC G FIELD F %=0:0 S %=$F(X," IN ") Q:'% S X=$E(X,1,%-5)_":"_$E(X,%,999),%=$F(X," FILE") S:% X=$E(X,1,%-6)_$E(X,%,999) F %=99:0 S %=$O(I(%)) Q:%="" K I(%),J(%) S %=-1,DCNEW=X,DICOMP="SW?",X="INTERNAL("_$P(X,":")_")"_$S($F(X,":"):":",1:"")_$P(X,":",2,99) D DA,DICOMP I '$D(X) S X=DCNEW,DICOMP="SW?" D DICOMP F %=9.2:.1 Q:'$D(X(%)) S ^UTILITY("DICE",$J,%+80)=X(%) I '$D(X)!'DICOMPX W !," ...",I,$C(7),!,"YOU MUST IDENTIFY SOME FIELD, EITHER WITHIN THE",!,"'",@("$P("_DIU_"0),U)"),"' FILE OR IN SOME OTHER" G FIELD S DFLD=X,DENEW=+$P(DICOMPX,U,2),DIN=+DICOMPX,DREF="",DLAY=Y["L" K X F X=Y\100*100:-100:0 F %=X:1 Q:'$D(J(%)) G CK:J(%)=DIN W $C(7),!,"SORRY, I AM CONFUSED" G FIELD CK I DENEW=.001 W $C(7),!,"CAN'T UPDATE A 'NUMBER' FIELD!" G FIELD I DENEW=DL,DIN=DI W $C(7),!,"CAN'T HAVE A FIELD TRIGGERING ITSELF!!!" G FIELD S DIFILE=J(X),DIAC="DD" D ^DIAC I '% W $C(7),!,"YOU DON'T HAVE 'DATA DEFINITION' ACCESS TO",!," THE '",$O(^DD(J(X),0,"NM",0)),"' FILE!" G FIELD I $P($G(^DD(J(X),0,"DI")),U,2)["Y" W $C(7),!,"CAN'T TRIGGER A RESTRICTED"_$S($P(^("DI"),U)["Y":" (ARCHIVE)",1:"")_" FILE!" G FIELD F X=X:1 S %=X#100,DREF=DREF_I(X)_$E(",",1,%)_"DIV("_%_"),",A=X S:$S('$D(J(%)):1,1:J(%)-J(X))&'$D(DICOMPX(0,J(X))) ^UTILITY("DICE",$J,"DIC")="LOOKUP" Q:J(X)=+DICOMPX!'$D(I(X+1)) S DLOC=$P(^DD(DIN,DENEW,0),U,4),DSUB=$P(DLOC,";"),DLOC=$P(DLOC,";",2),DNEW=$P(^(0),U) S:+DSUB'=DSUB DSUB=""""_DSUB_"""" I $P(^(0),U,2)["C" W !,$C(7),"CAN'T TRIGGER A COMPUTED FIELD!" G FIELD W " ...OK" K DIFILE,DIAC Q ; DA S DA="^DD("_DI_","_DL_",1,"_DQ_","_8 Q ; DICOMP ; S DICOMPX="",DICOMPX(0)="DIV(",DQI="Y(" G ^DICOMP ; DICE2 DICE2 ;SFISC/GFT-TRIGGER LOGIC ;09:41 AM 10 Jul 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q:$D(DTOUT) W !!!,"---",$P("SET^KILL",U,DIK)," LOGIC---" S DA="^DD("_DI_","_DL_",1,"_DQ_","_(DIK+3) C K DICOMPX,DATE S:DOLD=DNEW DNEW="TRIGGERED "_DNEW S DNEW=$E(DNEW,1,30),DICOMPX(DNEW)="DIU",DICOMPX(DNEW,U)=DIN_U_DENEW,DCOND="SET" S:$P(^DD(DIN,DENEW,0),U,2)["D" DICOMPX(DNEW,"DATE")=1 W !!,"IN ANSWERING THE FOLLOWING QUESTION, '"_DNEW_"'",!?2,"CAN BE USED TO REFER TO THE EXISTING TRIGGERED FIELD VALUE.",! S DICOMP="?",DICOMPX="",%=DIN S:DIK=1 DICOMPX(1,DI,DL)="DIV" D OLD W "PLEASE ENTER AN EXPRESSION WHICH WILL BECOME THE VALUE OF THE",! S %F=DENEW D WR^DIDH D GET Q:U[X I X="""@""" K X G DICE2^DIQQ I X="@" S X="S X=""""" E D ^DICOMP G DICE2^DIQQ:'$D(X) F %=9.2:.1 Q:'$D(X(%)) S ^UTILITY("DICE",$J,DIK+3*10+%)=X(%) K DICOMPX(DNEW) I X="S X=""""" S DE=X,DCOND="DELE" D DEL^DICE3 G Q:X=U,^DICE4:DENEW-.01 F X=0:1 G D01:'$D(J(X)) I J(X)=DIN W $C(7),!,"BUT THE TRIGGERING FIELD DEPENDS ON THE TRIGGERED FIELD!" S X=U G Q S DE="S X=DIV "_X,%=$P(^DD(DIN,DENEW,0),U,2) I %["D",'Y["D" W $C(7),!,"WARNING -- THIS SHOULD PRODUCE A DATE VALUE, AND IT MAY NOT!" S V=$P(%,"P",2) I V,DICOMPX-V!($P(DICOMPX,U,2)-.001) W !,$C(7),"WARNING -- THIS MUST BE '",$P(^DIC(+V,0),U)," NUMBER'!" I Y["B" W $C(7),!,"WARNING--THIS TRUTH-VALUED EXPRESSION WILL PRODUCE ONLY VALUES OF '0' OR '1'" I %'["D",Y["D" W $C(7),!,"WARNING -- THIS MAY PRODUCE A 'DATE', AND IT SHOULDN'T!" D ^DICE3 G ^DICE4:X'=U Q Q ; OLD ; I DIK=2 S X=$E("OLD "_DOLD,1,30),DICOMPX(X)="X",DICOMPX(X,U)=DI_U_DL W ?2,"NOTE: '"_X_"' CAN BE USED TO REFER TO THE VALUE OF THE",!?2,DOLD_" FIELD BEFORE ITS CHANGE OR DELETION.",! S:$P(^DD(DI,DL,0),U,2)["D" DICOMPX(X,"DATE")=1 Q ; D01 S V=DREF,X=$L(V)-1 F %=X:-1 I "(,"[$E(V,%) S DHI=$E(V,%+1,X) I DHI'?1N1")" S V=$E(V,1,%),X=0 Q DQ S X=$F(V,"""",X) I X>0 S V=$E(V,1,X-1)_""""_$E(V,X,999),X=X+2 G DQ S X="I "_DHI_">0 N DIK S DIK(0)=DA,",V="DIK="""_V_""",",DHI="DA="_DHI_" D ^DIK",DTAG="S DA=DIK(0)" F %=1:1:N S X=X_"DIK("_%_")=DA("_%_"),",DTAG=DTAG_",DA("_%_")=DIK("_%_")" F %=1:1:A#100 S DHI="DA("_%_")=DIV("_(A#100-%)_"),"_DHI S X=X_V_DHI,^UTILITY("DICE",$J,"DIK")="DELETE" G F^DICE4 ; GET ; W !," WHENEVER THE '"_DOLD_"' FIELD IS "_$P("ENTERED OR CHANGED^CHANGED OR DELETED",U,DIK) R ": ",X:DTIME S:'$T X=U S Y=X I X="" S Y="NO EFFECT",^UTILITY("DICE",$J,DIK)="Q" W " ",Y I DIK=2,^UTILITY("DICE",$J,1)="Q" W $C(7),"??" S X=U S ^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE VALUE")=Y DICE3 DICE3 ;SFISC/GFT-TRIGGER LOGIC ;8/14/89 12:37 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. G DIU:DIK=1 ; DEL ; G DIU:'DLAY W !!,$C(7),"ARE YOU SURE YOU WANT TO 'ADD A NEW ENTRY' WHEN THIS "_$P("SET^KILL",U,DIK)_" LOGIC OCCURS" S %=2 D YN^DICN W ! I %<1 S X=U Q G DIU:%=1 W "..OK, LET ME THINK A SECOND...",! S X=DCNEW,DICOMP="",DA="^DD("_DI_","_DL_",1,"_DQ_","_9 D DICOMP^DICE1 S DFLD=X F %=9.2:.1 Q:'$D(X(%)) S ^UTILITY("DICE",$J,90+%)=X(%) DIU S Y=DFLD_" S DIU=X K Y",DA="^DD("_DI_","_DL_",1,"_DQ_"," DICE4 DICE4 ;SFISC/GFT-TRIGGER LOGIC ;26NOV2004 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 3 ;Per VHA Directive 2004-038, this routine should not be modified. D SET S DTAG="S DIH=$G("_DREF_DSUB_")),DIV=X "_$P("I $D(^(0)) ","""",A>99)_X_",DIH="_DIN_",DIG="_DENEW_" D ^DICR",X="" S:$L(DE)+$L(DTAG)>160&($L(DE)>30) ^UTILITY("DICE",$J,DIK+.1)=DE,DE="X "_DA_DIK_".1)" S X=DE F ; S DB=DA_DIK S:$L(Y)+$L(X)>190 ^UTILITY("DICE",$J,DIK+.2)=Y,Y="X "_DB_".2)" S:$L(Y) X=Y_" "_X K DICOMPX(DNEW) S DHI=X,DCOND=DCOND_"TING OF '"_DNEW_"'" D COND G P:'$D(DCOND) I DLAY,DICOMPX,DICOMPX-DI W !,"SORRY, CAN'T DO THIS WHEN 'LAYGO' ALLOWED" S X=U Q S DHI="I X S X=DIV "_DHI I $O(J(A))>0 S ^("DIC")="" P S:$L(DHI)+$L(X)>220 ^UTILITY("DICE",$J,DIK+.3)=X,X="X "_DB_".3)" S X=X_" "_DHI S:$L(DTAG)+$L(X)>225 ^UTILITY("DICE",$J,DIK+.4)=DTAG,DTAG="X "_DB_".4)" S ^UTILITY("DICE",$J,DIK)=X_" "_DTAG K DTAG,D Q ; SET G PIECE:DLOC S DHI=$P(DLOC,",",2),%=+$E(DLOC,2,9),X="S DE="_(%-1)_"-$L(DIH),DIU=$E(DIH,"_%_","_DHI_"),Y=$E(DIH,"_(DHI+1)_",999),^("_DSUB_")=" I %>1 S X=X_"$E(DIH,1,"_(%-1)_")_" S X=X_"$J("""",$S(DE>0:DE,1:0))_DIV_$S(Y?."" "":"""",1:$J("""","_(DHI-%+1)_"-$L(DIV))_Y)" Q PIECE S X="S $P(^("_DSUB_"),U,"_DLOC_")=DIV" Q ; COND S DE=" DIV=X" F %=0:1:N S DE=DE_",D"_%_"=DA"_$S(%=N:"",1:"("_(N-%)_")") I A#100'<% S DE=DE_",DIV("_%_")=D"_% D CC I $D(DCOND) S DE=DE_" "_X S X="K DIV S"_DE Q Q ; CC ; S DA=DA_(DIK+5) R W !!,"DO YOU WANT TO MAKE THE "_DCOND_" CONDITIONAL" K DICOMPX S %=2,DICOMPX="",DICOMP="?",D="ENTER AN EXPRESSION FOR THE CONDITION: " D YN^DICN I %-1 K DCOND Q I DIK=1 S DICOMPX("Y(0)")="Y(0)",DICOMPX(1,DI,DL)="Y(0)",DICOMPX("Y(0)",U)=DI_U_DL E W ! D OLD^DICE2 S Y="CREATE CONDITION" I $D(^UTILITY("DICE",$J,Y)) W !,D_^(Y)_"// " R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T S:X="" X=^(Y) G X W !,D R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T X I X?."?" W !,"ENTER A TRUTH-VALUED 'COMPUTED-FIELD' EXPRESSION ",!?4,"(PERHAPS INVOLVING '"_DOLD_"')" G R S DCOND(0)=X D ^DICOMP I $D(X) W:Y'["B" !,"WARNING--THIS DOESN'T LOOK LIKE A CONDITION EXPRESSION!" S X="S Y(0)=X "_X,^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE CONDITION")=DCOND(0) F %=9.2:.1 G Q:'$D(X(%)) S ^(DIK+5*10+%)=X(%) K X(%) W $C(7),"??" G R DICE7 DICE7 ;SFISC/GFT-BULLETIN X-REFS ;12:38 PM 8 Jun 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K ^UTILITY("DICE",$J) S ^($J,0)="^^BULLETIN MESSAGE",DOLD=$P(^DD(DI,DL,0),U,1) F DIK=1,2 Q:$D(DTOUT) D M G QQ:X[U!$D(DTOUT) I X]"" S DQI="Y(",DCOND="SENDING OF '"_DREF_"'" D DA,CC^DICE4,DA G QQ:$D(DTOUT) S DHI=0,DLAY=$S($D(DCOND):X,1:"") D S G QQ:X=U Q:$D(DTOUT) G X^DICE0 QQ G QQ^DICE ; DA S DA="^DD("_DI_","_DL_",1,"_DQ_"," Q ; M W !!!,"---"_$P("SET^KILL",U,DIK)_" LOGIC---",!!,"ENTER THE NAME OF A 'BULLETIN' MESSAGE, IF YOU WANT THAT MESSAGE SENT" D GET^DICE2 Q:U[X S DIC=3.6,DIC(0)="ELMQ",DIC("DR")=".01;2;4;11;10" D ^DIC K DIC,DICOMPX G M:Y<0 S (DREF,^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE VALUE"))=$P(Y,U,2),DCOND=DI_U_DL_U_DIK_U_DQ S DIE=3.6,DA=+Y,DR=10 D:'$P(Y,U,3) ^DIE S X=DREF,DI=$P(DCOND,U,1),DL=$P(DCOND,U,2),DIK=$P(DCOND,U,3),DQ=$P(DCOND,U,4) Q ; S W " ..OK",! S DHI=DHI+1 SS S DLOC="PARAMETER #"_DHI I DHI>1 W !,"NOW, IF THE BULLETIN IS TO HAVE "_DHI_" OR MORE PARAMETERS INSERTED," W !,"ENTER A FIELD NAME (FOR EXAMPLE, '"_DOLD_"'),",!,"OR A 'COMPUTED-FIELD' EXPRESSION,",!,"THE VALUE OF WHICH WILL BE PASSED INTO THE '"_DREF_"' MESSAGE,",!,"AS "_DLOC S X=$O(^XMB(3.6,"B",DREF,0)) S:X="" X=-1 I X F Y=1:1 Q:'$D(^XMB(3.6,X,4,Y,0)) I ^(0)=DHI F D=1:1 G T:'$D(^XMB(3.6,X,4,Y,1,D,0)) W !?4,"-- ",^(0) W !,"(NOTE THAT NO SUCH PARAMETER IS DEFINED FOR THE '"_DREF_"' BULLETIN)" T W ! D OLD^DICE2 W DLOC_": " R X:DTIME S:'$T DTOUT=1 G:X?.P QQ:X=U!'$T,SET:X="",SS S DSUB=X,DICOMP="?" D ^DICOMP I $D(X)-1 W $C(7),"??",! G SS S DHI(DHI)=X_$P(" S Y=X X ^DD(""DD"") S X=Y",1,Y["D"),^UTILITY("DICE",$J,$P("CREA^DELE",U,DIK)_"TE "_DLOC)=DSUB G S SET W ! S ^UTILITY("DICE",$J,DIK)="K XMY S XMB="""_DREF_""" D ^XMB:$D(^XMB(3.6,""B"",XMB)) K Y,XMB" ; F D=1:1 Q:'$D(DHI(D)) D . S X="S X=Y(0) "_DHI(D)_" S XMB("_D_")=X" . S %=DIK_"."_$E("00",1,3-$L(D))_D . S ^UTILITY("DICE",$J,+%)=X ; S Y="" S:$D(DHI(1))#2 Y=" X ""N DIIND F DIIND="_DIK_".001:.001 Q:$D("_DA_"DIIND))[0 X ^(DIIND)""" S I="S Y(0)=X,D"_N_"=DA" F %=1:1:N S I=I_",D"_(N-%)_"=DA("_%_")" ; I $L(DLAY) D . S Y=" I X"_Y . S:$L(I)+$L(Y)+$L(DLAY)+$L(^(DIK))>238 ^(DIK+.9)=DLAY,DLAY="X "_DA_(DIK+.9)_")" . S DLAY=" "_DLAY ; S:Y]""!$L(DLAY) ^(DIK)=I_DLAY_Y_" "_^(DIK) DICF DICF ;VEN/TOAD,SF/TKW - Lookup: Finder, Part 1 (Main) ; 1/24/13 3:51pm ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; ; Contents ; ; $$FIND/FINDX/INPUT/HOOK75/LOOKUP: Finder Implementation ; $$BADVAL: Validate a Lookup Value ; CLOSE: Cleanup before Exiting Finder ; ; FIND(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DIVALUE,DINUMBER,DIFORCE,DISCREEN,DIWRITE,DILIST,DIMSGA,DINDEX,DIC,DIY,DIYX) ; ; Finder Implementation [internal use only] ; FINDX ; 1. Finder Pre-initialization [from FIND or FIND^DIC] ; I '$D(DIQUIET),$G(DIC(0))'["E" N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DICLERR S DICLERR=$G(DIERR) K DIERR N DIDENT S DIDENT(-1)=+$G(DILIST("C")) ; INPUT ; 2. Validate Input Parameters ; N DIEN M DIEN=DIVALUE N DIVALUE M DIVALUE=DIEN K DIEN S DIFLAGS=$G(DIFLAGS) ; Validate Flags (DIFLAGS), part 1 of 3 I DIFLAGS'["l" N DINDEX S DINDEX("WAY")=1 ; N DIFAIL S DIFAIL=0 D I DIFAIL D CLOSE Q . ; I1 . ; 2.1. Validate Flags (DIFLAGS), part 2 of 3 . ; . I DIFLAGS["p" S DIFLAGS=DIFLAGS_"f" . I DIFLAGS'["p" D Q:DIFAIL . . I $G(DIFIELDS)["IX",DIFIELDS'["-IX" D . . . N D S D=";"_DIFIELDS_";" I D'[";IX;",D'[";IXE",D'[";IXIE" Q . . . S DIDENT(-5)=1 . . S DIFLAGS=DIFLAGS_4 . . I DIFLAGS["O",DIFLAGS["X" S DIFLAGS=$TR(DIFLAGS,"O") . . S DIFLAGS=DIFLAGS_"t" . . ; I2 . . ; 2.2. Validate Value (DIVALUE) . . ; . . I DIFLAGS'["l" N DIERRM D I DIFAIL D ERR^DICF4(202,"","","",DIERRM) Q . . . S DIERRM="Lookup values" . . . I $G(DIVALUE(1))="" S DIVALUE(1)=$G(DIVALUE) . . . N I,DIEND S DIFAIL=1,DIEND=$O(DIVALUE(999999),-1) . . . F I=1:1:DIEND S DIVALUE(I)=$G(DIVALUE(I)) I DIVALUE(I)]"" S DIFAIL=$$BADVAL(DIVALUE(I)) Q:DIFAIL . ; I3 . ; 2.3. Validate Target_Root (DILIST) & Init Target Array . ; . S DILIST=$G(DILIST) . I DILIST'="",DIFLAGS'["l" D . . I DIFLAGS'["p" K @DILIST . . I DIFLAGS'["f" S DILIST=$NA(@DILIST@("DILIST")) . I DILIST="" S DILIST="^TMP(""DILIST"",$J)" K @DILIST . ; I4 . ; 2.4. Validate File (DIFILE), IENS (DIFIEN), & Screen (DISCREEN) . ; . D:DIFLAGS'["v"&(DIFLAGS'["l") FILE^DICUF(.DIFILE,.DIFIEN,DIFLAGS) . I $G(DIERR) S DIFAIL=1 Q . D SCREEN^DICUF(DIFLAGS,.DIFILE,.DISCREEN) . D DA^DILF(DIFIEN,.DIEN) . ; I5 . ; 2.5. Validate Fields (DIFIELDS) . ; . S DIFIELDS=$G(DIFIELDS) . ; I6 . ; 2.6. Validate Flags (DIFLAGS), part 3 of 3 . ; . I DIFLAGS'["p",DIFLAGS'["l" D Q:DIFAIL . . I $TR(DIFLAGS,"ABCKMOPQSUXfglpqtv4E")'="" S DIFAIL=1 D Q ;GFT . . . D ERR^DICF4(301,"","","",$TR(DIFLAGS,"fglpqtv4")) . ; I7 . ; 2.7. Validate Indexes (DIFORCE), Set Starting Index (DINDEX) . ; . I DIFLAGS'["l" D Q:DIFAIL . . S DIFORCE=$G(DIFORCE),DIFORCE(1)=1 . . I "*"[DIFORCE D . . . I DIFLAGS["M" S DIFORCE=0,DIFORCE(0)="*" Q . . . S DIFORCE(0)=$$DINDEX^DICL(DIFILE,DIFLAGS),DIFORCE=1 Q . . E D I DIFAIL D ERR^DICF4(202,"","","","Indexes") Q . . . I $P(DIFORCE,U)="" S DIFAIL=1 Q . . . S DIFORCE(0)=DIFORCE,DIFORCE=1 . . . I $P(DIFORCE(0),U,2)]"",DIFLAGS'["M" S DIFLAGS=DIFLAGS_"M" . . I DIFORCE S DINDEX=$P(DIFORCE(0),U) Q . . S DINDEX=$$DINDEX^DICL(DIFILE,DIFLAGS) Q . ; I8 . ; 2.8. Validate Number (DINUMBER) & Identifier (DIWRITE) . ; . I DIFLAGS'["p",DIFLAGS'["l" D Q:DIFAIL . . S DINUMBER=$S($G(DINUMBER):DINUMBER,1:"*") . . I DINUMBER'="*" D Q:DIFAIL . . . I DINUMBER\1=DINUMBER,DINUMBER>0 Q . . . S DIFAIL=1 D ERR^DICF4(202,"","","","Number") . S DIWRITE=$G(DIWRITE) ; I9 ; 2.9. Init Map (DIDENT(-3)), Window (DIDENT(-1)), & Done (DIOUT) ; I DIFLAGS["P" S DIDENT(-3)="" S DIDENT(-1,"MAX")=DINUMBER S DIDENT(-1,"MORE?")=0 S DIDENT(-1,"JUST LOOKING")=0 N DIOUT S DIOUT=0 ; HOOK75 ; 3. Process Pre-lookup Transform ; N DIHOOK75 S DIHOOK75=$G(^DD(DIFILE,.01,7.5)) I DIHOOK75'="",DIVALUE(1)]"",DIVALUE(1)'?."?",'$O(DIVALUE(1)),DIFLAGS'["l" D I DIOUT D CLOSE Q .N DIC D ;I DIFLAGS["p" N DIC D . . S DIC=DIFILE,DIC(0)=$TR(DIFLAGS,"2^fglpqtv4") Q . N %,D,X,Y,Y1 . S X=DIVALUE(1),D=DINDEX . M Y=DIEN S Y="",Y1=DIFIEN . X DIHOOK75 I '$D(X)!$G(DIERR) S DIOUT=1 D:$G(DIERR) Q . . S %=$$EZBLD^DIALOG(8090) ;Pre-lookup transform (7.5 node) . . D ERR^DICF4(120,DIFILE,"",.01,%) . S DIVALUE(1)=X,DIOUT=$$BADVAL(DIVALUE(1)) Q:DIOUT . I $G(DIC("S"))'="" S DISCREEN("S")=DIC("S") ;DIHOOK MAY HAVE SET THIS . I $G(DIC("V"))'="" S (DISCREEN("V"),DISCREEN("V",1))=DIC("V") ;...OR THIS ; LOOKUP ; 4. Finder Main Lookup Code ; I DIFLAGS'["l" D I DIOUT!($G(DIERR)) D CLOSE Q . D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN,DILIST,.DIOUT) Q I '$D(DINDEX("MAXSUB")) D . S DINDEX("MAXSUB")=$P($G(^DD("OS",+$G(^DD("OS")),0)),U,7) . I DINDEX("MAXSUB") S DINDEX("MAXSUB")=DINDEX("MAXSUB")-13 Q . S DINDEX("MAXSUB")=50 I $D(DISCREEN("V")) D VPDATA^DICUF(.DINDEX,.DISCREEN) I (DINDEX'="#")!($O(DIVALUE(1))) D CHKVAL1^DIC0(DINDEX("#"),.DIVALUE,DIFLAGS) I $G(DIERR) D CLOSE Q I DIFLAGS'["f" D I $G(DIERR) D CLOSE Q . D IDENTS^DICU1(DIFLAGS,.DIFILE,DIFIELDS,DIWRITE,.DIDENT,.DINDEX) I DIFLAGS'["p",DIFLAGS'["l" D I DIOUT!($G(DIERR)) D CLOSE Q . N I F I=2:1:DINDEX("#") Q:$G(DIVALUE(I))]"" . Q:$G(DIVALUE(I))]"" . D SPECIAL^DICF1(.DIFILE,.DIEN,DIFIEN,DIFLAGS,DIVALUE(1),.DINDEX,.DISCREEN,.DIDENT,.DIOUT,.DILIST) I DIFLAGS["t" D XFORM^DICF1(.DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX) I DIFLAGS'["X" D ; unless we are doing exact matches, also load FROM . D BACKFROM^DICF1(.DIVALUE,.DINDEX) ; values for backward traversal I DINDEX("#")>1,DIVALUE(1)="" N S M S=DISCREEN N DISCREEN M DISCREEN=S K S D . I DIFIELDS["IX",DIFIELDS'["-IX" Q . N DISAVMAX S DISAVMAX=DINDEX("MAXSUB") . D ALTIDX^DICF0(.DINDEX,.DIFILE,.DIVALUE,.DISCREEN,DINUMBER) . S DINDEX("MAXSUB")=DISAVMAX D CHKALL^DICF2(.DIFILE,.DIEN,DIFIEN,.DIFLAGS,.DIVALUE,.DISCREEN,DINUMBER,.DIFORCE,.DINDEX,.DIDENT,.DILIST,.DIC,.DIY,.DIYX) D CLOSE ; QUIT ; end of $$FIND/FINDX/INPUT/HOOK75/LOOKUP ; ; BADVAL(DIVALUE) ; Validate a Lookup Value ; I "^"[DIVALUE Q 1 I DIVALUE'?.ANP D ERR^DICF4(204,"","","",DIVALUE) Q 1 ; QUIT 0 ; end of $$BADVAL ; ; CLOSE ; Cleanup before Exiting Finder ; I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA) I DICLERR'=""!$G(DIERR) D . I DIFLAGS["l",+DIERR=1 Q . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) I $G(DIERR) D Q . Q:$G(DILIST)="" K @DILIST@("B") Q I DIFLAGS["p" S @DILIST=DIDENT(-1) Q Q:DIFLAGS["l" S @DILIST@(0)=DIDENT(-1)_U_DIDENT(-1,"MAX")_U_DIDENT(-1,"MORE?")_U_$S(DIFLAGS[2:"H",1:"") I DIFLAGS["P" S @DILIST@(0,"MAP")=$G(DIDENT(-3)) E D SETMAP^DICL1(.DIDENT,DILIST) K @DILIST@("B") ; QUIT ; end of CLOSE ; ; ; Error messages: ; 120 The previous error occurred when performin ; 202 The input parameter that identifies the |1 ; 204 The input value contains control character ; 301 The passed flag(s) '|1|' are unknown or in ; 8090 Pre-lookup transform (7.5 node) ; 8093 Too many lookup values for this index. ; 8094 Not enough lookup values provided for an e ; 8095 Only one compound index allowed on a looku ; ; EOR ; end of routine DICF DICF0 DICF0 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, get alternate index ;2/8/00 11:11 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ALTIDX(DINDEX,DIFILE,DIVALUE,DISCREEN,DINUMBER) ; Find alternate index when lookup value for first subscript is null. N DIX S DIX=DINDEX,DIX("WAY")=DINDEX("WAY"),DIX("OLDSUB")=DINDEX("#") D IDXOK(.DINDEX,DIFILE,.DIX) Q:DIX'=DINDEX A1 ; Find next lookup value N DIFIELD,DISUB,DITYPE,I,J,K,X,Y,Z F DISUB=1:0 S DISUB=$O(DIVALUE(DISUB)) Q:'DISUB I DIVALUE(DISUB)]"" D . S X=$G(DINDEX(DISUB,"TYPE")) . S DITYPE=$S(X="V":3,X="P":2,1:1),DITYPE(DITYPE,DISUB)="" . Q S DIX="" F DITYPE=1,2,3 Q:DIX]"" I $D(DITYPE(DITYPE)) F DISUB=0:0 D Q:'DISUB Q:DIX]"" . S DISUB=$O(DITYPE(DITYPE,DISUB)) Q:'DISUB . S DIFIELD=DINDEX(DISUB,"FIELD") A2 . ; find alternate index on that field. . F I=0:0 S I=$O(^DD(DIFILE,DIFIELD,1,I)) Q:'I S X=$G(^(I,0)) D Q:DIX]"" . . I $P(X,U,3)="",$P(X,U,2)]"A[" S DIX=$P(X,U,2) Q:DIX'=DINDEX . . S DIX="" Q . I DIX]"" S DIX("#")=1,DIX(1)=DISUB Q . F I=0:0 S I=$O(^DD("IX","F",DIFILE,DIFIELD,I)) Q:'I D Q:DIX]"" . . S DIX=$P($G(^DD("IX",I,0)),U,2) Q:DIX="" . . I DIX=DINDEX S DIX="" Q . . D IDXOK(.DINDEX,DIFILE,.DIX,I,.DIVALUE) . . Q . Q Q:DIX="" A3 ; Rearrange lookup values and for new index N DIV,DIS M DIS("S")=DISCREEN("S"),DIS("F")=DISCREEN("F") F I=1:1:DIX("#") S J=DIX(I) D . Q:DIVALUE(J)="" . M DIV(I)=DIVALUE(J),DIS(I)=DISCREEN(J) . K DIVALUE(J),DISCREEN(J) Q A4 ; Build screening logic for fields whose lookup values are not on new index. F J=0:0 S J=$O(DIVALUE(J)) Q:'J D . M DIS("VAL",J)=DIVALUE(J) . I $D(DISCREEN(J)) D . . S X="DINDEX(",Z="DISCREEN(""VAL""," . . F K=0:0 S K=$O(DISCREEN(J,K)) Q:'K S Y=DISCREEN(J,K) I Y[X S DISCREEN(J,K)="" F Q:Y'[X D . . . N L,S S S=$P(Y,X),L=$L(S_X),S=S_Z,Y=$E(Y,L+1,$L(Y)) . . . S DISCREEN(J,K)=DISCREEN(J,K)_S . . . I Y'[X S DISCREEN(J,K)=DISCREEN(J,K)_Y . . . Q . . M DIS("X",J)=DISCREEN(J) Q . N DICODE,DINODE . D GET^DICUIX1(DIFILE,DIFILE,DINDEX(J,"FIELD"),.DINODE,.DICODE) . I "PVSD"'[DINDEX(J,"TYPE") S DIS("X",J,"GET")="S DIVAL="_DICODE Q . S DIS("X",J,"GET")="S DIVAL=$$EXTERNAL^DIDU("_DIFILE_","_DINDEX(J,"FIELD")_","""","_DICODE_")" . D . . N DISAVJ S DISAVJ=J N J . . S X=$$EXTERNAL^DIDU(DINDEX(DISAVJ,"FILE"),DINDEX(DISAVJ,"FIELD"),"",DIS("VAL",DISAVJ),"DIERR") . . S J=$O(DIS("VAL",DISAVJ,99999),-1)+1 . . S DIS("VAL",DISAVJ,J)=X Q . Q K DINDEX S DINDEX=DIX,DINDEX("WAY")=DIX("WAY") I DIFLAGS["l" S DINDEX("START")=DIX,DINDEX("OLDSUB")=DIX("OLDSUB") K DISCREEN,DIVALUE M DISCREEN=DIS,DIVALUE=DIV K DIS,DIV D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN) D XFORM^DICF1(DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX) Q ; IDXOK(DINDEX,DIFILE,DIX,DIXIEN,DIVALUE) ; Return alternate index name DIX if it has no set/kill conditions and all subscripts are fields from original index DINDEX. I '$G(DIXIEN) S DIXIEN=$O(^DD("IX","BB",DIFILE,DIX,0)) I 'DIXIEN S DIX="" Q I $G(^DD("IX",DIXIEN,1.4))]""!($G(^(2.4))]"") S DIX="" Q N I,J,X,DIFIELD,DISKIP S DISKIP=1 I $O(DIVALUE(0)) S DIX("#")=0 F I=0:0 S I=$O(^DD("IX",DIXIEN,11.1,"AC",I)) Q:'I S DISKIP=1 D Q:DISKIP . S X=$G(^DD("IX",DIXIEN,11.1,I,0)) . Q:$P(X,U,3)'=DIFILE Q:$P(X,U,6)'=I S DIFIELD=$P(X,U,4) Q:'DIFIELD . Q:$G(^DD("IX",DIXIEN,11.1,I,2))]"" . I '$O(DIVALUE(0)) S DISKIP=0 Q . F J=1:1:DINDEX("#") D Q:'DISKIP . . Q:DINDEX(J,"FIELD")'=DIFIELD . . I I=1,DIVALUE(J)="" Q . . S DIX(I)=J,DISKIP=0 Q . I 'DISKIP S DIX("#")=DIX("#")+1 . Q I DISKIP S DIX="" Q Q ; DICF1 DICF1 ;VEN/TOAD,SF/TKW - Lookup: Finder, Part 2 (Xform) ; 1/24/13 3:52pm ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; ; Contents ; ; XFORM: Add Transformed Lookup Values & Screens, Main Loop ; VALUES/LOWER/CHK/COMMA/LONG: Alternate Lookup Values ; SPECIAL: Handle Selection by Record Number ; ENTRY: Screen & Accept a Record-number Match ; BACKFROM: Create From Values for Backward Collation ; ; XFORM(DIFLAGS,DIVALUE,DISCREEN,DINDEX) ; ; FIND--produce array of values and screens by transforming input ; subroutine, DIVALUE, DINDEX, & DISCREEN passed by reference ; N DISUB F DISUB=1:1:DINDEX("#") D VALUES ; QUIT ; end of XFORM ; ; VALUES ; Alternate Lookup Values ; ; 1. Add Original Lookup Value to Arrays ; I $D(DIVALUE(DISUB,0,1)) S DIVALUE(DISUB)=DIVALUE(DISUB,0,1) N I F I="PART","FROM","TO" I $D(DIVALUE(DISUB,0,1,I)) D . S DINDEX(DISUB,I)=DIVALUE(DISUB,0,1,I) Q D . S I=-1 F S I=$O(DIVALUE(DISUB,I)) Q:I="" K DIVALUE(DISUB,I) . S I=-1 F S I=$O(DISCREEN(DISUB,I)) Q:I="" K DISCREEN(DISUB,I) S DIVALUE(DISUB,1)=DIVALUE(DISUB) Q:DIVALUE(DISUB)="" I DIFLAGS["Q" D LONG Q ; LOWER ; 2. Add Upper-case Lookup Value to Array, If Needed ; I DIVALUE(DISUB)?.E1L.E,DIFLAGS'["X" D . S DIVALUE(DISUB,2)=$$OUT^DIALOGU(DIVALUE(DISUB),"UC") ; CHK ; 3. Skip Remaining Transforms for Most Data Types ; ; Quit if data type not free-text, pointer or vp ; or if lookup value is numeric or a date ; I "PVF"'[$G(DINDEX(DISUB,"TYPE"))!(DIVALUE(DISUB)?.NP) Q N Y D Q:Y>0 . N X S X=DIVALUE(DISUB) N %DT,DIFLAGS,DIVALUE,DISCREEN,DINDEX,DISUB . S %DT="T" D ^%DT ; COMMA ; 4. Add Comma-piece Lookup Value to Arrays, If Needed ; I DIVALUE(DISUB)[",",DIFLAGS'["X" D . N DISTEMP,DIPIECE1 S DISTEMP="",DIPIECE1=$P(DIVALUE(DISUB),",") . Q:$L(DIPIECE1)>DINDEX(DISUB,"LENGTH") . Q:'$L(DIPIECE1) ;SO . ; 21 . ; Handle Original Form of Comma-piece Lookup (C Flag) . ; . I DIFLAGS["C" D . . N DIPART1 S DIPART1=" I %?.E1P1""" . . N DIPART2 S DIPART2=""".E!(D'=""B""&(%?1""" . . N DIPART3 S DIPART3=""".E))" . . N DIOUT S DIOUT=0 . . N DIPIECE,DIVPIECE F DIPIECE=2:1 D I DIOUT Q . . . S DIVPIECE=$P(DIVALUE(DISUB),",",DIPIECE) . . . I DIVPIECE["""" Q . . . I $E(DIVPIECE)=" " S DIVPIECE=$E(DIVPIECE,2,$L(DIVPIECE)) . . . I DIVPIECE="" S DIOUT=1 Q . . . I $L(DIVPIECE)*2+$L(DISTEMP)+33+14+34>255 S DIOUT=1 Q . . . S DISTEMP=DISTEMP_DIPART1_DIVPIECE_DIPART2_DIVPIECE_DIPART3 . . . Q:DISTEMP="" . . . S DISTEMP="S %=DIVAL "_DISTEMP Q ;22*135 . . I DISTEMP="" Q . ; 22 . ; Handle New, Reduced Form of Comma-piece Lookup . ; . I DIFLAGS'["C" N DIPIECE2,DIPC2 D . . S (DIPC2,DIPIECE2)=$P(DIVALUE(DISUB),",",2) . . I DIPIECE2["""" S DIPC2=$$CONVQQ^DILIBF(DIPIECE2) . . S DISTEMP="S %=$P(DIVAL,"","",2) I $E(%,1,"_$L(DIPIECE2)_")="""_DIPC2_"""" . ; 23 . ; Either Way, Add Value and Screen to Arrays . ; . S DIVALUE(DISUB,3)=DIPIECE1 . S DISCREEN(DISUB,3)=DISTEMP . I DIFLAGS'["C" S DIVALUE(DISUB,3,"c")=DIPIECE2 . ; 24 . ; Handle Combo of Comma-piecing and Lowercase . ; . I DIVALUE(DISUB)'?.E1L.E Q . S DIVALUE(DISUB,4)=$$OUT^DIALOGU(DIPIECE1,"UC") . S DISCREEN(DISUB,4)=$$OUT^DIALOGU(DISTEMP,"UC") . I DIFLAGS'["C" S DIVALUE(DISUB,4,"c")=$$OUT^DIALOGU(DIPIECE2,"UC") ; LONG ; 5. Add Long Lookup Value to Arrays, If Needed ; I $L(DIVALUE(DISUB))'>DINDEX(DISUB,"LENGTH") Q N J,X,DISLONG,DISPART,DISXACT,DIREF F I=0:0 S I=$O(DIVALUE(DISUB,I)) Q:'I D . N L,M S L=DINDEX(DISUB,"LENGTH") . Q:$L(DIVALUE(DISUB,I))'>L . S X=DIVALUE(DISUB,I) K DIVALUE(DISUB,I) S DIVALUE(DISUB,0,I)=X . I $G(DISCREEN(DISUB,I))]"" S X=DISCREEN(DISUB,I) K DISCREEN(DISUB,I) S DISCREEN(DISUB,0,I)=X . S DIVALUE(DISUB,I)=$E(DIVALUE(DISUB,0,I),1,L) . I I=1 D . . S (DIVALUE(DISUB),DINDEX(DISUB))=DIVALUE(DISUB,I) . . F J="PART","FROM","TO" S M=$L($G(DINDEX(DISUB,J))) D:M>L . . . S DIVALUE(DISUB,0,I,J)=DINDEX(DISUB,J) . . . S DINDEX(DISUB,J)=$E(DINDEX(DISUB,J),1,L) . S DISLONG="" . I $D(DISCREEN(DISUB,0,I)) S DISLONG=" X DISCREEN("_DISUB_",0,"_I_")" . S DIREF="DINDEX("_DISUB_",0,"_I_")" . S DISPART="I $P(DIVAL,$G("_DIREF_"))="""""_DISLONG ;DI*22*70 . S DISXACT="I $P(DIVAL,U)="_DIREF_DISLONG . ; L10 . ; Handle Combo of Long Input and Exact Matching . ; . I DIFLAGS["X" S DISCREEN(DISUB,I)=DISXACT Q . I DIFLAGS'["O" S DISCREEN(DISUB,I)=DISPART Q . S DISCREEN(DISUB,I)=DISXACT . S DISCREEN(DISUB,I,2)=DISPART ; QUIT ; end of VALUES/LOWER/CHK/COMMA/LONG ; ; SPECIAL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DINDEX,DISCREEN,DIDENT,DIOUT,DILIST) ; ; Process space-bar return, 'IEN or DIVALUE equal to an IEN. ; S DIOUT=0 ; 11 ; 1. Handle Space Lookup Value (Space-bar Recall) ; I DIVALUE=" " D S DIOUT=1 Q . N DIROOT S DIROOT=$$ROOT^DIQGU(DIFILE,DIFIEN,"Q") . N DINODE S DINODE=$G(^DISV(DUZ,$E(DIROOT,1,28))) . N DINODEL S DINODEL=$L(DINODE,",") . I $P(DINODE,",",1,DINODEL-1)'=$E(DIROOT,29,9999) Q . S DIEN=$P(DINODE,",",DINODEL) . I 'DIEN S DIEN="" Q . D ENTRY ; 12 ; Handle Accent-grave Lookup Value ; I DIVALUE?1"`".NP D Q:DIOUT=1 . S DIEN=$E(DIVALUE,2,$L(DIVALUE)) Q:+DIEN'=DIEN . D ENTRY S DIOUT=1 ; 13 ; Handle Pure Numeric Lookup Value (Possible IEN) ; I $S(DIVALUE?1.N:1,DIVALUE'?.NP:0,1:+DIVALUE=DIVALUE) D . N DI001 S DI001=$D(^DD(DIFILE,.001)) . N DI01FLAG S DI01FLAG=$P($G(^DD(DIFILE,.01,0)),U,2) . I $D(@DIFILE(DIFILE)@(DIVALUE)) D . . I DIFLAGS'["A",'DI001,DI01FLAG["N"!($O(@DIFILE(DIFILE)@("A["))'="") Q . . S DIEN=DIVALUE . . D ENTRY . . I $G(DINDEX("DONE"))!($G(DIERR)) S DIEN="",DIOUT=1 ; QUIT ; end of SPECIAL ; ; ENTRY ; Execute screens, and if entry passes, do ACCEPT to add it to output. ; N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0)) Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE) D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE) ; QUIT ; end of ENTRY ; ; BACKFROM(DIVALUE,DINDEX) ; create From values for backward collation ; ;;private;procedure;clean;silent;SAC compliant ; input: ; .DINDEX("#") = # of lookup values supplied ; .DIVALUE(subscript #) = default lookup value ; .DIVALUE(subscript #,value #) = each additional lookup value ; output: ; .DIVALUE("BACK",DISUB,...) = From values for backwards ; called only by: ; LOOKUP^DICF ; calls: ; $$BACKFROM^DICUIX2 to compute each From value for backwards ; N DISUB F DISUB=1:1:DINDEX("#") D ; traverse lookup values . ; . M DIVALUE("BACK",DISUB)=DIVALUE(DISUB) ; initialize From values . ; . I DIVALUE(DISUB)'="" D ; if default exists . . N B S B=$$BACKFROM^DICUIX2(DIVALUE(DISUB)) . . S DIVALUE("BACK",DISUB)=B ; add default back-from value . ; . N DIVAL S DIVAL=0 . F D Q:'DIVAL ; traverse alternate values . . S DIVAL=$O(DIVALUE(DISUB,DIVAL)) ; each alternate . . Q:'DIVAL . . I $G(DIVALUE(DISUB,DIVAL))'="" D ; if alternate exists . . . N B S B=$$BACKFROM^DICUIX2(DIVALUE(DISUB,DIVAL)) . . . S DIVALUE("BACK",DISUB,DIVAL)=B ; add alternate back-from val ; QUIT ; end of BACKFROM ; ; EOR ; end of routine DICF1 DICF2 DICF2 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 3 (All Indexes) ;12/17/99 08:24 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CHKALL(DIFILE,DIEN,DIFIEN,DIFLAGS,DIVALUE,DISCREEN,DINUMBER,DIFORCE,DINDEX,DIDENT,DILIST,DIC,DIY,DIYX) ; ; Loop through all indexes to be searched, perform data type ; transforms on lookup values. N DIOUT I DIFLAGS["O",DIFLAGS'["p" S DIOUT=DIFLAGS N DIFLAGS S DIFLAGS=DIOUT_"X" S DIOUT=0 N DISKIP 41 F D Q:$G(DIERR)!($G(DINDEX("DONE")))!DIOUT . S DISKIP=0 . N DILINK S DILINK=DIFILE_U_DINDEX . I DINDEX="#" D . . S DIFILE("CHAIN",DILINK)="" . . Q:+$P(DIVALUE,"E")'=DIVALUE Q:'$D(@DIFILE(DIFILE)@(DIVALUE)) . . N DIEN S DIEN=DIVALUE D ENTRY^DICF1 Q . I '$D(DIFILE("CHAIN",DILINK)) D K DIFILE("CHAIN",DILINK) . . S DIFILE("CHAIN",DILINK)="" . . D:DIFLAGS'["Q" PREPIX(.DIFILE,DIFLAGS,.DINDEX,.DIVALUE,.DISKIP) . . I 'DISKIP D CHKONE^DICF3(.DIFLAGS,.DIVALUE,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX) . . D CLEANIX(.DINDEX,.DIVALUE) Q 43 . I $G(DIERR)!($G(DINDEX("DONE"))) Q . I DIFLAGS["l" S (DIOUT,DINDEX("DONE"))=1 Q . D NXTINDX(.DINDEX,.DIFORCE,.DIFILE,.DIFLAGS,.DIVALUE,DINUMBER) . I DINDEX="" D Q:DINDEX="" . . S DIOUT=1 . . Q:DIFLAGS'["O" Q:DIFLAGS'["X" Q:DIFLAGS["p" Q:DIDENT(-1) . . S DIFLAGS=$TR(DIFLAGS,"X"),DIOUT=0,DIFORCE(1)=1 . . S DINDEX=$S(DIFLAGS["l":DINDEX("START"),DIFORCE:$P(DIFORCE(0),U),1:$$DINDEX^DICL(DIFILE,DIFLAGS)) . . I DINDEX="" S DIOUT=1 Q . . D FIRSTIDX(.DINDEX,.DIFORCE,.DIFILE,DIFLAGS,.DIVALUE,DINUMBER) . . Q . D . . N DICRSR S DICRSR=0 . . I DIFLAGS["P" D Q:'DICRSR . . . F S DICRSR=$O(DIDENT(DICRSR)) Q:'DICRSR Q:$D(DIDENT(DICRSR,0,1,"E")) . . . Q . . Q:'$D(DIDENT(DICRSR,0,1,"E")) . . N DISAVNO,DISAVENT S DISAVNO=DINDEX("#"),DINDEX("#")=1,DISAVENT=$G(DIDENT),DIDENT="IXE" . . D THROW^DICU11(DIFLAGS,.DIDENT,"IXE",DICRSR,1,"E",.DINDEX,1) . . S DINDEX("#")=DISAVNO,DIDENT=DISAVENT Q . Q Q ; PREPIX(DIFILE,DIFLAGS,DINDEX,DIVALUE,DISKIP) ; ; CHKALL--lookup index data type, add transform values to list N DISUB,DITYPE F DISUB=1:1:DINDEX("#") D:DIVALUE(DISUB)]"" Q:$G(DIERR) . I $G(DINDEX("IXTYPE"))="S" D Q . . N X S X=$$SOUNDEX^DICF5(DINDEX(DISUB)) Q:'X . . S DIVALUE(DISUB,5)=X Q . S DITYPE=DINDEX(DISUB,"TYPE") . I DITYPE["F"!(DITYPE["N") D . . Q:$G(DINDEX(DISUB,"TRANCODE"))="" . . N X S X=DIVALUE(DISUB) X DINDEX(DISUB,"TRANCODE") Q:X="" . . S DIVALUE(DISUB,5)=X . . Q . N DINODE S DINODE=$G(^DD(+DINDEX(DISUB,"FILE"),+DINDEX(DISUB,"FIELD"),0)) . I DITYPE["D" D PREPD^DICF5(DISUB,.DINDEX,DINODE,.DIVALUE) Q . I DITYPE["S" D PREPS^DICF5(DIFLAGS,DISUB,.DINDEX,DINODE,.DIVALUE) Q . I DITYPE'["P",DITYPE'["V" Q . I DISUB'=1 D POINT^DICF5(DISUB,DIFLAGS,.DIFILE,.DINDEX,.DIVALUE,.DISCREEN) Q . D POINT^DICF4(.DIFILE,.DIFLAGS,.DINDEX,.DIDENT,.DIEN,DIFIEN,.DISCREEN,.DIVALUE,.DIC,.DIFORCE) . I '$D(DINDEX(1,"IXROOT"))!($G(DIERR)) S DISKIP=1 . I $G(DTOUT)!($G(DIROUT)) S (DISKIP,DINDEX("DONE"))=1 . Q:DISKIP . Q:$G(DINDEX(1,"TRANCODE"))="" . N DII,X . S DII="" F S DII=$O(@DINDEX(1,"ROOT")@(DII)) Q:DII="" D . . K @DINDEX(1,"ROOT")@(DII) . . S X=$P(DII,"^",2) X DINDEX(1,"TRANCODE") Q:X="" . . S X=$P(DII,"^")_"^"_X,@DINDEX(1,"ROOT")@(X)="" Q . Q Q ; CLEANIX(DINDEX,DIVALUE) ; ; CHKALL--clear transform values for this index from DIVALUE arrays ; clear temporary list of pointed-to entries. N I,DISUB F DISUB=1:1:DINDEX("#") D . I $G(DINDEX(DISUB,"IXROOT"))]"" D . . I DISUB=1,DIFLAGS["l" S I=$O(@DINDEX(DISUB,"ROOT")@("")),DS("INT")=$P(I,U,2) . . S I=$P(DINDEX(DISUB,"ROOT"),",""B"")",1) Q:I="" . . K @(I_")") Q . S I=4 . F S I=$O(DIVALUE(DISUB,I)) Q:'I K DIVALUE(DISUB,I) . Q Q ; FIRSTIDX(DINDEX,DIFORCE,DIFILE,DIFLAGS,DIVALUE,DINUMBER) ; ; Return data for starting index before second loop when flags["O" D N3 Q ; NXTINDX(DINDEX,DIFORCE,DIFILE,DIFLAGS,DIVALUE,DINUMBER) ; ; Return next index N D,DIGO,I,J,K,DIX1,DIX2,DIOK,DIOLDL S D=DINDEX,I=$G(DINDEX("START")),K=$G(DINDEX("MAXSUB")) D:DIFLAGS'["h" . F J=1:1:DINDEX("#") S DIOLDL(J)=DINDEX(J,"LENGTH") K DINDEX S DINDEX=D,DINDEX("WAY")=1 S:I]"" DINDEX("START")=I S:K]"" DINDEX("MAXSUB")=K S (DIGO,DIOK)=0 N1 I DIFORCE F D Q:DIOK!(DIGO) . I DIFLAGS["M",DIFORCE(1)=1,$P(DIFORCE(0),U,2)="" S DIGO=1 Q . S DIFORCE(1)=DIFORCE(1)+1,DINDEX=$P(DIFORCE(0),U,DIFORCE(1)) . I DINDEX="#",DIFLAGS'["l",DIFLAGS'["h" S DIOK=1 Q . S:DINDEX=-1 DINDEX="" I DINDEX="" S DIOK=1 Q . I $O(^DD(DIFILE,0,"IX",DINDEX,0)),$$IDXOK(DIFILE,DINDEX) S DIOK=1 Q . S I=$O(^DD("IX","BB",DIFILE,DINDEX,0)) Q:'I . S DIOK=1 Q N2 I ('DIFORCE)!DIGO D . S (DIX1,DIX2)=DINDEX . F S DIX1=$O(^DD(DIFILE,0,"IX",DIX1)) Q:DIX1="" Q:$$IDXOK(DIFILE,DIX1) . S DIOK=0 F S DIX2=$O(^DD("IX","BB",DIFILE,DIX2)) Q:DIX2="" D Q:DIOK . . S I=$O(^DD("IX","BB",DIFILE,DIX2,0)) Q:'I . . Q:$P($G(^DD("IX",I,0)),U,14)'["L" . . S J=$O(^DD("IX",I,11.1,"AC",1,0)) Q:'J Q:$G(^DD("IX",I,11.1,J,0))="" . . S DIOK=1 Q . I DIX1'="",DIX2=""!(DIX2]DIX1) S DINDEX=DIX1 Q . S DINDEX=DIX2 Q . Q N3 Q:DINDEX="" Q:DIFLAGS["h" D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN) I DINDEX("#")>1 F D=1:1:DINDEX("#") S DIVALUE(D)=$G(DIVALUE(D)) N DINEWVAL S DINEWVAL=0 D . N J F J=1:1:DINDEX("#") I DIVALUE(J)]"",DINDEX(J,"LENGTH")'=$G(DIOLDL(J)) S DINEWVAL=1 Q . I DINEWVAL D XFORM^DICF1(DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX) Q ; IDXOK(DIFILE,%) ; See whether selected index exists in 1 nodes of DD N DIX,%Y,DD,X Q:%="" 0 S DIX=$O(^DD(DIFILE,0,"IX",%,0)) Q:'DIX 0 S %Y=$O(^DD(DIFILE,0,"IX",%,DIX,0)) Q:'%Y 0 F DD=0:0 S DD=$O(^DD(DIX,%Y,1,DD)) Q:'DD S X=$P($G(^(DD,0)),U,2) Q:X=% Q:'DD 0 Q 1 ; DICF3 DICF3 ;VEN/TOAD,SF/TKW - Lookup: Finder, Part 3 (One Index) ; 1/24/13 3:53pm ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; ; Contents ; ; CHKONE: Check One Index for All Possible Matches ; ; CHKONE(DIFLAGS,DIVALUE,DINDEX,DIDENT,DIFILE,DIEN,DIFIEN,DISCREEN,DILIST,DIC,DIY,DIYX) ; ; Called from CHKALL--check one index for possible matches ; N I,DISUB F DISUB=1:1:DINDEX("#") D . F I=0:0 S I=$O(DINDEX(DISUB,I)) Q:'I K DINDEX(DISUB,I) ; C1 ; Set up then find eXact matches. ; I DIFLAGS["X" D Q . ; . F DISUB=1:1:DINDEX("#") D ; loop through lookup values . . S (DINDEX(DISUB),DINDEX(DISUB,1))=$G(DINDEX(DISUB,"FROM")) . . S DINDEX(DISUB,"USE")=$S(DIFLAGS["Q":1,"VP"[DINDEX(DISUB,"TYPE"):0,1:1) . . ; . . I DISUB>1!("VP"'[DINDEX(1,"TYPE")) M DINDEX(DISUB)=DIVALUE(DISUB) . . ; . . Q:DIFLAGS["Q" . . ; . . I "VP"[DINDEX(DISUB,"TYPE") D Q:DISUB=1 . . . S DINDEX(DISUB)="" . . . Q:DISUB'=1 . . . S DINDEX(1,1)="" F I=1:0 S I=$O(DINDEX(1,I)) Q:'I K DINDEX(1,I) . . S I=4 F S I=$O(DIVALUE(DISUB,I)) Q:'I S DINDEX(DISUB,I)=DIVALUE(DISUB,I) . ; . S DIDENT(-4)=1 . N DIF S DIF=$TR(DIFLAGS,"X")_"X" . S DINDEX("TOTAL")=DIDENT(-1) . ; . D WALK^DICFIX(DIF,.DINDEX,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX) ; Q:$G(DIERR)!($G(DINDEX("DONE"))) ; C2 ; Find partial matches ; F DISUB=1:1:DINDEX("#") D ; loop through lookup values . S (DINDEX(DISUB),DINDEX(DISUB,1))=$G(DINDEX(DISUB,"FROM")) . S DINDEX(DISUB,"USE")=$S(DIFLAGS["Q"!(DINDEX("#")>1):1,DIFLAGS["O":0,1:1) . ; . I DISUB>1!("VP"'[DINDEX(1,"TYPE")) D . . I DINDEX(DISUB,"WAY")=1 D ; forward traversal, traverse from . . . M DINDEX(DISUB)=DIVALUE(DISUB) ; start of partial matches . . I DINDEX(DISUB,"WAY")=-1 D ; backward traversal, traverse from . . . M DINDEX(DISUB)=DIVALUE("BACK",DISUB) ; end of partial matches . ; . I "VP"[DINDEX(DISUB,"TYPE"),DIFLAGS'["Q" D Q:DISUB=1 . . S DINDEX(DISUB)="",DINDEX(DISUB,"USE")=0 . . Q:DISUB'=1 . . S DINDEX(1,1)="" F I=1:0 S I=$O(DINDEX(1,I)) Q:'I K DINDEX(1,I) . I DIFLAGS["O" F I=0:0 S I=$O(DISCREEN(DISUB,I)) Q:'I D . . I $D(DISCREEN(DISUB,I,2)) S DISCREEN(DISUB,I)=DISCREEN(DISUB,I,2) ; S DIDENT(-4)=1 S DINDEX("TOTAL")=DIDENT(-1) ; D WALK^DICFIX(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX) ; QUIT ; end of CHKONE ; ; EOR ; end of routine DICF3 DICF4 DICF4 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (pointer indexes) ;19NOV2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DIVALUE,DIC,DIFORCE) ; ; PREPIX^DICF2--transform value for indexed pointer field N DIF,DIFL,DIX,DIPVAL,DISCR,DITARGET,DISKIP,DIPRV,DINEW S DIF=$TR(DIFLAGS,$TR(DIFLAGS,"4XOB"))_"Mp",DIX="B" I DIFLAGS["B" S DIF=$TR(DIF,"M") D GETTMP^DICUIX1(.DITARGET,"DICF") S DITARGET("C")=0 S (DIPRV,DINEW)="S" F S DINEW=$O(DISCREEN(DINEW)) Q:$E(DINEW)'="S" S DIPRV=DINEW,DISCR(DIPRV)=DISCREEN(DIPRV) S DINEW="S"_($P(DIPRV,"S",2)+1) P1 ; Process regular pointer I DINDEX(1,"TYPE")="P" D Q . S DIFL=+$P($P(DINDEX(1,"NODE"),U,2),"P",2) Q:'DIFL . M DIPVAL(1)=DIVALUE(1),DISCR(1)=DISCREEN(1) . I DIFLAGS["l" D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET) . I DIFLAGS'["l" D NUM ..;I +$P(DIPVAL(1),"E")=DIPVAL(1),$G(DINDEX)'="B",DIFLAGS["M" Q ;GFT PATCH 165 DO NOT LOOK UP POINTERS. IN 1040 DID NOT HAVE ,$G(DINDEX)'="B",DIFLAGS["M" . . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF) . . N F S F=DIF N DIF S DIF=F K F M DIFL("CHAIN")=DIFILE("CHAIN") . . D BLDSCR(.DISCR,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE) . . D FIND^DICF(.DIFL,",","",DIF,.DIPVAL,"",.DIX,.DISCR,"",.DITARGET) . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B")) . Q P2 ; Process variable pointer I DIFLAGS["l" D Q . D DIC(.DIC,.DIEN,.DIFILE,.DINDEX,.DIVALUE,DITARGET) . I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q . S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B")) . Q N DIFILES I DIVALUE(1)[".",$P(DIVALUE(1),".")]"" D . N V S V=$$OUT^DIALOGU($P(DIVALUE(1),"."),"UC") . D VPFILES^DIEV1(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),V,.DIFILES) . Q P21 D P3 I $G(DIERR) K @DITARGET Q I $O(DIFILES(0)),'$G(@DITARGET) K DIFILES D P3 I $G(DIERR)!('$G(@DITARGET)) K @DITARGET Q S DINDEX(1,"IXROOT")=DINDEX(1,"ROOT"),DINDEX(1,"ROOT")=$NA(@DITARGET@("B")) Q ; P3 N DIVP,G,I,X,DIF1,DIS1 F DIVP=0:0 S DIVP=$O(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),"V",DIVP)) Q:'DIVP S X=$G(^(DIVP,0)) D Q:$G(DIERR) . K DIF1,DIFL,DIPVAL,DIS1,DIX S DIX="B" . Q:'X I $O(DIFILES(0)) Q:'$D(DIFILES(+X)) . I $G(DISCREEN("V",1))]"" D Q:G="" . . S G=$G(^DIC(+X,0,"GL")) Q:G="" . . S:'$D(DINDEX(DISUB,"VP",G)) G="" Q . S DIF1=DIF_"v",DIFL=+X . I $D(DIFORCE("PTRIX")) D SETIX(.DIFORCE,.DINDEX,.DIX,.DIF1) . D FILE^DICUF(.DIFL,"",.DIF1) Q:$G(DIERR) . M DIS1=DISCR . I '$O(DIFILES(0)) M DIPVAL(1)=DIVALUE(1),DIS1(1)=DISCREEN(1) . E D . . S DIF1=DIF1_"t" . . S DIPVAL(1)=$P(DIVALUE(1),".",2,99) . . Q . M DIFL("CHAIN")=DIFILE("CHAIN") . D BLDSCR(.DIS1,DINEW,DIPRV,.DIFL,.DINDEX,.DISCREEN,.DIFILE) . S DITARGET("C")=+$G(@DITARGET) . D FIND^DICF(.DIFL,",","",DIF1,.DIPVAL,"",.DIX,.DIS1,"",.DITARGET) . Q Q ; SETIX(DIFORCE,DINDEX,DIX,DIF) ; If user passes list of indexes to use on pointed-to file, set up to use them. M DIX("PTRIX")=DIFORCE("PTRIX") N % S %=$G(DIX("PTRIX",DINDEX(1,"FILE"),DINDEX(1,"FIELD"),DIFL)) Q:%="" S DIX=% I $P(DIX,U,2)="" S:DIF["M" DIF=$TR(DIF,"M") Q S:DIF'["M" DIF=DIF_"M" Q ; BLDSCR(DISCR,DINEW,DIPRV,DIFL,DINDEX,DISCREEN,DIFILE) ; Build screen to make sure entry is in pointer index. N DICSUBS S DICSUBS="" S DISCR(DINEW)=$S(DIPRV="S":" Q",1:" "_DISCREEN("S")_" Q:$T") N I S I="I" S:DINDEX(1,"TYPE")["V" I=I_"_"";"_$P(DIFL(DIFL,"O"),U,2)_"""" S DISCR("S")=DICSUBS_"N "_DINEW_" S "_DINEW_"="_I_" X DISCREEN("""_DINEW_""")" I DINDEX("#")>1 D Q . S DISCR(DINEW)="X ""I 0"" I $D("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_"))"_DISCR(DINEW) . Q S DISCR(DINEW)="X ""I 0"" N I F I=0:0 S I=$O("_DIFILE(DIFILE,"O")_""""_DINDEX_""","_DINEW_",I)) Q:'I I $D("_DIFILE(DIFILE,"O")_"I,0))"_DISCR(DINEW) Q ; SETDA(DIEN) ; Return code that sets DA array to current level when pointer field is in a multiple. DA itself=DA(1). N %,DICODE S DICODE="S DA="_+$G(DIEN(1)) F %=1:1 Q:'$D(DIEN(%)) S DICODE=DICODE_",DA("_%_")="_DIEN(%) Q DICODE ; DIC(DIC,DIEN,DIFILE,DINDEX,DIVALUE,DITARGET) ; If we were called from ^DIC, we want to do recursive lookup there. N %,%Y,D,DD,DIVAL,DF,DID,DINUM,DICRS,DS,DO,X,Y,DIFINDER S DO(2)=DIFILE,(D,DF)=DINDEX("START"),(X,DIVAL(1))=DIVALUE(1),DIVAL(0)=1 S DD=0,%=DINDEX,DS=$G(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),0)),Y=DINDEX(1,"TYPE"),%Y=DINDEX(1,"FIELD") S:$G(DICR)="" DICR=0 D . N DIFILE,I . S DIFINDER="p" . M I=DIC N DIC M DIC=I K I . N DA X $$SETDA(.DIEN) N DIEN . D A^DICM Q:Y=-1 D ^DICM1 K DICR(DICR) S DICR=DICR-1 I DICR<1 K DICR . Q Q:Y'>0 S @DITARGET@("B",($P(Y,U,2)_U_X))="",@DITARGET=1 Q ; ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ; ; error logging procedure N DIPE N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI)) D BLD^DIALOG(DIERN,.DIPE,.DIPE) Q ; DICF5 DICF5 ;SEA/TOAD,SF/TKW-VA FileMan: Finder, (Other lookup value transform) ;5/26/99 10:05 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PREPS(DIFLAGS,DISUB,DINDEX,DINODE,DIVALUE) ; ; transform value for indexed set of codes field ; proc, DINDEX passed by ref N DICODE,DIMEAN,DIPAIR,DISKIP,DITRY,DIVAL N DISET S DISET=$P(DINODE,U,3) CODES ; N DIP F DIP=1:1:$L(DISET,";")-1 D . S DIPAIR=$P(DISET,";",DIP) . F DIVAL=1,2 S DITRY=$G(DIVALUE(DISUB,DIVAL)) D:DITRY]"" . . I DIVAL=2,DIFLAGS["l" Q . . S DIMEAN=$P(DIPAIR,":",2) . . I $P(DIMEAN,DITRY)'="" Q . . I DIFLAGS["X",DIMEAN'=DITRY Q . . S DICODE=$P(DIPAIR,":") . . I $G(DINDEX(DISUB,"TRANCODE"))="" D Q . . . S:DICODE'=DITRY DIVALUE(DISUB,(4+DIVAL))=DICODE Q . . N X S X=DICODE X DINDEX(DISUB,"TRANCODE") Q:X="" . . S DIVALUE(DISUB,7)=X Q . Q Q ; POINT(DISUB,DIFLAGS,DIFILE,DINDEX,DIVALUE,DISCREEN) ; Add transform values for dates and sets at end of pointer chain ; save off the primary file info, follow the ptr chain to the end N DIVPTR,DIF,DITYPE S DIVPTR=$S(DINDEX(DISUB,"TYPE")="V":1,1:0) M DIF=DIFILE N DIFILE M DIFILE=DIF K DIF N DIFIL,DIFLD S DIFIL=+DINDEX(DISUB,"FILE"),DIFLD=+DINDEX(DISUB,"FIELD") N DINODE S DINODE=$G(^DD(DIFIL,DIFLD,0)) Q:DINODE="" D FOLLOW^DICL3(.DIFILE,"",DINODE,1,0,"",DIFLD,DIFIL,DIVPTR,DISUB,.DISCREEN) N DIEND F DIEND=0:0 S DIEND=$O(DIFILE("STACKEND",DIEND)) Q:'DIEND D . S DIFIL=$P(DIFILE("STACKEND",DIEND),U,2) . S DINODE=$G(^DD(DIFIL,.01,0)),DITYPE=$P(DINODE,U,2) . I DITYPE["F"!(DITYPE["N") D Q . . Q:$G(DINDEX(DISUB,"TRANCODE"))="" . . N X S X=DIVALUE(DISUB) X DINDEX(DISUB,"TRANCODE") Q:X="" . . S DIVALUE(DISUB,5)=X Q . I $P(DINODE,U,2)["D" D PREPD(DISUB,.DINDEX,DINODE,.DIVALUE) Q . I $P(DINODE,U,2)["S" D PREPS(DIFLAGS,DISUB,.DINDEX,DINODE,.DIVALUE) . Q Q ; PREPD(DISUB,DINDEX,DINODE,DIVALUE) ; ; PREPIX--transform value for indexed date field N D S D=$G(DIVALUE(DISUB)) Q:D="" N DIFLAGS S DIFLAGS=$P($P(DINODE,"%DT=""",2),"""") N DIDATEFM D DT^DILF($TR(DIFLAGS,"ER")_"Ne",D,.DIDATEFM) I DIDATEFM'>1 Q I $G(DINDEX(DISUB,"TRANCODE"))="" S DIVALUE(DISUB,5)=DIDATEFM Q N X S X=DIDATEFM X DINDEX(DISUB,"TRANCODE") Q:X="" S DIVALUE(DISUB,6)=X Q ; SOUNDEX(DIVALUE) ; func, convert value to soundex value N DICODE S DICODE="01230129022455012623019202" N DISOUND S DISOUND=$C($A(DIVALUE)-(DIVALUE?1L.E*32)) N DIPREV S DIPREV=$E(DICODE,$A(DIVALUE)-64) N DICHAR,DIPOS F DIPOS=2:1 S DICHAR=$E(DIVALUE,DIPOS) Q:","[DICHAR D Q:$L(DISOUND)=4 . Q:DICHAR'?1A . N DITRANS S DITRANS=$E(DICODE,$A(DICHAR)-$S(DICHAR?1U:64,1:96)) . Q:DITRANS=DIPREV Q:DITRANS=9 . S DIPREV=DITRANS . I DITRANS'=0 S DISOUND=DISOUND_DITRANS Q $E(DISOUND_"000",1,4) ; DICFIX DICFIX ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes ;5/26/99 14:40 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. ; WALK(DIFLAGS,DINDEX,DIDENT,DIFILE,DIEN,DIFIEN,DISCREEN,DILIST,DIC,DIY,DIYX) ; ; ; a walker to traverse a compound index, taking actions ; DINDEX is an array describing the index and how to walk it ; PREP ; prepare to loop through subscript ; N DISUB S DISUB=DINDEX("AT") N DIVAL S DIVAL=DINDEX(DISUB) N DIPART,DIMORE S DIPART=$G(DINDEX(DISUB,"PART")),DIMORE=+$G(DINDEX(DISUB,"MORE?")) N DITRXNO S DITRXNO=DIDENT(-4) I $G(DINDEX(DISUB,"USE")),DIVAL'="" D . S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIVAL),-DINDEX(DISUB,"WAY")) ; LOOP ; loop through subscripts ; N DIDONE,DISKIP S DIDONE=0 F D Q:DIDONE!$G(DIERR) . S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIVAL),DINDEX(DISUB,"WAY")) . DATA . ; if we're in the data subscripts, we need to walk further . . I DISUB'>DINDEX("#") D Q . . S DISKIP=0 . . I DIVAL'="",'$D(DINDEX(DISUB,"IXROOT")) D CHK Q:DISKIP . . S:DIVAL="" DIDONE=1 . . I DIDONE Q:'DITRXNO D Q:DIDONE!(DISKIP) . . . S DITRXNO=$O(DINDEX(DISUB,DITRXNO)) Q:'DITRXNO . . . S (DIVAL,DIPART)=DINDEX(DISUB,DITRXNO) . . . I DITRXNO=3!(DITRXNO=4),DIDENT(-1)>DINDEX("TOTAL") S DISKIP=1 . . . S DIDONE=0 . . . Q . . S DINDEX(DISUB)=DIVAL,DINDEX("AT")=DISUB+1 . . S DINDEX(DISUB,"FOUND")=DITRXNO,DIDENT(-4)=1 . . I DISUB=1,$D(DINDEX(1,"IXROOT")) S DINDEX(1)=$P(DIVAL,U,2) . . D WALK(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DIC,.DIY,.DIYX) . . S DINDEX("AT")=DISUB . . S DIDENT(-4)=DITRXNO . . I DISUB=1,$D(DINDEX(1,"IXROOT")) S DINDEX(1)=DIVAL . . I $G(DINDEX("DONE"))!$G(DIERR) S DIDONE=1 . IEN . ; otherwise, we're in the IEN subscripts & need to process . . I DIVAL="" S DIDONE=1 Q . I DINDEX="B" N DIMNEM D . . I $D(@DINDEX(DISUB,"ROOT")@(DIVAL))#2 Q:'^(DIVAL) . . E Q:'$O(@DINDEX(DISUB,"ROOT")@(DIVAL,"")) . . S DIMNEM="" Q . D TRY . Q CLEAN ; clean up after loop, exit S DINDEX(DISUB)=$S(DISUB<(DINDEX("#")+1):$G(DINDEX(DISUB,"FROM")),1:"") S DIDENT(-4)=1 Q ; CHK ; See whether we have a match or are at the end of the subscripts. I DISUB>1,"VP"[DINDEX(DISUB,"TYPE"),DIFLAGS'["Q" D Q . N DIFL,DIFLD,DIV . S DIFL=DINDEX(DISUB,"FILE"),DIFLD=DINDEX(DISUB,"FIELD"),DIV=DIVAL . I DINDEX(DISUB,"TYPE")="V",$G(DISCREEN("V",DISUB))]"" D Q:DISKIP . . N G S G="^"_$P(DIV,";",2) Q:G="^" . . S:'$D(DINDEX(DISUB,"VP",G)) DISKIP=1 Q . N DIVAL S DIVAL=$$EXTERNAL^DIDU(DIFL,DIFLD,"i",DIV) . I $G(DIERR),DIFLAGS["l" K DIERR,^TMP("DIERR",$J) S DIVAL=DIV . I DIVAL="" S DIDONE=1 Q . F DITRXNO=0:0 S DITRXNO=$O(DINDEX(DISUB,DITRXNO)) Q:'DITRXNO D Q:'DIDONE . . S DIPART=DINDEX(DISUB,DITRXNO),DIDONE=0 . . D MATCH I DIDONE,'$G(DINDEX("DONE")),DIMORE,DIFLAGS'["X" D . . . S DIDONE=0 D FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE) I DIVAL="" S DIDONE=1 Q . . . D MATCH Q . . Q:DIDONE . . S DINDEX(DISUB,"EXT")=$$EXTERNAL^DIDU(DIFL,DIFLD,"",DIV) . . I $G(DIERR),DIFLAGS["l" K DIERR,^TMP("DIERR",$J) S DINDEX(DISUB,"EXT")=DIV . . Q . I DIDONE S DIDONE=0,DISKIP=1 . Q D MATCH I DIDONE,'$G(DINDEX("DONE")),DIMORE,DIFLAGS'["X" D . S DIDONE=0 D FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE) I DIVAL="" S DIDONE=1 Q . D MATCH Q Q ; MATCH ; No more subscripts or partial matches, or past our TO value? Q:DIVAL="" I DIFLAGS["l",DINDEX(DISUB,DITRXNO)="" Q I DIFLAGS["X",DIVAL'=DINDEX(DISUB,DITRXNO) S DIDONE=1 Q I $P(DIVAL,$G(DIPART))'="" S DIDONE=1 Q I $G(DINDEX(DISUB,+DITRXNO,"c"))]"" D Q:DIDONE!(DISKIP) . D NXTNAM^DICFIX1(.DIVAL,DIPART,.DINDEX,.DISKIP,.DIDONE) Q Q ; TRY ; Apply screens to entry. If passed, add entry to output. S (DIEN,DINDEX(DISUB))=DIVAL N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0)) Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE) ; If called from ^DIC, special processing. I DIFLAGS["l" D DICLIST Q ; Else, add entry to output list. D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE) Q:$G(DIERR) I DIDENT(-1)=DIDENT(-1,"MAX"),'DIDENT(-1,"JUST LOOKING") S DIDONE=1,DINDEX("DONE")=1 Q ; DICLIST ; Build output list when Finder is called from ^DIC. ; Display entries and allow selection if screen is filled. K DTOUT,DUOUT N D,DIX,DIFINDR,DIFILE,X,Y I DIC(0)["E" N DIQUIET S Y=DIEN,D=DINDEX,DIX=DINDEX(1),DIFINDR=1 S X=$S("VP"[DINDEX(1,"TYPE"):DIX,1:DINDEX(1,DINDEX(1,"FOUND"))) I "VP"[DINDEX(1,"TYPE") S DS(0,"DICRS")=1 I "D"[DINDEX(1,"TYPE") S DS(0,"DIDA")=1 D MN^DIC3 Q:'$T D K^DIC3 I DS(0) S (DIDONE,DINDEX("DONE"))=1 Q ; ; DICFIX1 DICFIX1 ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes (cont.) ;15MAY2011 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. ; ; NXTNAM(DIVAL,DIPART,DINDEX,DISKIP,DIDONE) ; ; limited comma piece lookup, skip nonmatching names in index N DIUTF8 D .N X,Y S Y=$C(126),X=$G(^DD("OS",^DD("OS"),"HIGHESTCHAR")) X:X]"" X S DIUTF8=Y I $P(DIVAL,",")=DIPART S DIVAL=DIPART_","_DIUTF8,DISKIP=1 Q ;UTH/SMH N DIPREC,DIPOSTC,DIPPOSTC S DIPREC=$P(DIVAL,","),DIPOSTC=$P(DIVAL,",",2) S DIPPOSTC=DINDEX(DISUB,DITRXNO,"c") I $$PREFIX(DIPOSTC,DIPPOSTC) Q I $$PREFIX(DIPPOSTC,DIPOSTC) Q D SKIP(.DISKIP,.DIVAL,DIPREC,DIPOSTC,DIPART,DIPPOSTC,.DINDEX) Q ; PREFIX(DISTRING,DIPREFIX) ; Q $E(DISTRING,1,$L(DIPREFIX))=DIPREFIX ; SKIP(DISKIP,DIVAL,DIPREC,DIPOSTC,DIPART,DIPPOSTC,DINDEX) ; ; Skip forward within index based on limited comma piecing I DIPPOSTC]DIPOSTC D Q . ; Current first name before starting first name, skip to starting first name . S DIVAL=DIPREC_","_DIPPOSTC . I '$D(@DINDEX(DISUB,"ROOT")@(DIVAL)) S DISKIP=1 ; Else, skip the rest of the first names within current last name. S DIVAL=DIPREC_","_DIUTF8,DISKIP=1 Q ;UTH/SMH ; ; DICL DICL ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister ;28APR2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DISCREEN,DIWRITE,DILIST,DIMSGA,DIC) ; ; ENTRY POINT--return a list of entries from a file ; (Note: DIC parameter only passed if called from ^DICQ) ; IN ; Entry point from LIST^DIC I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DICLERR S DICLERR=$G(DIERR) K DIERR ; INPUT ; Validate input parameters N DIERN,DIPE,DIDENT S DIFLAGS=$G(DIFLAGS) I DIFLAGS["I",DIFLAGS'["Q" S DIFLAGS=DIFLAGS_"Q" S DIFIELDS=$G(DIFIELDS) I DIFIELDS'["-IX" D . N DID S DID=";"_DIFIELDS_";" . I (DID["@"!(DIFLAGS["I")),DID'[";IX;",DID'[";IXE",DID'[";IXIE" Q . S DIDENT(-5)=1 Q S DINUMBER=$G(DINUMBER) I DINUMBER="" S DINUMBER="*" I '$D(DIPART(1)) S DIPART(1)=$G(DIPART) I '$D(DIFROM(1)) S DIFROM(1)=$G(DIFROM) I $O(DIFROM(1)) D . N E S E=9999 F S E=$O(DIFROM(E),-1) Q:'E Q:DIFROM(E)]"" . I E N I F I=1:1:E I DIFROM(I)="" D BLD^DIALOG(202,"FROM values"),OUT Q . Q S DIFROM("IEN")=$G(DIFROM("IEN")) S DINDEX("WAY")=1 I DIFLAGS["B" S DINDEX("WAY")=-1 S DINDEX=$G(DINDEX) I '$D(DISCREEN("S")) S DISCREEN("S")=$G(DISCREEN) D:DISCREEN("S")]"" .N X S X=DISCREEN D ^DIM I '$D(X) D BLD^DIALOG(202,"SCREEN") ;**GFT CHECK FOR GOOD MUMPS CODE S DIWRITE=$G(DIWRITE) ; OUTPUT ; Establish output file name, starting output subscript no. I $G(DILIST)="" S DILIST="^TMP(""DILIST"",$J)" E I DIFLAGS'["h" D I $G(DIERR) D OUT Q . I DILIST'?.1"^"1U.7UN.ANP,DILIST'?.1"^%".7UN.ANP D Q . . D BLD^DIALOG(202,"target array") . S DILIST=$NA(@DILIST@("DILIST")) . Q K @DILIST S DILIST("ORDER")=$S(DINDEX("WAY")=1:0,1:DINUMBER+1) I DINUMBER="*",DINDEX("WAY")=-1 D . S DINDEX("WAY")=1,DINDEX("WAY","REVERSE")=1 . S DILIST("ORDER")=0 . Q ; FILE ; Validate file number and IENS. I DIFLAGS'["h" D FILE^DICUF(.DIFILE,.DIFIEN,DIFLAGS) I $G(DIERR) S DIFROM="",DIFROM("IEN")="" D OUT Q D SCREEN^DICUF(DIFLAGS,.DIFILE,.DISCREEN) ; CHECKS ; I $TR(DIFLAGS,"BIKMPQSUfhuXE")'="" S DIERN=301,DIPE(1)=DIFLAGS D ERROUT Q ;GFT: "X" and "E" added S DIFLAGS=DIFLAGS_3 I DINUMBER'="*",DINUMBER<1!(DINUMBER\1'=DINUMBER) D Q . S DIERN=202,DIPE(1)="Number" D ERROUT ; IXANDID ; Gather information about index and field data to be returned. N DIOUT S DIOUT=0 IXNAME ; Set default index name if null. N DIGFT,DIGFTEMP I DIFLAGS["X" D DICL^DICLGFT G BADQ ;NOTE: A CROSS-REF MUST BE 1U.UN (IX^DICE); AN INDEX MUST BE 1A.AN I DINDEX'="#",DINDEX'?1U.UNP S DINDEX=$$DINDEX(DIFILE,DIFLAGS) D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,.DIFROM,.DIPART,DINUMBER,.DISCREEN,DILIST,.DIOUT) BADQ I DIOUT!($G(DIERR)) D KTMPIX^DICL1 Q I $D(DISCREEN("V")) D VPDATA^DICUF(.DINDEX,.DISCREEN) I $O(DIFROM(DINDEX("#")+1))!(DINDEX'="#"&($O(DIPART(DINDEX("#"))))) D BLD^DIALOG(202,"Index"),KTMPIX^DICL1 Q D IDENTS^DICU1(DIFLAGS,.DIFILE,DIFIELDS,DIWRITE,.DIDENT,.DINDEX) I $G(DIERR) D KTMPIX^DICL1 Q ; BRANCH ; Continue on to actual search. D PREP^DICL1 I $G(DIGFTEMP)["^" K @DIGFTEMP ;** Q ; DINDEX(DIFILE,DIFLAGS) ; Set DINDEX to index name for KEY. Also called at top of ^DIC & by DICF & DICF2 N I,X S X="" I $G(DIFLAGS)["K" D . S I=$O(^DD("KEY","AP",DIFILE,"P",0)) Q:'I . S X=$P($G(^DD("IX",+$P($G(^DD("KEY",I,0)),U,4),0)),U,2) Q Q:X?1U.UNP X Q "B" ; ERROUT D BLD^DIALOG(DIERN,.DIPE,.DIPE),OUT Q ; OUT I DICLERR'=""!$G(DIERR) D . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA) Q ; ; Possible messages returned ; 202 The input parameter that identifies the |1 ; 301 The passed flag(s) '|1|' are unknown or in ; DICL1 DICL1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 2 ;10/15/98 14:19 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PREP ; set up subfile's DA array under DIEN, init how many found, ; set max, and init array of last entries returned. ; N DIEN D DA^DILF(DIFIEN,.DIEN) N DISUB,DIVAL,X,Y S DIDENT(-1)=0 S DIDENT(-1,"MAX")=DINUMBER S DIDENT(-1,"JUST LOOKING")=0 F DISUB=1:1:DINDEX("#")+1 S DIDENT(-1,"LAST",DISUB)="" S (DIDENT(-1,"LAST"),DIDENT(-1,"LAST","IEN"))="" ; PTR ; if 1st indexed field is a pointer or var.ptr., and we're not doing ; a quick list, we build info for the ; pointer chain(s) to the end file(s) and do the search. ; I "VP"[DINDEX(1,"TYPE"),DIFLAGS'["Q",'$D(DINDEX("ROOTCNG",1)) D . D POINT^DICL10(.DIFILE,.DIFLAGS,.DINDEX,.DIDENT,.DIEN,DIFIEN,.DISCREEN,.DILIST) . Q ; GETLIST ; build the output list when first subscript not a ptr. or var.ptr. ; E D . I $D(DINDEX("ROOTCNG",1)) D BLDTMP^DICLIX1(.DINDEX,.DISCREEN,DIFLAGS,.DIDENT) . D WALK^DICLIX(DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,"","",.DIC) ; DSPHLP ; If we're displaying entries for online ^DIC help, display the rest ; I DIFLAGS["h",$O(DICQ(0)) D . K DTOUT,DUOUT S DICQ(0,"MAP")=DIDENT(-3) . D DSP^DICQ1(.DINDEX,.DICQ,.DIC,.DIFILE) . I $G(DTOUT)!($G(DUOUT)) S (DINDEX("DONE"),DIDONE)=1 Q . S DIDENT(-1)=0 . Q ; KTMPIX ; if we've built temporary indexes, we delete them: D KILLB(.DIFILE) N DISUB S DISUB=$O(DINDEX("ROOTCNG","")) I DISUB K @DINDEX(DISUB,"ROOT") ; FINAL ; cleanup after search. ; I $G(DIERR) K @DILIST D OUT^DICL Q ; ; set the output list header node and map node, output FROM values ; for last entries returned. ; I '$D(DIDENT(-1)) S DIDENT(-1)=0,DIDENT(-1,"MAX")=DINUMBER N DIHEADER S DIHEADER=DIDENT(-1)_U_DIDENT(-1,"MAX")_U_+$G(DIDENT(-1,"MORE?")) S @DILIST@(0)=DIHEADER_U_$S(DIFLAGS[2:"H",1:"") I DIFLAGS["P",$G(DIDENT(-3))]"" S @DILIST@(0,"MAP")=DIDENT(-3) E D SETMAP(.DIDENT,DILIST) N I S I=0 F S I=$O(DIDENT(-1,"LAST",I)) Q:'I D . K DIDENT(-1,"LAST",I,"I") . Q:$G(DIDENT(-1,"MORE?")) . I I=1 S (DIDENT(-1,"LAST"),DIDENT(-1,"LAST","IEN"))="" . S DIDENT(-1,"LAST",I)="" . Q K DIFROM M DIFROM=DIDENT(-1,"LAST") ; ; Move arrays to output and QUIT. D OUT^DICL Q ; KILLB(DIFILE) ; Kill temporary "B" index on current file DIFILE or pointed-to files. N DIROOT I $D(DIFILE(DIFILE,"NO B")) S DIROOT=DIFILE(DIFILE,"NO B")_")" K @DIROOT Q:'$O(DIFILE("STACK",0)) N I,J,K F I=0:0 S I=$O(DIFILE("STACK",I)) Q:'I F J=0:0 S J=$O(DIFILE("STACK",I,J)) Q:'J F K=0:0 S K=$O(DIFILE("STACK",I,J,K)) Q:'K I $D(DIFILE(K,"NO B")) D . S DIROOT=DIFILE(K,"NO B")_")" . K @DIROOT Q Q ; SETMAP(DIDENT,DILIST) ; Set map node for unpacked format N I,J,K,DIMAP,DITMP S (DIMAP,I)="" F S I=$O(DIDENT(-3,I)) Q:I="" S DITMP="" D D SETM2 . I I S J="" F S J=$O(DIDENT(-3,I,J)) Q:J="" D . . I J?1.N.1"I" D . . . N K S K="FID("_I_")"_$P("I^",U,J["I") . . . K:$D(DIDENT(-3,I,K)) DIDENT(-3,I,K) Q . . S DITMP=DITMP_J_"^" Q . Q:I'=0 . F J=0:0 S J=$O(DIDENT(-3,0,J)) Q:'J S K="" F D Q:K="" . . S K=$O(DIDENT(-3,0,J,K)) S:K]"" DITMP=DITMP_K_"^" Q Q:DIMAP="" S $E(DIMAP,$L(DIMAP))="" S @DILIST@(0,"MAP")=DIMAP Q ; SETM2 N DILENGTH S DILENGTH=$L(DIMAP) Q:$E(DIMAP,DILENGTH-3,DILENGTH)="..." I $L(DITMP)+($L(DIMAP))>252 S DIMAP=DIMAP_"..." Q S DIMAP=DIMAP_DITMP Q ; ; DICL10 DICL10 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 2 ;5/21/98 15:27 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; POINT(DIFILE,DIFLAGS,DINDEX,DIDENT,DIEN,DIFIEN,DISCREEN,DILIST) ; ; save off the primary file info, follow the ptr chain to the end S DIFLAGS=DIFLAGS_"p" N DIVPTR,DIF S DIVPTR=$S(DINDEX(1,"TYPE")="V":1,1:0) M DIF=DIFILE N DIFILE M DIFILE=DIF K DIF D FOLLOW^DICL3(.DIFILE,"",DINDEX(1,"NODE"),1,0,"",DINDEX(1,"FIELD"),DINDEX(1,"FILE"),DIVPTR,1,.DISCREEN) D SETB^DICL3 N DIX1 S DIX1="B" S DIX1("WAY")=DINDEX("WAY") N DIFROM S DIFROM(1)=$G(DINDEX(1,"FROM")),DIFROM("IEN")="" N DIPART S DIPART(1)=$G(DINDEX(1,"PART")) S DIFILE("STACK")=1_U_DIFILE("STACKEND",1) S DIFILE=$P(DIFILE("STACK"),U,3) D INDEX^DICUIX(.DIFILE,.DIFLAGS,.DIX1,.DIFROM,.DIPART) I $G(DINDEX(1,"USE")) S DIX1(1,"USE")=1 N I F I="FIELD","FILE","FROM","GET","TYPE" K DIX1(1,I) K DIX1("FLIST") P1 ; no variable pointers in pointer chain I '$O(DIFILE("STACKEND",1)) D Q . D WALK^DICLIX(DIFLAGS,.DIX1,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,"",.DIC) . Q P2 ; variable pointer(s) in pointer chain N DIXV S DIFLAGS=DIFLAGS_"v",DIFILE("STACK")="" S I=0 F S I=$O(DIFILE("STACKEND",I)) Q:'I D . N DIXNAME,DISUB,R S DIXNAME="DIXV("_I_")",DISUB=DIX1(1) . N DIFL,DIGL S DIFL=+$P(DIFILE("STACKEND",I),U,2),DIGL=DIFILE(DIFL,"O") . S @DIXNAME@(1)=DISUB,@DIXNAME@(1,"MORE?")=DIX1(1,"MORE?"),@DIXNAME@(2)="" . S R=DIGL_"DINDEX" . S @DIXNAME@(1,"ROOT")=R_")",@DIXNAME@(2,"ROOT")=R_",DINDEX(1))" . I $G(DINDEX(1,"USE")),DISUB'="" D . . S R=DIGL_"""B"")",DISUB=$O(@R@(DISUB),-DIX1(1,"WAY")) . . S @DIXNAME@(1)=DISUB . . Q . S R=DIGL_"""B"")",DISUB=$O(@R@(DISUB)),@DIXNAME@(1,"NXTVAL")=DISUB . I DISUB="" K @DIXNAME,DIFILE("STACKEND",I) Q . Q:DIFILE("STACK") . S DIFILE("STACK")=I_U_DIFILE("STACKEND",I) . Q K DIX1(1,"USE") I +DIFILE("STACK")=1 S DIX1(1)=DIXV(1,1) E S I="DIXV("_+DIFILE("STACK")_")" M DIX1=@I D WALK^DICLIX(DIFLAGS,.DIX1,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,.DIXV,.DIC) Q ; DICL2 DICL2 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 3 ;11JUNE2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;. SCREEN(DIFILE,DIEN,DIFLAGS,DIFIEN,DISCREEN,DINDEX,DI0NODE) ; ; ; return 1 if entry should be screened out ; S1 ; entries tagged for archiving, or missing the .01 or already on ; the list should be screened out. ; I DIFILE'<2,'$$VMINUS9^DIEFU(DIFILE,","_DIEN_DIFIEN) Q 1 I $P(DI0NODE,U)="" Q 1 I DIFLAGS[4 N DIREC D I 'DIREC Q 1 . S DIREC=DIEN I DIFLAGS["v" S DIREC=DIREC_";"_$P(DIFILE(DIFILE,"O"),U,2) . I $D(@DILIST@("B",($E($P(DI0NODE,U),1,DINDEX("MAXSUB"))_"^"_DIREC))) S DIREC=0 . Q ; S2 ; execute any screen on transformed lookup values ; N DISKIP S DISKIP=0 I DIFLAGS[4 N DISUB F DISUB=1:1:DINDEX("#") D Q:DISKIP . N DISCR2 S DISCR2=+$G(DINDEX(DISUB,"FOUND")) . Q:'$D(DISCREEN(DISUB,DISCR2)) . N DIVAL,D S @DINDEX(DISUB,"GET"),D=DINDEX . X DISCREEN(DISUB,DISCR2) S DISKIP='$T . Q I DISKIP Q DISKIP N DISCR S3 ; Additional screening for using an alternate index for loop through file. I $D(DISCREEN("X")) F DISCR=0:0 S DISCR=$O(DISCREEN("X",DISCR)) Q:'DISCR D Q:DISKIP . N D,DIPART,DISUB,DIVAL,X . X DISCREEN("X",DISCR,"GET") I DIVAL="" S DISKIP=1 Q . F DISUB=0:0 S DISUB=$O(DISCREEN("VAL",DISCR,DISUB)) Q:'DISUB D Q:'DISKIP . . S D="",DISKIP=1 . . S DIPART=DISCREEN("VAL",DISCR,DISUB) Q:$P(DIVAL,DIPART)'="" . . S X=$G(DISCREEN("X",DISCR,DISUB)) I X]"" X X Q:'$T . . S DISKIP=0 Q . Q I DISKIP Q DISKIP S4 ; Execute Screen parameter, whole file screen. F DISCR="F","S" I $G(DISCREEN(DISCR))'="" D Q:DISKIP . N %,D S D=$G(DINDEX) . N DIC S DIC=DIFILE(DIFILE,"O") . I DIFLAGS[4 S DIC(0)=$TR(DIFLAGS,"2^fqlpqtuv4PQU") . E S DIC(0)=$TR(DIFLAGS,"2^fpq3BIMPQ") . N Y M Y=DIEN . N Y1 S Y1=DIEN_DIFIEN . N X S X=$G(@DIFILE(DIFILE)@(DIEN,0)),X=$P(X,U) . I DIFLAGS[4,DIFLAGS["p" N I S I=DIEN . D . . N DIFILE,DIXV,DIY,DIYX . . I 1 X DISCREEN(DISCR) S DISKIP='$T . S5 . ; if the screen returned DIERR, id the error's source with a second . ; error and exit . . I $G(DIERR) D . . S DISKIP=1 . . N DICONTXT . . S DICONTXT=$S(DISCR["F":"Whole File Screen",1:"Screen Parameter") . . D ERR^DICF4(120,DIFILE,DIEN,"",DICONTXT) Q DISKIP ; ACCEPT(DIFILE,DIEN,DIFLAGS,DIFIEN,DINDEX,DIDENT,DILIST,DI0NODE) ; ; accept an entry into the output list ; A1 ; if we're doing the final pass (just looking to see if there are any ; more entries), we don't actually add it to the list, just note what ; we found and quit ; I DIDENT(-1,"JUST LOOKING") D Q . S DIDENT(-1,"JUST LOOKING")=0 . S DIDENT(-1,"MORE?")=1 . Q:DIFLAGS[4 . N DISAME,I S DISAME=0 . F I=1:1 Q:I>DINDEX("#") D Q:DISAME1 D . S DIF(DILVL,DIFILE)=DIFRFILE_U_DIVPTR . I '$D(@DIFILE(DIFILE)@("B")) S DIFILE(DIFILE,"NO B")="" . S DIFILE(DIFILE,"O")=$$OREF^DIQGU(DIFILE(DIFILE)) . Q F2 ; Find data type of .01 field of pointed-to file, process ; end of pointer chain. N T S T=$P(DIDEF,U,2) I T'["P",T'["V" D Q . S DIFILE("STACKEND",DICHNNO)=DILVL_U_DIFILE . N L,F F L=DILVL:-1:1 D . . S DIFILE("STACK",DICHNNO,L,DIFILE)=DIFRFILE_U_DIVPTR . . Q:L=1 . . S DIFILE=+DIF(L,DIFILE) . . S F=DIF(L-1,DIFILE),DIFRFILE=$P(F,U),DIVPTR=$P(F,U,2) . S DICHNNO=DICHNNO+1 . Q F3 ; Advance file number, Process regular pointers within pointer chain. N DIFRFILE S DIFRFILE=DIFILE I T["P" D Q . S DIFILE=+$P($P(DIDEF,U,2),"P",2) . S DIFILE(DIFILE)=$$CREF^DIQGU(U_$P(DIDEF,U,3)) . S DIDEF=$G(^DD(DIFILE,.01,0)) . D FOLLOW(.DIFILE,.DIF,DIDEF,.DICHNNO,.DILVL,DIFRFILE,"","",0) . Q F4 ; Process variable pointers within the pointer chain. N DIVP,G S:'$G(DIFIELD) DIFIELD=.01 F DIVP=0:0 S DIVP=$O(^DD(DIFILE,DIFIELD,"V",DIVP)) Q:'DIVP S G=$G(^(DIVP,0)) D . Q:'G . S DIFILE=+G,G=$G(^DIC(DIFILE,0,"GL")) I G="" S DIFILE=DIFRFILE Q . I DILVL=1,$D(DISCREEN("V",DISUB)),'$D(DINDEX(DISUB,"VP",G)) S DIFILE=DIFRFILE Q . S DIFILE(DIFILE)=$$CREF^DIQGU(G) . S DIDEF=$G(^DD(DIFILE,.01,0)) . N DISAVL S DISAVL=DILVL . D FOLLOW(.DIFILE,.DIF,DIDEF,.DICHNNO,.DILVL,DIFRFILE,"","",1) . S DILVL=DISAVL,DIFILE=DIFRFILE Q ; BACKTRAK(DIFLAGS,DIFILE,DISTACK,DIEN,DIFIEN,DINDEX0,DINDEX,DIDENT,DISCREEN,DILIST) ; ; ; Back up on pointer stack until we get back to home file. ; B1 ; back up one level on stack, recover file #, root, and index file, ; and set value to match equal to the previous level's ien value ; N F,DIVPTR S F=DIFILE("STACK",+DISTACK,+$P(DISTACK,U,2),+$P(DISTACK,U,3)) S DIVPTR=$P(F,U,2),F=+F N DIVALUE D . I 'DIVPTR S DIVALUE=DIEN Q . S DIVALUE=DIEN_";"_$P(DIFILE(+$P(DISTACK,U,3),"O"),U,2) . Q S DISTACK=(+DISTACK)_U_($P(DISTACK,U,2)-1)_U_F I $P(DISTACK,U,2)=1 D Q . N DIROOT1 S DIROOT1=$S($D(DIFILE(F,"NO B")):DIFILE(F,"NO B"),1:DIFILE(F,"O")_"DINDEX0")_")" . I $O(@DIROOT1@(DIVALUE,""))="" S DIEN="" Q . S DINDEX0(1)=DIVALUE,DIEN="" . S DIFILE=+F . S F=$TR(DIFLAGS,"vp") . D WALK^DICLIX(F,.DINDEX0,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,.DINDEX,"",.DIC) . S DIFILE=+$P(DIFILE("STACK"),U,3) . Q ; B2 ; loop through matches on pointer index, ; quit when no matches, if not back to root of pointer chain yet, ; make another recursive call to BACKTRAK to unwind to pointing ; file's matches ; S DIEN="" F D Q:DIEN=""!($G(DIERR)) . N DIROOT1 S DIROOT1=$S($D(DIFILE(F,"NO B")):DIFILE(F,"NO B"),1:DIFILE(F,"O")_"""B""")_")" . S DIEN=$O(@DIROOT1@(DIVALUE,DIEN)) . Q:DIEN="" . D BACKTRAK(.DIFLAGS,.DIFILE,DISTACK,DIEN,DIFIEN,.DINDEX0,.DINDEX,.DIDENT,.DISCREEN,.DILIST) . Q Q ; SETB ; Set temporary "B" index on pointed-to files. Q:'$O(DIFILE("STACK",0)) N I,J,DIFL,DITEMP F I=0:0 S I=$O(DIFILE("STACK",I)) Q:'I F J=0:0 S J=$O(DIFILE("STACK",I,J)) Q:'J F DIFL=0:0 S DIFL=$O(DIFILE("STACK",I,J,DIFL)) Q:'DIFL I $D(DIFILE(DIFL,"NO B")) D . D TMPB^DICUIX1(.DITEMP,DIFL) . S DIFILE(DIFL,"NO B")=DITEMP . D BLDB^DICUIX1(DIFILE(DIFL),DITEMP) . Q Q ; DICLGFT DICLGFT ;GFT/GFT-- USE ANY SORT VALUES FOR LISTER;07MAR2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; DICL ;FROM ^DICL RETURN TO BADQ^DICL WITH DIERR DEFINED OR ELSE WE HAVE DINDEX SET UP CORRECTLY TO GET SORTED OUTPUT N X,I,DITEMP,DICLGFT D TMPB^DICUIX1(.DITEMP,DIFILE) ;SETS DITEMP=something like "^TMP("DICLB",2,3188" S DIGFTEMP=DITEMP_")" ;so we can remember to KILL the temporary array BACKWARD I $G(DINDEX("WAY","REVERSE"))=1 D .S X=$$SORT(DIFILE,DINDEX,DIGFTEMP,,.DIFROM) E D .S X=$$SORT(DIFILE,DINDEX,DIGFTEMP,.DIFROM) S DIFROM(1)="" I X D BLD^DIALOG(-X,$P(X,U,2)) K @DIGFTEMP Q ;We have already done the sort, so "FROM" can be the beginning ;now we have the answers in @DITEMP. ;D COMMON1^DICUIX2 probably need some of this S DICLGFT=$P(X,U,2),DINDEX("#")=DICLGFT ;NUMBER OF LEVELS IN OUR SORT S DINDEX("IXTYPE")="[" F I=1:1:DICLGFT+1 S DINDEX(I,"WAY")=DINDEX("WAY") S DINDEX(1,"ROOT")=DITEMP_")",X=DITEMP F I=1:1:DICLGFT S X=X_",DINDEX("_(I)_")",DINDEX(I+1,"ROOT")=X_")" F I=1:1:DICLGFT S DINDEX(I,"FILE")=DIFILE ;S DINDEX(1,"GET")="DIVAL=ZZZ" ;???????? S DINDEX(1,"TYPE")="[",DINDEX("AT")=1 F I=1:1:DICLGFT S DINDEX(I)=$G(DIFROM(I)) ;FROM VALUES S DINDEX(DICLGFT+1)=0 Q ; ; ; ; SORT(DIFILE,BY,DICLARAY,FR,TO) ;SORT FILE BY TEMPLATE OR FIELD(S), AND PUT RESULTS IN 'DICLARAY' ARRAY ;EXTRINSIC FUNCTION RETURNS ;"OK^n" IF SUCCESSFUL, where 'n' is number of levels ; N L,DIC,FLDS,DHD,DIASKHD,DIPCRIT,PG,DHIT,DIOEND,DIOBEG,DCOPIES,IOP,DQTIME,DIS,DISTOP,DISPAR,DIFIXPTH,DISH,DIS0 N D0,D1,D2,D3,D4,D5,D6,D7,D8,D9,D10,D11,D12,D13 N DIQUIET,DISUPNO S DIQUIET=1,DISUPNO=1 N X N DIOSL S DIOSL=9999999 N DIFIXPT S DIFIXPT=1,DHD="@@" ;TRICK TO AVOID DEVICE SELECTION! S DIOBEG="K ^UTILITY($J,""H"") S DISH=1,IOT="""",$X=0,$Y=0" ;TRICK TO SUPPRESS SUBHEADERS IN SORT TEMPLATE, WHETHER OR NOT THERE IS A PRE-SORT I '$D(^DIC(DIFILE,0,"GL")) Q "401^"_DIFILE S DIC=^("GL") ; N DICLGFT S DICLGFT=1 ; I $G(BY)="" Q "-202^SORT VALUE" DIBT S X=0 I $G(BY)?1"[".E1"]" S X=$O(^DIBT("F"_DIFILE,$TR(BY,"[]"),0)) I X&$O(^(X))!'X Q "-202^SORT TEMPLATE '"_BY_"'" ;MUST HAVE EXACTLY ONE TEMPLATE OF THAT NAME I X S L=$O(^DIBT(X,2,999),-1) I L S DICLGFT=L D G A:$D(X) Q "-202^SORT TEMPLATE '"_BY_"'" ;NUMBER OF LEVELS .F L=1:1:L I $G(^DIBT(X,2,L,"ASK")) K X Q ;NONE OF THE LEVELS MUST ASK ;I X,'L S DICLGFT0=1 ; FIELD N DICLGFTX,DD S DICLGFTX=$G(BY),DICLGFT=$L(DICLGFTX,",") ;SORT BY FIELD S:$D(FR)[0 FR=",,,,,,,,,,,," S:$D(TO)[0 TO=",,,,,,,,,," S DD=DIFILE F S FLDS=$P(DICLGFTX,","),DICLGFTX=$P(DICLGFTX,",",2) Q:FLDS="" D .S FLDS=$P(FLDS,";") I $D(^DD(DD,FLDS,0)) .E S FLDS=$O(^DD(DD,"B",FLDS,0)) Q:'FLDS .S L=+$P(^DD(DD,FLDS,0),U,2) I L S DD=L,DICLGFT=DICLGFT-1 ;GOING DOWN INTO A MULTIPLE, SO LEVEL OF SORT IS 1 LESS THAN WE THOT ; A I DICLARAY["^",DICLARAY'["(" Q "-202^BAD ARRAY "_DICLARAY K ^UTILITY("DICLGFT",$J),@DICLARAY ; DHIT S DHIT="" ;I $G(DICLGFT0) S DHIT="1," ;IF IT IS JUST A LIST F L=1:1:DICLGFT S X="DIOO"_L,DHIT="$S($G("_X_")]"""":"_X_",1:1),"_DHIT S DHIT="("_DHIT_"D0)",DHIT="S @DICLARAY@"_DHIT_"=""""" ;CREATES SOMETHING LIKE DHIT = S @DICLARAY@($S($G(DIOO2)]"":DIOO2,1:1),$S($G(DIOO1)]"":DIOO1,1:1),D0)="" ; S L=0,FLDS="X ""QUIT"";X" S $X=0,$Y=0 ;,IOP="NULL" DIP D EN1^DIP ;HERE IS THE BIG CALL TO FILEMAN'S PRINT MODULE! Q "OK^"_DICLGFT ;EXIT WITH 'DICLGFT' DEFINED AS THE NUMBER OF LEVELS ; ; ; DICLIB DICLIB ;SFISC/TKW - LIBRARY OF FUNCTIONS FOR ^DIC ;05:00 PM 14 Oct 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. NXTNO(F,DA,FLAGS) ;GET NEXT RECORD NUMBER FOR FILE OR SUBFILE F (F CAN CONTAIN A GLOBAL REFERENCE TO IMPROVE EFFICIENCY) ;DA=DA ARRAY (IF F IS A SUBFILE) ;FLAGS (OPTIONAL) IF IT CONTAINS "U", WILL UPDATE LAST REC.# ON 0 NODE N I,X,Y,DIC,% S X=0,I=1 S:'F DIC=$TR(F,")",",") S:F DIC=$$ROOT^DIQGU(F,.DA) G:DIC="" QI G:'$D(@(DIC_"0)")) QI INCR L @("+"_DIC_"0):10") G:'$T QL I 'X S Y=@(DIC_"0)"),X=$P($P(Y,U,3),"."),%=+$P(Y,U,2) I '$D(^DIA(%,"B")) S %=0 F I=1:1 S X=X+1 Q:'$D(@(DIC_X_")"))&$S(%:+$O(^DIA(%,"B",X_","))'=X&'$D(^(X)),1:1) I I=100 S I=0 Q I 'I L @("-"_DIC_"0)") G INCR I $G(FLAGS)["U" S $P(@(DIC_"0)"),U,3,4)=X_U_($P(Y,U,4)+1) L @("-"_DIC_"0)") Q X QI D BLD^DIALOG(200) G Q0 QL D BLD^DIALOG(110,F) Q0 Q 0 ;DIALOG #200 'An input variable or parameter is missing or invalid.' ; #110 'The record is currently locked' DICLIX DICLIX ;SEA/TOAD,SF/TKW-FileMan: Lister, Search Compound Indexes ;6/5/00 10:13 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. ; WALK(DIFLAGS,DINDEX,DIDENT,DIFILE,DIEN,DIFIEN,DISCREEN,DILIST,DINDEX0,DIXV,DIC) ; ; ; a walker to traverse a compound index, taking actions ; DINDEX is an array describing the index and how to walk it ; PREP ; prepare to loop through subscript ; N DISUB S DISUB=DINDEX("AT") N DIVAL S DIVAL=DINDEX(DISUB) N DIPART,DIMORE S DIPART=$G(DINDEX(DISUB,"PART")),DIMORE=+$G(DINDEX(DISUB,"MORE?")) I $G(DINDEX(DISUB,"USE")),DIVAL'="" D . S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIVAL),-DINDEX(DISUB,"WAY")) ; LOOP ; loop through subscripts ; N DIDONE,DISKIP S DIDONE=0 F D Q:DIDONE!$G(DIERR) . S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIVAL),DINDEX(DISUB,"WAY")) . DATA . ; if we're in the data subscripts, we need to walk further . . I DISUB'>DINDEX("#") D Q . . I DISUB=1,$O(DIXV(0)) D LOWSUB . . S DISKIP=0 . . I DIVAL'="",'$D(DINDEX(DISUB,"IXROOT")) D CHK Q:DISKIP . . S:DIVAL="" DIDONE=1 . . Q:DIDONE . . S DINDEX(DISUB)=DIVAL,DINDEX("AT")=DISUB+1 . . I $D(DINDEX("ROOTCNG",DISUB+1)) D BLDTMP^DICLIX1(.DINDEX,.DISCREEN,DIFLAGS,.DIDENT) . . D WALK(.DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,DIFIEN,.DISCREEN,.DILIST,.DINDEX0,"",.DIC) . . S DINDEX("AT")=DISUB . . I $G(DINDEX("DONE"))!$G(DIERR) S DIDONE=1 . . Q . IEN . ; otherwise, we're in the IEN subscripts & need to process . . I DIVAL="" S DIDONE=1 Q . I DINDEX="B" N DISKIPMN,DIMNEM S DISKIPMN=0 D Q:DISKIPMN . . I $D(@DINDEX(DISUB,"ROOT")@(DIVAL))#2 Q:'^(DIVAL) . . E Q:'$O(@DINDEX(DISUB,"ROOT")@(DIVAL,"")) . . I DIFLAGS["M" S DISKIPMN=1 Q . . S DIMNEM="" Q . I $G(DINDEX(DISUB,"TO")) D Q:DIDONE . . Q:$D(DINDEX(DISUB,"IXROOT")) . . D BACKPAST^DICLIX1(DIFLAGS,.DINDEX,DISUB,DIVAL,.DIDONE) Q . D TRY . Q CLEAN ; clean up after loop, exit S DINDEX(DISUB)="" I DISUB>1,$G(DINDEX(DISUB,"PART"))]"" S DINDEX(DISUB)=DINDEX(DISUB,"FROM") Q ; CHK ; See whether we have a match or are at the end of the subscripts. D MATCH I DIDONE,'$G(DINDEX("DONE")),DIMORE D . S DIDONE=0 D FINDMORE^DICLIX0(DISUB,.DIVAL,DIPART,.DINDEX,.DIMORE) I DIVAL="" S DIDONE=1 Q . D MATCH Q Q ; MATCH ; No more subscripts or partial matches, or past our TO value? Q:DIVAL="" I $P(DIVAL,$G(DIPART))'="" S DIDONE=1 Q Q:$G(DINDEX(DISUB,"TO"))="" I DIFLAGS["p" D BACKPAST^DICLIX1(DIFLAGS,.DINDEX0,DISUB,DIVAL,.DIDONE) Q I $G(DINDEX(DISUB+1,"TO"))="" D BACKPAST^DICLIX1(DIFLAGS,.DINDEX,DISUB,DIVAL,.DIDONE) Q ; LOWSUB ; Find next subscript value from multiple pointed-to files N I,DILOWNO,DILOWVAL S DILOWNO=+DIFILE("STACK"),DILOWVAL=DIVAL I DILOWVAL="" D I 'DILOWNO K DIXV Q . K DIXV(DILOWNO),DIFILE("STACKEND",DILOWNO) . S DILOWNO=$O(DIXV(0)),DILOWVAL=$G(DIXV(+DILOWNO,1,"NXTVAL")) . Q N J S J=DILOWNO I DILOWVAL'="" F I=0:0 S I=$O(DIFILE("STACKEND",I)) Q:'I I I'=J D . I DINDEX(1,"WAY")=1,DILOWVAL']]DIXV(I,1,"NXTVAL") Q . I DINDEX(1,"WAY")=-1,DIXV(I,1,"NXTVAL")']]DILOWVAL Q . S DILOWNO=I,DILOWVAL=$G(DIXV(DILOWNO,1,"NXTVAL")) . Q I DILOWNO'=DIFILE("STACK") D . I DIVAL'="" S DIXV(+DIFILE("STACK"),1,"NXTVAL")=DIVAL . S DIFILE("STACK")=DILOWNO_U_DIFILE("STACKEND",DILOWNO) . S DIVAL=DILOWVAL . S DIFILE=+$P(DIFILE("STACK"),U,3) . M DINDEX=DIXV(DILOWNO) Q Q ; TRY ; Apply screens to entry. If passed, add entry to output. S (DIEN,DINDEX(DISUB))=DIVAL I DIFLAGS["p" D . S DINDEX0(1,"EXT")=DINDEX(1) . D BACKTRAK^DICL3(.DIFLAGS,.DIFILE,DIFILE("STACK"),.DIEN,DIFIEN,.DINDEX0,.DINDEX,.DIDENT,.DISCREEN,.DILIST) . S:$G(DINDEX0("DONE")) (DIDONE,DINDEX("DONE"))=1 Q I DIFLAGS'["p" D . N DI0NODE S DI0NODE=$G(@DIFILE(DIFILE)@(DIEN,0)) . Q:$$SCREEN^DICL2(.DIFILE,.DIEN,DIFLAGS,DIFIEN,.DISCREEN,.DINDEX,DI0NODE) . D ACCEPT^DICL2(.DIFILE,.DIEN,.DIFLAGS,DIFIEN,.DINDEX,.DIDENT,.DILIST,DI0NODE) . Q Q:$G(DIERR)!($G(DINDEX("DONE"))) I DIDENT(-1)=DIDENT(-1,"MAX") D . I 'DIDENT(-1,"JUST LOOKING") S DIDONE=1,DINDEX("DONE")=1 Q . ; If called from online DIC help ^DICQ, display list. . Q:DIFLAGS'["h" . K DTOUT,DUOUT S DICQ(0,"MAP")=DIDENT(-3) . D DSP^DICQ1(.DINDEX,.DICQ,.DIC,.DIFILE) . I $G(DTOUT)!($G(DUOUT)) S (DINDEX("DONE"),DIDONE)=1 Q . S DILIST("ORDER")=$S(DINDEX("WAY")=1:0,1:DIDENT(-1,"MAX")+1) . S DIDENT(-1)=0,DIDENT(-1,"JUST LOOKING")=0 Q Q ; ; DICLIX0 DICLIX0 ;SEA/TOAD,SF/TKW-FileMan: Continuation of DICLIX ;7/31/98 09:03 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. ; FINDMORE(DISUB,DIVAL,DIPART,DINDEX,DIMORE) ; Look across the numeric/string collation boundary ; Searching forwards N S,DIOUT S DIOUT=0 I DINDEX(DISUB,"WAY")=1 D Q . I +$P(DIVAL,"E")=DIVAL,DIPART'=0 F D Q:DIOUT!(+$P(DIVAL,"E")'=DIVAL) . . I DIPARTDIVAL,((DIPART[".")!(DIPART>0)) S DIVAL="" Q I DIPART<0,DIVAL>DIPART D . I $D(@DINDEX(DISUB,"ROOT")@(DIPART)) S DIVAL=DIPART Q . S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIPART),-1) Q Q:$E(DIVAL,1,$L(DIPART))=DIPART!(DIVAL="") F D Q:DIOUT!(DIVAL="") . I DIPART>DIVAL,((DIPART[".")!(DIPART>0)) S DIVAL="" Q . D NXT(.DIVAL,DIPART,-1,DINDEX(DISUB,"ROOT"),.DIOUT) Q Q NXT(DIVAL,DIPART,DIWAY,DIROOT,DIOUT) ; Skip values we don't need to look at within numeric entries N DIPART2,DIVAL2,I,P,V S DIPART2=$P(DIPART,"."),DIVAL2=$P(DIVAL,".") S P=$S(DIPART<0:-DIPART2,1:DIPART2) S V=$S(DIVAL<0:$E(DIVAL2,2,($L(P)+1)),1:$E(DIVAL2,1,$L(P))) S I=$L(DIVAL2) I DIWAY=1&(DIPART>0)!(DIWAY=-1&(DIPART<0)) D . S:V>P I=I+1 Q E D . S DIPART2=DIPART2+$S(DIPART>0:1,1:-1) . I P>V,$L(DIPART2)=$L($P(DIPART,".")) S I=I-1 S V="",I=I-$L(DIPART2)+1 S:I>1 $P(V,"0",I)="" S DIVAL=DIPART2_V I $E(DIVAL,1,$L(DIPART))=DIPART,$D(@DINDEX(DISUB,"ROOT")@(DIVAL)) S DIOUT=1 Q S DIVAL=$O(@DIROOT@(DIVAL),DIWAY) S:$E(DIVAL,1,$L(DIPART))=DIPART DIOUT=1 Q ; ; DICLIX1 DICLIX1 ;SEA/TOAD,SF/TKW-FileMan: Lister, Search Compound Indexes (cont.) ;11/5/99 15:13 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. ; BLDTMP(DINDEX,DISCREEN,DIFLAGS,DIDENT) ; Build temporary index of external values when pointer/vp subscript is encountered. N DISUB,DIXSAV,DIX,DIDOUT S DIDOUT=0 S DIX("AT")=DINDEX("AT") K @DINDEX(DIX("AT"),"ROOT") N I S I=$S(DIX("AT")=1:1,1:DIX("AT")-1) F DISUB=I:1:DINDEX("#")+1 D . S (DIXSAV(DISUB),DIX(DISUB))=DINDEX(DISUB) . I "VP"[$G(DINDEX(DISUB,"TYPE")) S DIX(DISUB)="" D BT1 F DISUB=DINDEX("AT"):1:DINDEX("#")+1 S DINDEX(DISUB)=DIXSAV(DISUB) Q ; BT1 N DISUB S DISUB=DIX("AT") N DIVAL,DISINT,DIDONE,DIPART,DIMORE S DISINT=DIX(DISUB),DIDONE=0 F D Q:DIDONE . S DISINT=$O(@DINDEX(DISUB,"IXROOT")@(DISINT),DINDEX(DISUB,"WAY")) . S:DISINT="" DIDONE=1 Q:DIDONE . I DISUB'>DINDEX("#") D Q . . S DIVAL=DISINT,DIPART=$G(DINDEX(DISUB,"PART")),DIMORE=$G(DINDEX(DISUB,"MORE?")) . . I DINDEX(DISUB,"TYPE")="V",$G(DISCREEN("V",DISUB))]"" D Q:DIVAL="" . . . N G S G="^"_$P(DISINT,";",2) Q:G="^" . . . S:'$D(DINDEX(DISUB,"VP",G)) DIVAL="" Q . . I "VP"[DINDEX(DISUB,"TYPE") D I DIVAL="" S DIDONE=1 Q . . . S DIVAL=$$EXTERNAL^DIDU(DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),"i",DIVAL) . . . Q:'$G(DIERR) . . . I DIFLAGS["h" K DIERR,^TMP("DIERR",$J) Q . . . S DIVAL="",DINDEX("DONE")=1 Q . . D CHK^DICLIX I DIDONE D Q . . . I $G(DINDEX("DONE")) S DIDOUT=1 Q . . . S:DIVAL]"" DIDONE=0 Q . . I DISUB=1,"VP"[DINDEX(1,"TYPE") S @DINDEX(1,"ROOT")@(DIVAL)=DISINT . . S DINDEX(DISUB)=DIVAL,DIX(DISUB)=DISINT,DIX("AT")=DISUB+1 . . D BT1 . . S DIX("AT")=DISUB . . I $G(DIDOUT) S DIDONE=1 . . Q . Q:DIDONE . I $G(DINDEX(DISUB,"TO")) D Q:DIDONE . . D BACKPAST(DIFLAGS,.DINDEX,DISUB,DISINT,.DIDONE) . . S:DIDONE DIDOUT=1 Q . S @DINDEX(DISUB,"ROOT")@(DISINT)="" S DIX(DISUB)="" Q ; BACKPAST(DIFLAGS,DINDEX,DISUB,DIVAL,DIDONE) ; Have we gone past TO value? Lister only. N I,DIOUT S DIOUT=0 F I=1:1:DISUB D Q:DIOUT . N V S V=$S(I=DISUB:DIVAL,1:DINDEX(I)) . I I=1,DIFLAGS'["p","PV"[DINDEX(1,"TYPE") S V=DINDEX(I,"EXT") . Q:V=DINDEX(I,"TO") . I DINDEX(I,"WAY")=1,DINDEX(I,"TO")]]V S DIOUT=1 Q . I DINDEX(I,"WAY")=-1,V]]DINDEX(I,"TO") S DIOUT=1 Q . S DIVAL="",(DIOUT,DIDONE,DINDEX("DONE"))=1 Q . Q Q:DIOUT S DIVAL="",(DIDONE,DINDEX("DONE"))=1 Q ; ; DICM DICM ;SFISC/GFT,XAK,TKW-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;27OCT2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; I '$D(DICR(1)),DIC(0)'["T" N DICR S DICR=0 I $A(X)=34,X?.E1"""" G N I $G(^DD(+DO(2),0,"LOOK"))]"",^("LOOK")'="SOUNDEX" G @^("LOOK") I DIC(0)["U" S DD=0 G W I DIC(0)["T" G 2 R N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M") N DIFORCE D . S DIFORCE=0 I DIC(0)'["M"!($D(DID)) S DIFORCE=1 . S DIFORCE(0)=$S(DIC(0)'["M":DINDEX,$D(DID):DID,1:"*"),DIFORCE(1)=1 F D 1 I DINDEX=""!(Y>0)!($G(DTOUT))!($G(DIROUT)) Q ;LOOP THRU ALL THE INDEXES! G 2 ; 1 N DS,%Y,DIV I $G(DINDEX("IXFILE")) S Y=DINDEX(1,"FILE"),%Y=DINDEX(1,"FIELD") E S Y=$O(^DD(+DO(2),0,"IX",DINDEX,0)) S:Y="" Y=-1 S %Y=+$O(^(Y,0)) I Y=-1,DINDEX="B" S Y=+DO(2),%Y=.01 S:Y="" Y=-1 S:%Y="" %Y=-1 I $D(DICR(U,Y,%Y,DINDEX)) S Y=-1 ;HAVE WE ALREADY TRIED THIS INDEX? E I %Y=.01,DINDEX'="B",Y=+DO(2),$D(DICR(U,Y,%Y,"B")),$G(DINDEX(1,"TRANCODE"))="" S Y=-1 ;! I Y'<0 D . S DS=$G(^DD(Y,%Y,0)) I DS="" S Y=-1 Q . S %=DINDEX,DICR(U,Y,%Y,DINDEX)=0 . I $D(^DD(Y,%Y,7)) D RS K DS X ^(7) Q . I $G(DINDEX("IXTYPE"))="S" D A,SOU^DICM1,D Q:Y>0 S Y=-1 Q . S DIX=Y,Y=$P(DS,U,2) I Y["P",DIC(0)'["L",$T(ORDERQ^DICUIX2)]"",$$ORDERQ^DICUIX2(+$P(Y,"P",2)) S Y="" ;TRICK TO SPEED LOOKUP OF ORDERS! . S Y=$S(Y["P":"P",Y["D":"D",Y["S":"S",Y["V":"V",1:"") ;TRANSFORMATION WILL BE NECESSARY IF X-REF'D FIELD IS DATE, POINTER, SET OR VARIABLE-POINTER . I Y]"" D A D:'Y ^DICM1,D Q:Y>0 S Y=-1 Q . I $G(DINDEX(1,"TRANCODE"))]"" S Y="T" D A,^DICM1 N DITRANX S DITRANX=1 D D . Q:Y>0 S Y=-1 Q Q:Y>0!(DIC(0)["T") D . K DIV M DIV=X S DIV(1)=X N X,Y . D NXTINDX^DICF2(.DINDEX,.DIFORCE,.DIFILEI,DIFLAGS,.DIV,"*") Q Q ; 2 D D^DIC0 S %=D ;HERE'S WHERE WE TRY ALTERNATE LOOKUPS: UPPER CASE, COMMA-PIECING, TRUNCATE LONG INPUT G K:Y>0!($G(DIROUT)) I X?.E1L.E,DIC(0)'["X" D G K:$G(DIROUT) ;CONVERT TO UPPER-CASE . D % N DIFILEI,DINDEX . S DIC(0)=$TR(DIC(0),"L"),X=$$UP^DILIBF(X) S:$G(DILONGX) DICR(DILONGX,"ORG")=X . D DIC Q I Y'>0,X["," S DS="",DIX=$P(X,",") I DIC(0)'["X",$L(DIX)<31 D G K:$G(DIROUT) ;COMMA-PIECING . F %=2:1 S DD=$P(X,",",%) I DD'["""" D Q:DD="" . . F Q:$A(DD)-32 S DD=$E(DD,2,999) . . F Q:$A(DD,$L(DD))-32 S DD=$E(DD,1,$L(DD)-1) . . I $L(DD)*2+$L(DS)>200!(DD="") S DD="" Q . . S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))" Q . Q:DS="" S %=D . D % S X=DIX N DILONGX . S DS="S %=$P(^(0),U)"_DS,DIC(0)=DIC(0)_"D" D 7 Q I Y'>0,$L(X)>30 D ;LONG DATA . N DILONGX . S %=D D % S DILONGX=DICR,Y="DICR("_DICR_")",DICR(DICR,"ORG")=X . S DS=$S(DIC(0)["X":"I DIVAL="_Y,1:"I '$L($P(DIVAL,"_Y_"))") . S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" . D 7 I Y>0!(X'?.E1L.E)!(DIC(0)["X") Q . S %=D D % S (X,DICR(DICR,"ORG"))=$$UP^DILIBF(X) . S Y="DICR("_DICR_",""ORG"")" . S DS="I '$L($P(DIVAL,"_Y_"))" S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" . D 7 ; K S DICR=+$G(DICR),DD=$D(DICR(DICR,6)) K:'DICR DICR I Y>0 K DIC("W") D R^DIC2 Q I $G(DTOUT)!($G(DIROUT)) Q W I @("$O("_DIC_"""A[""))]""""") G NL:DIC(0)["N",DD I DO(2)'["Z" S Y=0 D Q:Y>0!($G(DIROUT)) DINUM .I $G(DINDEX("1","FIELD"))=.01,X?1.15NP,$P($G(^DD(+DO(2),.01,0)),U,5,99)["DINUM=X",$P($G(@(DIC_"X,0)")),U)=X D Q:Y>0 ..S Y=X I 1 X:$D(DIC("S")) DIC("S") I S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 Q ..S Y=0 .N DIOUT S DIOUT=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") D Q:DIOUT ;GO THRU THE WHOLE FILE BECAUSE WE HAVE NO CROSS-REFERENCE! (SEE ..DOTS.. BELOW) . . I 'Y S Y=-1,DIOUT=1 Q . . W:DIC(0)["E"&(DS#20=0) ".." . . I $D(@(DIC_Y_",0)")),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I S DIOUT=1 . . I DIOUT S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 . . Q NL I '$G(DICR) D NQ I $T D Q:Y>0!($G(DTOUT))!($G(DIROUT)) . N:'$G(DIASKOK) DIASKOK S (DS,DIASKOK)=1 N DZ,DD . D ADDKEY^DIC3,GOT^DIC2 Q DD S Y=-1 I DD D BAD^DIC1 Q L I DIC(0)["L" K DD G ^DICN B D BAD^DIC1 Q ; N D RS S X=$E(X,2,$L(X)-1),%=D D . I DINDEX("#")>1 S %Y=+$G(DINDEX(1,"FIELD")),DS=$G(^DD(+$G(DINDEX(1,"FILE")),%Y,0)) Q:DS]"" . S DS=^DD(+DO(2),.01,0),%Y=.01 Q F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 S:$D(X)#2 DS("INT")=X Q I $D(X),DINDEX("#")>1 S X(1)=X S Y=-1 D L:$D(X),E I Y'>0 K DUOUT D BAD^DIC1 Q G 2 ; A ; Set variables needed for transforming date/set/ptr/var.ptr S DICR(DICR+1,4)=% D % K DF,DID,DINUM Q ; % ; Set variables up before doing lookup w/transformed value I DIC(0)'["L" S DICR(DICR+1,8)=1 E I '$$OKTOADD^DICM0(.DIFILEI,.DINDEX,.DIFINDER) S DICR(DICR+1,8)=1 I $G(DINUM)]"" S DICR(DICR+1,10)=DINUM I $D(DF) S DICR(DICR+1,9)=DF S:$G(DID)]"" DICR(DICR+1,9.1)=$G(DID(1))_U_DID RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DIC(0)=$TR(DIC(0),"A"),DIC(0)=$TR(DIC(0),"Q") Q ; D S:$G(DICR(DICR,10))]"" DINUM=DICR(DICR,10) S (D,DF)=DICR(DICR,4) D . N T S T=$P($G(DS),U,2) . S DIC(0)=$TR(DIC(0),"M","") I T["V" S DIC(0)=$TR(DIC(0),"A","") . I D="B",T'["D",'$G(DITRANX) S DIC(0)=DIC(0)_"s" . I T["P"!(T["V")!(T["S") S DIC(0)=DIC(0)_"X" . Q I DICR(DICR,4)=DINDEX N I M I=DINDEX N DINDEX M DINDEX=I K I S DINDEX("START")=DINDEX E N DINDEX D . S (DINDEX,DINDEX("START"))=DICR(DICR,4),DINDEX("WAY")=1 . D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVALUE) Q I DINDEX("#")>1 S (DINDEX(1),DINDEX(1,"FROM"),DINDEX(1,"PART"))=$G(X) RCR S:'$D(DIDA) DICRS=1 DIC ; I $D(DICR(DICR,8)) S DIC(0)=$TR(DIC(0),"L") S Y=-1 I $D(X) D ;**22*159 WAS: I $D(X),$L(X)<31 D . N DIVAL S (DIVAL,DIVAL(1))=X N X S (X,X(1))=DIVAL . D RENUM^DIC1 K DIDA Q I $G(DICR) S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF ;**GFT 12/18/07 E S D="B" D:$G(DICR) ;**GFT 1/3/06 .S %=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1 .S:$G(DICR(%,10))]"" DINUM=DICR(%,10) .S:$D(DICR(%,9)) (D,DF)=DICR(%,9) I $G(DICR(%,9.1))]"" S:$P(DICR(%,9.1),U)]"" DID(1)=$P(DICR(%,9.1),U) S DID=$P(DICR(%,9.1),U,2,999) .K DICRS,DICR(%) D DO^DIC1:'$D(DO(2)) Q ; NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC3 Q ; SOUNDEX I DIC(0)["E",'$D(DICRS) W " " D RS,SOU S DIC(0)=$TR(DIC(0),"L") D RCR Q:Y>0 G R ; 7 S Y=-1 N % S %=$S($D(DIC("S")):DIC("S"),1:1) ;RECURSIVE CALL TO ^DIC! I $D(DS),'$D(DIC("S1")) D . S DIC("S")=DS I '% S DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=% . I X]"" D . . N DIVAL S (DIVAL,DIVAL(1))=X,DIVAL(0)=1 N X S (X,X(1))=DIVAL . . N DINDEX,DIFILEI . . S DIC(0)=$TR(DIC(0),"L") D F^DIC . K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1") D E Q ; SOU D SOU^DICM1 Q DICM0 DICM0 ;SF/XAK,TKW - LOOKUP WHEN INPUT MUST BE TRANSFORMED ;2/15/00 14:40 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; P ;Pointers, called by ^DICM1 S D="" N DICODE,DIASKOK,DIPTRIX S DICR(DICR,1)=DIC,DIC=U_$P(DS,U,3),Y=DIC(0),DIC(0)=$TR(Y,"L","") S DICR(DICR,2)=$S($$OKTOADD(.DIFILEI,.DINDEX,.DIFINDER):Y,1:DIC(0)) S DICR(DICR,2.1)=$S($P(DS,U,2)["'":DIC(0),1:Y) N:'$D(DIVPSEL) DIVPSEL S DIVPSEL(DICR)=0 I DIC(0)["B" S DIC(0)=$TR(DIC(0),"M",""),DICR(DICR,2.1)=$TR(DICR(DICR,2.1),"M","") S DIC(0)=$TR(DIC(0),"NV","") F Y="DR","S","P","W" I $D(DIC(Y)) M DICR(DICR,Y)=DIC(Y) K DIC(Y) S DIPTRIX=$G(DIC("PTRIX",DIFILEI,+DINDEX(1,"FIELD"),+$P($P(DS,U,2),"P",2))) AST ; Process screens on pointers. I $P(DS,U,2)["*",DICR(DICR,2)["L" N DID,DF D . F DICODE=" D ^DIC"," D IX^DIC"," D MIX^DIC1" D . . S Y=$F(DS,DICODE) Q:'Y . . N I S I=$P($E(DS,1,Y-$L(DICODE)-1),U,5,99) . . D SETSCR(I,.DICR,.DIC,.D,DICODE,.DID,.DF,+$P($P(DS,U,2),"P",2)) Q . Q P1 ; Build screen to make sure selected entry is pointed-to. S Y="("_DICR(DICR,1) G L1:'$D(DO) K DO I @("$O"_Y_"0))'>0") G L1 S I="DIC"_DICR,DICODE="X ""I 0"" N "_I D . I DINDEX("#")=1,$D(DICR(DICR,"S")) S DICODE=DICODE_",%Y"_DICR . S DICODE=DICODE_" F "_I_"=0:0 S "_I_"=$O"_Y,%=""""_%_"""" D G:DICODE="" L1 . I $G(DINDEX("#"))>1 D BLDC(Y,%,DINDEX("#"),DIFILEI,"",.DICODE,.DICR) Q . I @("$O"_Y_%_",0))>0") S DICODE=DICODE_%_",Y,"_I_")) Q:"_I_"'>0 I $D"_Y_I_",0))"_$$CHKTMP(.DIC,DICR,DIFILEI,I) Q . I DS["DINUM=X" S DICODE="I $D"_Y_"Y,0))"_$$CHKTMP(.DIC,DICR,DIFILEI,"Y")_" S "_I_"=Y" Q . I $P(DS,U,4)="0;1" S DICODE=DICODE_I_")) Q:"_I_"'>0 I $P(^("_I_",0),U)=Y"_$$CHKTMP(.DIC,DICR,DIFILEI,I) Q . S DICODE="" Q I DINDEX("#")=1,$D(DICR(DICR,"S")) S DICODE=DICODE_" S %Y"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I " S DIC("S")=DICODE_" Q" ; If user passed list of indexes for lookup on pointed-to file, set-up. I DIPTRIX]"" S D=DIPTRIX D SETIX(.D,.DIC,.DID,.DF,.DICR,+$P($P(DS,U,2),"P",2)) S:$G(D)="" D="B" S Y=0 N DS,DINDEX,DIFILEI D X^DIC L1 K DIC("S"),@("DIC"_DICR) I Y'>0 I $G(DTOUT)!($G(DIROUT)) G R I Y'>0,'$D(DICR(DICR,8)) D G RETRY . I $G(DICR(DICR,31.2)) S DIC("S")="I Y-"_DICR(DICR,31.2) . Q:'$D(DICR(DICR,31)) . S DIC("S")=$S($D(DIC("S")):DIC("S")_" ",1:"")_DICR(DICR,31) Q I DICR(DICR,2)["L",DICR(DICR,2)["E",@("$P("_DIC_"0),U,2)'[""O"""),$P(@(DICR(DICR,1)_"0)"),U,2)'["O",'DIVPSEL(DICR) D G:%-1 L2 . N I F I=(DICR-1):-1 Q:'$D(DIVPSEL(I)) S DIVPSEL(I)=1 . S DST=" ...OK",%=1 D Y^DICN W:'$D(DDS) ! Q R K DICS,DICW,DO,DIC("W"),DIC("S") S DIC=DICR(DICR,1),%=DICR(DICR,2),DIC(0)=$P(%,"M")_$P(%,"M",2) F X="DR","S","P","W" I $D(DICR(DICR,X)) M DIC(X)=DICR(DICR,X) I $D(DIC("P")),+DIC("P")=.12 S DIC(0)=DIC(0)_"X" D DO^DIC1 S X=+Y K:X'>0 X Q ; L2 G NO:%-2 S DIC("S")="I Y-"_+Y_$S($D(DICR(DICR,31)):" "_DICR(DICR,31),1:""),X=DICR(DICR) W:'$D(DDS) " "_X I $D(DDS),$G(DDH) D LIST^DDSU K DST ; RETRY D DO^DIC1 K DICR(U,+DO(2)) S D=$G(DICR(DICR,2.2)) S:D]"" DF=D S:D="" D="B" S DIC(0)=DICR(DICR,2.1) S:"^"[X X=DICR(DICR) I $D(DIFILEI) N DS,DINDEX,DIFILEI I $D(DICR(DICR,31)),$G(DA(1)),'$G(DA) M DS=DA N DA M DA=DS S DA=DA(1) K DS I $D(DICR(DICR,31.1)) S DID=DICR(DICR,31.1),DID(1)=2,DF=D D X^DIC K DICR(DICR,6) G R ; BLDC(DIGBL,DIXNAM,DIXNO,DIFILEI,DIPGBL,DICODE,DICR) ; Build screening logic to loop through compound index, making sure pointed-to file is pointed-to by entry in index N %,I,C,X,Y,DISB S Y="Y" I $G(DIPGBL)]"" S Y="(+Y_"";"_$E(DIPGBL,2,99)_""")" S %=DIGBL_DIXNAM_","_Y S DICODE="N DICROUT,DIC"_DICR D . I $D(DICR(DICR,"S")) S DICODE=DICODE_",%Y"_DICR . S DICODE=DICODE_" X ""I 0"" I $D"_%_")) S DICROUT=0 X DICR("_DICR_",""SUB"",2)" Q F I=2:1:DIXNO S C="N DISB"_I_" S DISB"_I_"="""" " D . S C=C_"F S DISB"_I_"=$O"_%_",DISB"_I_")) Q:DISB"_I_"="""" X DICR("_DICR_",""SUB"","_(I+1)_") Q:DICROUT" . S DICR(DICR,"SUB",I)=C . S %=%_",DISB"_I Q S I="DIC"_DICR S X="S "_I_"=0 F S "_I_"=$O"_%_","_I_")) Q:'"_I_" I $D"_DIGBL_I_",0))"_$$CHKTMP(.DIC,DICR,DIFILEI,I) I $D(DICR(DICR,"S")) S X=X_" S %Y"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I" S DICR(DICR,"SUB",DIXNO+1)=X_" S DICROUT=1 Q" Q ; CHKTMP(DIC,DICR,DIFILEI,DIVAR) ; If DIC(0)["T", add check to make sure entry hasn't already been presented once before. I DIC(0)'["T"!(DICR'=1) Q "" Q ",'$D(^TMP($J,""DICSEEN"","_DIFILEI_","_DIVAR_"))" ; SETSCR(DICODE,DICR,DIC,D,DICALL,DID,DF,DIFILEI) ; Execute screening logic for screened pointers and var.ptrs. N DISAV0 S DISAV0=DIC(0) D S DIC(0)=DISAV0 . N DISAV0 X DICODE Q S:DIC(0)["B" D="B" I $D(DIC("S")) S DICR(DICR,31)=DIC("S") Q:$G(D)="" I $P(D,U,2)="",DICALL["IX^DIC",DIC(0)["M" D SETIX(.D,.DIC,.DID,.DF,.DICR,DIFILEI) Q I $P(D,U,2)]"",DICALL["MIX^DIC1" D SETIX(.D,.DIC,.DID,.DF,.DICR,DIFILEI) Q S DICR(DICR,2.2)=D Q ; SETIX(D,DIC,DID,DF,DICR,DIFILEI) ; If user passes list of indexes to use on pointed-to file, set up to use them. I '$G(DICR) N DICR S DICR=0 I DICR D . N % S %=DICR(DICR,2.1) . I %["L",(U_D_U)'["^B^" N D S D=I_"^B" . I $P(D,U,2)="" D . . I %["M" S DICR(DICR,2.1)=$TR(%,"M") . . K DICR(DICR,31.1) Q . I $P(D,U,2)]"" D . . I %'["M" S DICR(DICR,2.1)=%_"M" . . S DICR(DICR,31.1)=D_"^-1" Q . S DICR(DICR,2.2)=$P(D,U) Q I DIC(0)["L",(U_D_U)'["^B^" S D=D_"^B" I $P(D,U,2)="" D . I DIC(0)["M" S DIC(0)=$TR(DIC(0),"M") . S (D,DF)=$P(D,U) K DID Q I $P(D,U,2)]"" D . S DID=D_"^-1",DID(1)=2,(D,DF)=$P(D,U) . S:DIC(0)'["M" DIC(0)=DIC(0)_"M" Q Q ; NO S Y=-1 G R ; OKTOADD(DIFILEI,DINDEX,DIFINDER) ; Return 1 if index is OK for LAYGO. Q:$G(DINDEX(1,"TRANCODE"))]"" 0 Q:$G(DIFINDER)="p" 1 Q:DINDEX="B" 1 Q:DINDEX("#")=1 0 Q:$D(DICR("^",DIFILEI,.01,"B")) 0 Q:DINDEX(1,"FILE")'=DIFILEI 0 Q:DINDEX(1,"FIELD")'=.01 0 Q 1 ; DICM1 DICM1 ;SFISC/XAK,TKW-LOOKUP WHEN INPUT MUST BE TRANSFORMED ; 20 Jun 2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. G @Y ; P ;POINTERS G P^DICM0 ; D ;DATES I $S(X'?.N:1,$L(X)>15:0,1:X>49) S %DT=$S($D(^DD(+DO(2),.001)):"N",1:"")_$P($P(DS,"%DT=""",2),"""") F %="E","R" D DZ I D ^%DT S X=Y K %DT I X>1 D Q . I $D(DINDEX(1,"TRANCODE"))#2 D Q . . X DINDEX(1,"TRANCODE") I $G(X)="" K X S Y=-1 Q . . I ('$D(DINDEX(1,"TRANOUT"))#2)!(DIC(0)'["E")!($D(DDS)) Q . . N % S %=X N X S X=% X DINDEX(1,"TRANOUT") W " ",X Q . Q:DIC(0)'["E" . I '$D(DDS) W " " D DT^DIQ . S DIDA=1 Q K X Q DZ S %DT=$P(%DT,%)_$P(%DT,%,2) Q ; S ;SETS N A8,A9,DDH S DDH=0 I $P(DS,U,2)["*"!($D(DIC("S"))) D SC S DICR(DICR,1)=1,I=$P(DS,U,3),DD=$P(";"_I,";"_X_":",2) N DS S DS=0 I DD]"" S Y=X X:$D(A9) A9 I D SDSP,SK Q SS S DICMF=0 F DICM=1:1 S DD=$P(I,";",DICM) Q:DD="" I $P($P(DD,":",2),X)="" D . S Y=$P(DD,":"),DD=$P(DD,":",2) Q:DIC(0)["X"&(DD'=X) . I $D(A9) X A9 E Q . I DIC(0)["O"!(DIC(0)'["E") S:DD=X DICMF=1 I DD'=X,DICMF=1 Q . S DS=DS+1 D SDSP . S DS(DS)=Y_"^ "_DDH_" "_DDH(DDH,Y) G:DDH=0 NO I DDH=1 D G SK . S X=$O(DDH(1,"")) . W:DIC(0)["E"&('$D(DDS)) " ("_DDH(1,X)_")" . S:$D(DS(1,"T")) X=DS(1,"T") Q G:DIC(0)'["E" NO I $D(DDS) S DD=DDH,DDD=2 K DDQ D LIST^DDSU K DDD,DDQ G:$D(DTOUT) NO I '$D(DDS) F D Q:DICM'="AGN" . F DICM=1:1:DDH W !,$P(DS(DICM),U,2,999) . W !,"CHOOSE 1-"_DDH_": " . R DIY:$S($D(DTIME):DTIME,1:300) E Q . Q:U[DIY!(DIY[U) I DIY?1.N,$D(DS(+DIY)) Q . W $C(7),"??" S DICM="AGN" G:+$P(DIY,"E")'=DIY NO G:'$D(DS(+DIY)) NO S X=$P(DS(DIY),U) I '$D(DDS) W " "_DDH(DIY,X),! S:$D(DS(DIY,"T")) X=DS(DIY,"T") G SK ; NO K X,Y S Y=-1 SK K DIC("S") S:$D(A8) DIC("S")=A8 K DDH,DICM,DICMF,DICMS Q SC ;SCREENS ON SETS S:$D(DIC("S")) A8=DIC("S") Q:$P(DS,U,2)'["*" Q:'$D(^DD(+DO(2),.01,12.1)) X ^(12.1) Q:'$D(DIC("S")) S Y="("_DIC,I="DIC"_DICR,%=""""_%_"""",A9="X DIC(""S"")" Q:$G(DICR(DICR))?1"""".E1"""" ;I DS["DINUM=X" S D=D_" E I $D"_Y_"Y,0))" Q S A9=A9_" E F "_I_"=0:0 S "_I_"=$O"_Y I @("$O"_Y_%_",0))'=""""") S A9=A9_%_",Y,"_I_")) Q:"_I_"="""" "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$D"_Y_I_",0)) Q" Q S A9=A9_I_")) Q:'"_I_" "_$S($D(A8):"X ""N Y S Y="_I_" ""_A8 I $T,",1:"I ")_"$P(^("_I_",0),U)=Y Q" Q ; SDSP ; Execute screen, transform, set up output for display N DISAVX,DISAVY,DIXX,DIOUT S DIOUT=0,DIXX=Y S DDH=DDH+1,DDH(DDH,Y)=$P(" (^",U,(DS=0))_Y I $D(DINDEX(1,"TRANCODE"))#2 D S:'DIOUT&('DS) X=DIXX I DIOUT S Y=-1 Q . S DISAVY=Y N X,Y S X=DISAVY . X DINDEX(1,"TRANCODE") I $G(X)="" S DIOUT=1 Q . S DIXX=X I DS S DS(DS,"T")=X Q I $G(DINDEX(1,"TRANOUT"))]"" D . S DISAVY=Y N X,Y S X=DIXX X DINDEX(1,"TRANOUT") . S DDH(DDH,DISAVY)=$P(" (^",U,(DS=0))_$G(X) Q S DDH(DDH,Y)=DDH(DDH,Y)_" "_$P(DD,";")_$P(")^",U,(DS=0)) I DS=0,DIC(0)["E",'$D(DDS) W DDH(DDH,Y) Q ; V ;VARIABLE POINTER I X["?BAD" K X Q D ^DICM2,DO^DIC1 Q ; T ; Execute TRANSFORM code for indexes other than Pointers, Date, VP or Sets. N DIXX S DIXX=X X DINDEX(1,"TRANCODE") I $G(X)="" K X S Y=-1 Q I DIXX=X K X S Y=-1 Q ; SOU ; S DSOU="01230129022455012623019202",DSOV=X,X=$C($A(X)-(X?1L.E*32)),DIX=$E(DSOU,$A(X)-64) F DIY=2:1 S Y=$E(DSOV,DIY) Q:","[Y I Y?1A S %=$E(DSOU,$A(Y)-$S(Y?1U:64,1:96)) I %-DIX,%-9 S DIX=% I % S X=X_% Q:$L(X)=4 S X=$E(X_"000",1,4) K DSOU,DSOV Q ; ACT ; S DIY=Y,DIY(1)=DIC,DIC("W")="",DIX=X A I $G(DO(2)) X:$D(^DD(+DO(2),0,"ACT")) ^("ACT") I Y<0 S DIC=DIY(1),X=DIX G W I $G(DO(2))["P" N % S %=^DD(+DO(2),.01,0) I $P(%,U,2)["P",$P(%,U,3)]"" S DIC=U_$P(%,U,3) D DO I $D(@(DIC_+$P(Y,U,2)_",0)")) S Y=+$P(Y,U,2)_U_$P(^(0),U) G A S Y=DIY,DIC=DIY(1),X=DIX W K DIC("W") DO K DO D DO^DIC1 Q DICM2 DICM2 ;SFISC/XAK/TKW-LOOKUP FOR VAR PTR ;2/15/00 14:55 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N A9,DIEX,DISAVIEX,DIV,DIVDIC,DIVDO,DIVP,DIVP1,DIVP2,DIVPDIC,DIVY,DIASKOK S DIVDO=+DO(2),DIVDIC=DIC,DIVY=%Y N DIADD,DS F %="DR","W","P","V","A" I $D(DIC(%)) M DIV(%)=DIC(%) K DIC(%) I $D(DIC("S")) S DICR(DICR,"S")=DIC("S") K DIC("S") K DO,DUOUT S (DIEX,DISAVIEX)=X I '$D(DICR(DICR,"V")) D . I DIC(0)'["L" S DICR(DICR,"V")=1 Q . S:DICR>1 DICR(DICR,"V")=1 Q G ALL:X'["." I $P(X,".",2,999)="" S Y=-1 G ALL V S DIVP=$P(DIEX,"."),A9=1 I DIVP="" G ALL I $D(^DD(DIVDO,DIVY,"V","P",DIVP)) S (DIVP,DIVPDIC)=+$O(^(DIVP,0)),DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"") G Q:'DIVPDIC S X=$P(DIEX,".",2,999),A9=0 D ^DICM3 G Q S DIVP2="",DIVP=$P(DIEX,".") F %=0:0 S DIVP2=$O(^DD(DIVDO,DIVY,"V","M",DIVP2)) Q:DIVP2="" I $P(DIVP2,DIVP)="" D G Q:'DIVPDIC D ^DICM3 G Q:Y>0 S DIVP=$P(DIEX,".") . S (DIVP,DIVPDIC)=+$O(^DD(DIVDO,DIVY,"V","M",DIVP2,0)) . S DIVPDIC=$S($D(^DD(DIVDO,DIVY,"V",DIVP,0)):^(0),1:"") . S X=$P(DIEX,".",2,999),A9=0 Q F DIVP=0:0 S DIVP=+$O(^DD(DIVDO,DIVY,"V",DIVP)) Q:'DIVP I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S %=$P(^(0),U) I $P(%,$P(DIEX,"."))="" S X=$P(DIEX,".",2,999),A9=0 D ^DICM3 G Q:Y>0 S X=DIEX I A9,$P(DIEX,".")?.E1L.E S $P(DIEX,".")=$$OUT^DIALOGU($P(DIEX,"."),"UC") G V I A9 S X=DISAVIEX,A9=0 G ALL K X G Q ALL F DIVP1=0:0 S DIVP1=+$O(^DD(DIVDO,DIVY,"V","O",DIVP1)) Q:'DIVP1 S DIVP=+$O(^(DIVP1,0)) I $D(^DD(DIVDO,DIVY,"V",DIVP,0)) S DIVPDIC=^(0) D ^DICM3 G Q:Y>0!(%<0)!$D(DUOUT) S X=DIEX G Q:DICR>1!$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G ALL ; ; Q I '$D(DUOUT),Y<0,DICR<2,'$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G V K:Y<0 X S DICR(DICR,"V")=1 F %="DR","W","P","V","A" I $D(DIV(%)) M DIC(%)=DIV(%) I $D(DICR(DICR,"S")) S DIC("S")=DICR(DICR,"S") QQ K:Y DICR(DICR,6) K DUOUT,DIVP,DIVDIC,DIVY,DO,DIVDO,DIVPDIC,DIEX,DIVP1,DIVP2,DIV,A9 Q ; NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP S DINAME=DIY Q:DIY'?1.N1";"1.E N % S %=$P(DIY,";",2),DINAME="^"_%_+DIY_",0)",DINAME=$S($D(@DINAME)#2:$P(^(0),U,1),1:DIY),%=$S($D(@("^"_%_"0)")):$P(^(0),U,2),1:"") Q:%="" I %["P"!(%["S")!(%["D")!(%["V") S DINAME=$$EXT^DIC2(+%,.01,DINAME) Q ; DICM3 DICM3 ;SFISC/XAK,TKW-PROCESS INDIVIDUAL FILE FOR VAR PTR ;07:39 PM 8 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. DIC ; Does recursive ^DIC call to single pointed-to file. Q:$D(DIVP(+DIVPDIC)) I $D(DIV("V")) N % D X % I '$T K Y S Y=-1 D DQ Q . S Y=DIVP,Y(0)=DIVPDIC . S %=$S($G(DIV("V"))]"":DIV("V"),1:$G(DIV("V",1))) Q I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 D DQ Q S (Y,DIC)=^("GL"),%="DIC"_DICR N:'$D(DIVPSEL) DIVPSEL S DIVPSEL(DICR)=0 S D=$G(DICR(DICR,4)) S:D="" D="B" I DIC["""" S Y="" F A1=1:1:$L(DIC,",")-1 S A0=$P(DIC,",",A1) S:A0["""" A0=$P(A0,"""")_""""""_$P(A0,"""",2)_""""""_$P(A0,"""",3) S Y=Y_A0_"," ; ; Build screen to select only pointed-to entries. K DIC("S") N DICODE S DICODE="" I DIC(0)'["L"!'$D(DICR(DICR,"V")) D . N DIX S DIX=""""_D_"""" D . . I $G(DINDEX("#"))>1 D BLDC^DICM0("("_DIVDIC,DIX,DINDEX("#"),DIFILEI,Y,.DICODE,.DICR) Q . . S DICODE="X ""I 0"" N "_%_$S($D(DICR(DICR,"S")):",%Y"_DICR,1:"")_" " . . S DICODE=DICODE_"F "_%_"=0:0 S "_%_"=$O("_DIVDIC_DIX_",(+Y_"";"_$E(Y,2,99)_"""),"_%_")) Q:"_%_"'>0 I $D("_DIVDIC_%_",0))" . . I DIC(0)["T",DICR=1 S DICODE=DICODE_$$CHKTMP^DICM0(.DIC,DICR,DIFILEI,%) . . I $D(DICR(DICR,"S")) S DICODE=DICODE_" S %Y"_DICR_"=Y,Y="_%_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I " . . S DICODE=DICODE_" Q" Q . S:DICODE]"" DIC("S")=DICODE Q ; ; Set DIC(0) S %=DIC(0),DIC(0)="D"_$E("M",%'["B") D . N I F I="E","O","B","T","V" I %[I S DIC(0)=DIC(0)_I . Q I %["L",$D(DICR(DICR,"V")),$$OKTOADD^DICM0(DIVDO,.DINDEX,.DIFINDER) D . I $P(DIVPDIC,U,6)="y" S DIC(0)=DIC(0)_"L" . ; Execute screen code for screened pointer (should set DIC("S")). . K D Q:$P(DIVPDIC,U,5)'="y" . N DICODE S DICODE=$G(^DD(DIVDO,DIVY,"V",DIVP,1)) Q:DICODE="" . N DICSSAV S DICSSAV=$G(DIC("S")) . X DICODE . S DIC("S")=$G(DIC("S"))_$S(DICSSAV]"":" "_DICSSAV,1:"") . Q E K D ; If user passed list of indexes to use on pointed-to file, setup. S %=$G(DIC("PTRIX",DIFILEI,DINDEX(1,"FIELD"),+DIVPDIC)) I %]"" N DF,DID S D=% D SETIX^DICM0(.D,.DIC,.DID,.DF) S:$G(D)="" D="B" N DISAVED S DISAVED=D ; ; Write prompt I DIC(0)["E" D . I $G(DICODE)="" D H1^DIE3 W:'$D(DDS) ! Q . D H1 Q ; ; Set up rest of variables needed for DQ^DICQ or ^DIC call. D DO^DIC1 N DS,DINDEX,DIFILEI S D=DISAVED K DISAVED ; Handle ? help I X?."?" D D DQ Q . S DZ=X_$E("?",'$D(DICR(DICR,"V"))) . D DQ^DICQ S X=$S($D(DZ):DZ,1:"?"),Y=-1 Q ; Do ^DIC call. D X^DIC I $D(DUOUT) D DQ Q ; ; Process output from ^DIC call. S X=+Y_";"_$E(DIC,2,99),%=1 K:Y<0 X I Y<0,DIC(0)["E",$D(DIVP1),$D(DICR(DICR,"V")) W ! I '$D(DICR(DICR,"V"))!(DICR>1) K DICR("^",+DIVPDIC) S DIVP(+DIVPDIC)=0 I Y>0,'DIVPSEL(DICR),DIC(0)["E",'$P(Y,U,3),$P(@(DIC_"0)"),U,2)'["O" D . N I F I=(DICR-1):-1 Q:'$D(DIVPSEL(I)) S DIVPSEL(I)=1 . D S1^DIE3 I $G(%Y)?1"^^".E S (DIROUT,DUOUT)=1 . Q DQ I $D(DIC("PTRIX")) M DIV("PTRIX")=DIC("PTRIX") K A0,A1,DIC,DO S DIC=DIVDIC,D=$S($D(DICR(DICR,4)):DICR(DICR,4),1:"B") S DIC(0)=DICR(DICR,0) F %="V","PTRIX" I $D(DIV(%)) M DIC(%)=DIV(%) Q ; H1 W:'$D(DDS) ! N A1,DST,DIPAR S A1="T" EGP S DIPAR(1)=$$FILENAME^DIALOGZ(+DIVPDIC),DIPAR(2)=$$LABEL^DIALOGZ(DIVDO,DIVY) ;**CCO/NI NAME OF FILE, AND VARIABLE-POINTER FIELD THAT POINTS TO IT S DST=$$EZBLD^DIALOG(8097,.DIPAR) D S^DIE3 W:'$D(DDS) ! Q ; ;8070 Searching for a |1| ;8097 Searching for a |1|, (pointed-to by |2|) ; DICN DICN ;SFISC/GFT,XAK,TKW,SEA/TOAD-ADD NEW ENTRY ;16NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; N DIENTRY,DIFILE,DIAC D:'$D(DO(2)) GETFA^DIC1(.DIC,.DO) S DO(1)=1 I '$D(DINDEX) N DINDEX S DINDEX("#")=1,DINDEX("START")="B" N DISUBVAL,V I DINDEX("#")>1 M V=X N X D I X="",DIC(0)'["E"!('$D(DISUBVAL)) D BAD^DIC1 Q . D VALIX(+DO(2),.DINDEX,.V,.DISUBVAL,.X,.DS) K V Q I $S($D(DLAYGO):DO(2)\1-(DLAYGO\1),1:1) S %=1 D B1 I '% D BAD^DIC1 Q USR D DS S DIX=X I X'?16.N,X?.NP,X,DIC(0)["E",'$G(DICR),DS'["DINUM",$P(DS,U,2)'["N",DIC(0)["N"!$D(^DD(+DO(2),.001,0)) D N^DICN1 I $D(X) S DIENTRY=X G I S X=DIX D:DINDEX("#")'>1 VAL G I:$D(X) S X=DIX B D BAD^DIC1 S Y=-1 Q ; B1 Q:'DO(2) Q:$D(^DD(+DO(2),0,"UP"))!(DO(2)=".12P") S DIFILE=+DO(2),DIAC="LAYGO" D ^DIAC K DIAC,DIFILE Q ; 1 I '$D(DIC("S")) D ;**CCO/NI 'ARE YOU ADDING'? THRU NEXT 4 LINES .N M .S M=$$EZBLD^DIALOG(8058,$$OUT^DIALOGU(Y,"ORD")) .S:$D(^DD(+DO(2),0,"UP")) M=M_$$EZBLD^DIALOG(8059,$$FILENAME^DIALOGZ(^("UP"))) S M=M_")" .I $L(M)+$L(DST)'>$S($G(IOM):IOM,1:80) S DST=DST_M Y I $D(DDS) S A1="Q",DST=%_U_DST D H^DDSU Q W !,DST K DST YN ; N %1 S %1=$$EZBLD^DIALOG(7001) S:'$D(%) %=0 W "? " W:(%>0) $P(%1,U,%),"// " RX R %Y:$S($D(DTIME):DTIME,1:300) E S DTOUT=1,%Y=U W $C(7) I %Y]""!'% S %=+$$PRS^DIALOGU(7001,%Y) S:(%<0&($A(%Y)'=94)) %=0 I '%,%Y'?."?" W $C(7),"??",!?4,$$EZBLD^DIALOG(8040),": " G RX W:$X>73 ! W:% $S(%>0:" ("_$P(%1,U,%)_")",1:"") Q ; DS S DS=^DD(+DO(2),.01,0) Q ; VAL I X'?.ANP K X Q I X[""""!(X["^") K X Q I $P(DS,U,2)'["N",$A(X)=45 K X Q I $P(DS,U,2)["*" S:DS["DINUM" DINUM=X Q N %T,%DT,C,DIG,DIH,DIU,DIV,DICR ;PRESERVE VARIABLES WHILE WE XECUTE INPUT TRANSFORM ON THE .01 FIELD S %=$F(DS,"%DT=""E"),DS=$E(DS,1,%-2)_$E(DS,%,999) N DICTST S DICTST=DS["+X=X"&(X?16.N) K:DICTST X X:'DICTST $P(DS,U,5,99) UNIQ I $P(DS,U,2)["U",$D(X),$D(@(DIC_"""B"",X)")) K X Q ; I1 S DST=$C(7)_$$EZBLD^DIALOG(8060) I '$D(DIENTRY),Y]"" S DST=DST_$$EZBLD^DIALOG(8061,Y) S %=$$FILENAME^DIALOGZ(+DO(2)) I $L(DST)+$L(%)'>55 S DST=DST_$$EZBLD^DIALOG(8062,%) Q ;**CCO/NI FILE NAME W:'$D(DDS) !,DST K A1 D:$D(DDS) H^DIC2 S DST=" "_$$EZBLD^DIALOG(8062,%) Q ; I I DIC(0)["E",DO(2)'["A",DIC(0)'["W" K DTOUT,DUOUT D G OUT^DICN0:$G(DTOUT)!($G(DUOUT)) I %'=1 S Y=-1 D BAD^DIC1 Q . S (Y,DIX)=X I Y]"" N C S C=$P(^DD(+DO(2),.01,0),U,2) D Y^DIQ . D I1 S %=2,Y=$P(DO,U,4)+1,X=DIX D 1 I2 . Q:%>0!($G(DTOUT)) I %=-1 S DUOUT=1 Q . W:'$D(DDS) $C(7)_"??",!?4,$$EZBLD^DIALOG(8040) D YN G I2 G NEW:'$D(DIENTRY) R D DS S DST=" "_$P(DS,U,1)_": " I '$D(DDS) W !,DST K DST R X:DTIME S:$E(X)=U DUOUT=1,Y=-1 S:'$T X=U,DTOUT=1,Y=-1 I $D(DDS) S A1="Q",DST="3^"_DST D H^DDSU S X=% I $D(DTOUT) S X=U,Y=-1 I X[U D BAD^DIC1 Q I X="" G R D VAL HELP I '$D(X) D G R ;**CCO/NI PLUS NEXT 2 LINES HELP MESSAGE FOR .01 FIELD, WHEN TELLING USER HOW TO LAYGO A NEW ONE .W $C(7) W:'$D(DDS) "??" S DST=$$HELP^DIALOGZ(+DO(2),.01) Q:DST="" .S DST=" "_DST W:'$D(DDS) !,DST D:$D(DDS) H^DDSU ; NEW ; try to add a new record to the file G NEW^DICN0 ; FILE ; DOCUMENTED ENTRY POINT: add a new record to a file ; N DIENTRY,DS,DIAC,DIFILE D NEW^DICN0,Q^DIC2 Q ; FIRE ; fire the SET logic of a bulletin or trigger xref (in DZ) ; STORLIST^%RCR (called by NEW^DICN0) ; X DZ Q ; VALIX(DIFILEI,DINDEX,V,DISUBVAL,X,DS) ; ; Save lookup values in array by field no. so we can update the fields on the new record. N VI,DISUB,DIERR,DIFILE,DIFIELD,DO,DIOK S X="" I $G(V)]"",$G(V(1))="" S V(1)=V F DISUB=1:1:DINDEX("#") I $G(V(DISUB))]"" D . S DIFILE=$G(DINDEX(DISUB,"FILE")),DIFIELD=$G(DINDEX(DISUB,"FIELD")) . S DIOK=0 I 'DIFILE!('DIFIELD) Q . S V=V(DISUB) . I DISUB=1 D I DIOK S:DIOK'=2 DISUBVAL(DIFILE,DIFIELD)=V Q . . I $A(V)=34,V?.E1"""" S V=$E(V,2,($L(V))-1) . . I $G(DS("INT"))="",'$G(DICRS) S:"VP"[$G(DINDEX(1,"TYPE")) DIOK=2 Q . . S DIOK=1 . . I DIFILE=DIFILEI,DIFIELD=.01 S X=$S($G(DICRS):V,1:DS("INT")) Q . . S DISUBVAL(DIFILE,DIFIELD,"INT")=$S($G(DICRS):V,1:DS("INT")) . . Q . S DISUBVAL(DIFILE,DIFIELD)=V . D CHK^DIE(DIFILE,DIFIELD,"",V,.VI,"DIERR") Q:VI="^" . I DIFILE=DIFILEI,DIFIELD=.01 S X=VI K DISUBVAL(DIFILE,.01) Q . S DISUBVAL(DIFILE,DIFIELD,"INT")=VI . Q Q ; ;#7001 Yes/No question ;#8040 Answer with 'Yes' or 'No' ;#8058 (the |entry number| ;#8059 for this |filename| ;#8060 Are you adding ;#8061 '|.01 field value|' as ;#8062 a new |filename| DICN0 DICN0 ;SFISC/GFT,XAK,SEA/TOAD/TKW-ADD NEW ENTRY ;22MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; NEW ; try to add a new record to the file ; called from FILE, ^DICN ; N %,I,DDH,DI,DIE,DIK,DQ,DR,%H,%T,%DT,C,DIG,DIH,DIU,DIV,DISYS K % M %=X N X M X=% S %=+$G(D0) N D0 S:% D0=% K % I '$G(DIFILEI)!($G(DINDEX("#"))="") N DINDEX,DIFILEI,DIENS D . S DINDEX("#")=1,(DINDEX,DINDEX("START"))="B" . D GETFILE^DIC0(.DIC,.DIFILEI,.DIENS) Q G:DIFILEI="" OUT I '$D(@(DIC_"0)")),'$D(DIC("P")),$E(DIC,1,6)'="^DOPT(" S DIC("P")=$$GETP^DIC0(DIFILEI) D:'$D(DO(2)) GETFA^DIC1(.DIC,.DO) I DO="0^-1" G OUT S X=$G(X) I X="",DINDEX("#")>1 S X=$G(X(1)) I X="",(DIC(0)'["E"!(DINDEX("#")'>1)) G OUT N DINO01 S DINO01=$S(X="":1,1:0) N DIX,DIY ; N1 ; if LAYGO nodes are present, XECUTE them and verify they don't object ; S Y=1 F DIX=0:0 D Q:DIX'>0 Q:'Y . S DIX=$O(^DD(+DO(2),.01,"LAYGO",DIX)) Q:DIX'>0 . I $D(^DD(+DO(2),.01,"LAYGO",DIX,0)) X ^(0) S Y=$T I 'Y G OUT ; ; if the file is in the middle of archiving, keep out ; I $P($G(^DD($$FNO^DILIBF(+DO(2)),0,"DI")),U,2)["Y" D I Y G OUT . S Y='$D(DIOVRD)&'$G(DIFROM) ; N2 ; process DINUM ; S DIX=X I $D(DINUM) D . S X=DINUM D I '$D(X) S Y=0,X=DIX Q . . N DIX D N^DICN1 Q . D LOCK(DIC,X,.Y) ; ; or process DIENTRY (numeric input that might be IEN LAYGO) ; E I $D(DIENTRY) D . S X=DIENTRY D I 'Y S X=DIX Q . . N DIX D ASKP001^DICN1 Q . D LOCK(DIC,X,.Y) ; ; or get a record number the usual way ; E S X=$P(DO,U,3) D INCR N DIFAUD S %=+$P(DO,U,2),DIFAUD=$S($D(^DIA(%,"B")):%,1:0) F D Q:Y'="TRY NEXT" . F S X=X\DIY*DIY+DIY Q:'$D(@(DIC_"X)"))&$S('DIFAUD:1,1:+$O(^DIA(DIFAUD,"B",X_","))-X&'$D(^(X))) . I $G(DUZ(0))="@"!$P(DO,U,2) N DIX D ASKP001^DICN1 Q:'Y . D LOCK(DIC,X,.Y) Q:Y S Y="TRY NEXT" ; I 'Y S Y=-1 D BAD^DIC1 Q ; N3 ; add the new record at the IEN selected ; S @(DIC_"X,0)")=DIX L @("-"_DIC_"X)") ; ; update the file header node ; K D S:$D(DA)#2 D=DA S DA=X,X=DIX I $D(@(DIC_"0)")) S ^(0)=$P(^(0),U,1,2)_U_DA_U_($P(^(0),U,4)+1) N4 ; if compound index and we don't know internal value of .01, we'll prompt for it in ^DIE. I DINO01 D G:Y>0 D Q . D ^DICN1 I Y'>0 S:$G(DO(1)) DS(0)="1^" S (X,DIX)="" Q . S (X,DIX)=$P($G(@(DIC_DA_",0)")),U) . Q N5 ; If .01 is marked for auditing, update audit file D . I DO(2)'["a" Q:$P(^DD(+DO(2),.01,0),U,2)'["a" Q:^("AUDIT")["e" . D AUD^DIET ; ; index the .01 field of the new entry ; N DD S DD=0 D . N DIFILEI,DINDEX,DIVAL,DIENS,DISUBVAL . F S DD=$O(^DD(+DO(2),.01,1,DD)) Q:'DD D . . K % M %=X N X M X=% K % . . I ^DD(+DO(2),.01,1,DD,0)["TRIGGER"!(^(0)["BULL") D Q . . . N %RCR,DZ S %RCR="FIRE^DICN",DZ=^DD(+DO(2),.01,1,DD,1) . . . F %="D0","Y","DIC","DIU","DIV","DO","D","DD","DICR","X" S %RCR(%)="" . . . D STORLIST^%RCR Q . . M %=DIC N DIC M DIC=% K % M %=DA N DA M DA=% K % S %=DD N DD,D . . X ^DD(+DO(2),.01,1,%,1) Q . Q I $O(^DD("IX","F",+DO(2),.01,0)) D . K % M %=X N X M X=% K % M %=DIC N DIC M DIC=% . K % M %=DA N DA M DA=% K % M %=DO N DO M DO=% K % N DD,D . D INDEX^DIKC(+DO(2),DA_DIENS,.01,"","SC") Q ; N6 ; if we have lookup values to stuff, or DIC("DR"), or if the file has ; IDs or KEYS, go do DIE. ; Code will return at D if successful. We set output and go exit ; S Y=DA D . I $D(DIC("DR"))!($O(DISUBVAL(+DO(2),0)))!($O(^DD("KEY","B",+DO(2),0))) D ^DICN1 Q . Q:DIC(0)'["E" . I '$O(^DD(+DO(2),0,"ID",0)) Q . D ^DICN1 Q I Y'>0 S:$G(DO(1)) DS(0)="1^" Q ; ; Finish adding the new record. D S Y=DA_U_X_"^1" I $D(D)#2 S DA=D D R^DIC2 Q ; INCR S DIY=1 I $P(DO,U,2)>1 F %=1:1:$L($P(X,".",2)) S DIY=DIY/10 Q ; ; OUT I DIC(0)["Q" W $C(7)_$S('$D(DDS):" ??",1:"") S Y=-1 I $D(DO(1)),'$D(DTOUT) D A^DIC S DS(0)="1^" Q D Q^DIC2 Q ; LOCK(DIROOT,DIEN,DIRESULT) ; ; ; try to lock the record, and see if it's already there ; NEW ; D LOCK^DILF(DIROOT_"DIEN)") ;L @("+"_DIROOT_"DIEN):1") ;**147 S DIRESULT='$D(@(DIROOT_"DIEN)"))&$T I 'DIRESULT L @("-"_DIROOT_"DIEN)") Q ; DICN1 DICN1 ;SFISC/GFT,TKW,SEA/TOAD-PROCESS DIC("DR") ;8MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; K DIDA,DICRS,Y,%RCR F Y="DIADD","I","J","X","DO","DC","DA","DE","DG","DIE","DR","DIC","D","D0","D1","D2","D3","D4","D5","D6","DI","DH","DIA","DICR","DK","DIK","DL","DLAYGO","DM","DP","DQ","DU","DW","DIEL","DOV","DIOV","DIEC","DB","DV","DIFLD" S %RCR(Y)="" S DZ="W !?3,$S("""_$P(DO,U)_"""'=$P(DQ(DQ),U):"""_$P(DO,U)_""",1:"""")_"" ""_$P(DQ(DQ),U)_"": """ S Y=DA N % S %=0 D I '$D(%) D W,BAD Q . S DD="" N I,J,X,Y . I DINO01 D . . S DD=".01//" . . S I=$G(DISUBVAL(+DO(2),.01)) I I="" S DD=DD_";" Q . . S DD=DD_$S(DIC(0)'["E":"/",1:"")_"^S X=DISUBVAL("_+DO(2)_",.01);" Q . K DISUBVAL(+DO(2),.01) . F I=0:0 S I=$O(DISUBVAL(+DO(2),I)) Q:'I D . . S DD=DD_I_"//" . . I $G(DISUBVAL(+DO(2),I,"INT"))]"" S DD=DD_"//^S X=DISUBVAL("_+DO(2)_","_I_",""INT"");" Q . . S:DIC(0)'["E" DD=DD_"/" . . S DD=DD_"^S X=DISUBVAL("_+DO(2)_","_I_");" Q . S DD=DD_$G(DIC("DR")) I DD]"",$E(DD,$L(DD))'=";" S DD=DD_";" . Q:DIC(0)'["E" . F I=0:0 S I=$O(^DD("KEY","B",+DO(2),I)) Q:'I!('$D(%)) F J=0:0 S J=$O(^DD("KEY",I,2,J)) Q:'J!('$D(%)) D . . S X=$G(^DD("KEY",I,2,J,0)) Q:$P(X,U,2)'=+DO(2) . . S Y=$P(X,U) Q:'Y D CKID . . Q . Q:$D(DIC("DR"))!('$D(%)) . S Y=0 F S Y=$O(^DD(+DO(2),0,"ID",Y)) Q:'Y D CKID Q:'$D(%) . Q I DD]"",$O(^DD("KEY","B",+DO(2),0)) D . N I S I=$S(DIC(0)["E":"M",1:"") . S DD=DD_"S DIEFIRE="""_I_"""" Q S %RCR="RCR^DICN1" D STORLIST^%RCR I $D(Y)<9 S Y=DA Q ; BAD S:$D(D)#2 DA=D K Y I '$D(DO(1)) S Y=-1 D Q^DIC2 Q K DO D A^DIC S DS(0)="1^",Y=-1 Q ; CKID I $G(DUZ(0))'="@",$G(^DD(+DO(2),Y,9))]"" D Q:'$D(%) Q:$L(^DD(+DO(2),Y,9))<% . F %=1:1 I DUZ(0)[$E(^DD(+DO(2),Y,9),%) Q:$L(^(9))'<% K:$P(^(0),U,2)["R" % Q Q:Y=.01 I $P(DD,"//")=Y!(DD[(";"_Y_"//"))!(DD[(";"_Y_";")) Q S DD=DD_Y_";" Q Q ; W S A1="T",DST="SORRY! A VALUE FOR '"_$P(^(0),U,1)_"' MUST BE ENTERED," W:'$D(DDS) ! D H S A1="T",DST="BUT YOU DON'T HAVE 'WRITE ACCESS' FOR THIS FIELD" W:'$D(DDS) !,?6 D H D:$D(DDS) LIST^DDSU S %RCR="D^DICN1" D STORLIST^%RCR Q ; H I $D(DDS) S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K A1,DST Q W:'$D(ZTQUEUED) DST K A1,DST Q RCR ; K DR,DIADD,DQ,DG,DE,DO N DISAV0 S DIE=DIC,DR=DD,DIE("W")=DZ,DISAV0=DIC(0) K DIC I $D(DIE("NO^")) S %RCR("DIE(""NO^"")")=DIE("NO^") S DIE("NO^")="BACKOUTOK" N X D:$D(DDS) CLRMSG^DDS D:DR]"" K DIE("W"),DIE("NO^") . N DISAV0,DIFILEI,DINDEX,DIVAL,DIENS,DIOPER . S DIOPER="A" K % M %=DISUBVAL N DISUBVAL M DISUBVAL=% K % . D ^DIE Q D:$D(DDS) . I $Y" W:'$D(DDS)&'$D(ZTQUEUED) !?3 D H D:$D(DDS)&'$D(ZTQUEUED) LIST^DDSU D ^DIK S Y(0)=0 K DST Q ; D N DISAV0 S DISAV0=DIC(0),DIE=DIC D ZAP Q ; ASKP001 ; ask user to confirm new record's .001 field value ; NEW^DICN ; ; quit if there's no .001 or we can't ask ; I DIC(0)'["E" S Y=1 Q S Y=$P(DO,U,2) I '$D(^DD(+Y,.001,0)) S Y=1 Q ; ; if this is not a LAYGO lookup in which X looks like an IEN, and we're ; adding a new file, and we haven't tried this before, then offer a new ; .001 based on the user's or site's file range, whichever's handy. ; NEW^DICN will increment this .001 forward to find the first gap, then ; drop back through here to the paragraph below (because DO(3) will be ; defined next time) to offer it to the user ; I '$D(DIENTRY),DIC="^DIC(",'$D(DO(3)) D S Y="TRY NEXT" Q . S DO(3)=1 . I $S($D(^VA(200,DUZ,1))#2:1,1:$D(^DIC(3,DUZ,1))#2),$P(^(1),U) D Q . . S DIY=.1,X=+$P(^(1),U) ; NAKED . I $D(^DD("SITE",1)),X\1000'=^(1) S X=^(1)*1000,%=0 ; ; set up our prompt, if .001 looks valid use it as a default, otherwise ; count forward until we find a valid one to offer ; S DST=" "_$P(DO,U)_" "_$P(^DD(+Y,.001,0),U)_": " S %=$P(^DD(+Y,.001,0),U,2),X=$S(%'["N"!(%["O"):0,1:X),%Y=X I X F %=1:1 D N Q:$D(X) S X=0 Q:%>999 S X=%Y+DIY,%Y=X I X S DST=DST_X_"// " ; ; prompt user for .001 ; I '$D(DDS) D . W !,DST K DST R Y:$S($D(DTIME):DTIME,1:300) E S DTOUT=1,Y=U W $C(7) E D . S A1="Q",DST=3_U_DST N DIY D H,LIST^DDSU S Y=$S($D(DTOUT):U,1:%) K % ; ; sort through possible responses ; I Y[U S Y=U Q I Y="" S Y=1 Q I Y'="?" D Q:Y . S X=Y D N S Y=$D(X)#2 D:Y Q:Y . . I $D(@(DIC_X_")")) K X S Y=0 . . Q . W $C(7) . W:'$D(DDS) "??" ; ; for bad response or help request, offer help and try new IEN ; EGP S DST=$$HELP^DIALOGZ(+DO(2),.001) I $D(^DD(+DO(2),.001,0)),DST]"" S DST=" "_DST ;**CCO/NI HELP MESSAGE FOR .001 FIELD WHEN USER IS LAYGO-ING (NOTE NAKED REFERENCES IN FOLLOWING LINES) I '$D(DDS) D . W:DST]"" !?5,DST X:$D(^(4)) ^(4) K DST ; NAKED E D . S A1=0 N DIY D H S:$D(^(4)) DDH("ID")=^(4) D LIST^DDSU ; NAKED S X=$P(DO,U,3) D INCR^DICN0 S Y="TRY NEXT" Q ; IHSGL(X) ;----- CHECK GL NODE OF TOP LEVEL FILE FOR DUZ(2) ;USED TO ALLOW USE OF "SOFT" GLOBAL REFERENCES, I.E., DUZ(2) ; ; RETURNS: ; 0 IF THE TOP LEVEL FILE "GL" NODE DOES NOT CONTAIN DUZ(2) ; 1 IF IT DOES ; ; INPUT: ; X = FILE NUMBER ; N DITOP,Y S Y=0 I X D . S DITOP=X . F Q:'$D(^DD(DITOP,0,"UP")) S DITOP=^("UP") . S Y=$G(^DIC(DITOP,0,"GL"))["DUZ(2)" Q Y ; N ; test X as an IEN (apply input transform and numeric restrictions) ; USR^DICN, ASKP001 ; I $D(^DD(+$P(DO,U,2),.001,0)),'$D(DINUM) X $P(^(0),U,5,99) I $D(X),$L(X)<15,+X=X,X>0,X>1!(DIC'="^DIC(") Q K X Q ; ; 741 Either key values are null, or creates a duplicate key. ; DICOMP DICOMP ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;16JUN2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; S DICOMP=$G(DICOMP) N DLV,K S K=0 F DLV=0:1 G A:'$D(J(DLV+1)) EN1 ; S K=0 F S DLV=K,K=$O(I(K)) G A:K="",A:$D(J(K))[0!($D(I(K\100*100))[0) EN ; S DLV=+DICOMP A N DICO,DPUNC,DLV0,DIM,DIMW,DG,DBOOL,DICV,V,T,DICN,DICF,DIC,DATE,DPS,M,W,DICOMPQI,D,%,%Y,DS,DZ,%DT ;Don't NEW the variable A! I DICOMP'["?",'$D(DIQUIET) N DIQUIET S DIQUIET=1 K K K S K=0 I DLV F I=0:100 Q:I>DLV S K=K+1,K(K)="",K(K,1)=I I '$D(DQI) N DQI S DQI="Y(",DICOMPQI=1 S I=DLV F S I=$O(J(I)),DICO(1)=DLV Q:I="" K:DLV I(I),J(I) S DPUNC=",'+-():[]!&\/*_=<>",DLV0=DLV\100*100,I=X,DIMW="" K X S DIC(0)="ZFO",(M,DPS)=0,DICO=I,DICO(1)=DLV,DICO(0)=DLV\100*100 F %=0:100 Q:'$D(J(%)) S DG(%)=% TOOEASY G 0:" "[I!(+I=I)!(I'?.ANP)!(I?."?")!($E(I,$L(I))=":") G D I I X?.NP G:X="" N:I]"",^DICOMP1 I +X=X,X<1700!'$D(DATE(K-1))!'$G(DBOOL) G N:W'=":",N:$D(DPS($$NEST,"$S")) G E:$L(X)>30,FUNC:W="(",N:X?1"$"1U V I $D(DICOMPX(X))#2 D DATE^DICOMP0:$D(DICOMPX(X,"DATE")) S T=X,X=DICOMPX(X) G N:'$D(DICOMPX(T,U)) S T=DICOMPX(T,U),DICN=$P(T,U,2),T=+T,Y(0)=^DD(T,DICN,0),D=$P(Y(0),U,2) D S^DICOMP0 G N E K Y D ^DICOMP0 G N:+X=X,N:$D(Y),0:$D(DICO("BACK"))-10 S X=DICO,DLV=DICO(1),DICO("BACK")=1 S:$G(DICOMPX)]"" DICOMPX="" G K N ; I X]"" S K=K+1,K(K)=X S I=$E(I,M,999),M=0 G G:$F(DPUNC,W)<2 I W=":",'$D(DPS($$NEST,"$S")) S I=$E(I,2,999) D I,M^DICOMPX,M^DICOMPW:$D(X) S W="" G N:$D(X),0 S X=W,W="",M=2 G N:X="" G DPS:X=")",C:",:"[X,0:"+-'"[X&'$L($E(I,M,999)) I X="(" D ST G N S DBOOL="><]['=!&"[X,Y="[]!&/\_><*=" NOT I X="'" S %=$E(I,2) I "_"""[% G 0 G N:Y'[X BINOP I ")"'[$E(I_W,M),$G(K(K))]"" I '$D(K(K,2)),'$F($TR(DPUNC,")'"),K(K)),$F(Y,W)<2 D:X="_" G N:K(K)'="'" S K(K)="'"_X,X="" G N:DBOOL CONCAT .I $D(DATE(K)) K DATE(K) S X=" S Y=X X ^DD(""DD"") S X=Y_" 0 G 0^DICOMP1 ; I ;parse off the next element I $A(I,M+1)=34 S M=$F(I,"""",M+2)-1 G I:M>0 S W=0,M=999,X=U Q MR F M=M+1:1 S W=$E(I,M) Q:DPUNC[W S X=$E(I,1,M-1) Q ; C I $D(DPS($$NEST,"SETDATA")) G 0 S DICF=X D DG S K(K+1,2)=0 I $O(DPS($$NEST,"$"))["$" S DPS($$NEST)=DPS($$NEST)_Y_DICF G N G 0:'$D(W($$NEST)) S (W,W($$NEST))=W($$NEST)-1 K:W<2 W($$NEST) S DPS($$NEST)=" S X"_W_"="_Y_DPS($$NEST) G N ; DPS G 0:'DPS I $D(DPS(DPS,"ST")) D DPS^DICOMPW S:X]"" K=K+1,K(K)=X G DPS I $D(DPS(DPS,"BETWEEN")) S DPS(DPS,"BOOL")=1 DUP I $D(DPS(DPS,"DUPLICATED")) D G 0:'DPS .I $G(Y(0))'[U S DPS=0 Q .S Y=$O(^DD(J(DLV),"B",$P(Y(0),U),0)) I 'Y S DPS=0 Q .F T=0:0 S T=$O(^DD(J(DLV),Y,1,T)) Q:'T I +$G(^(T,0))=J(DLV0),$P(^(0),U,3,99)="" S Y=$P(^(0),U,2) I Y?1U.AN Q ;find a regular cross_refs .I 'T F T=0:0 S T=$O(^DD("IX","F",J(DLV),Y,T)) Q:'T I $P($G(^DD("IX",T,0)),U,4)="R",$P(^(0),U,6)="F",$P(^(0),U,9)=J(0) S Y=$P(^(0),U,2) Q ;or find a regular INDEX .I 'T S DPS=0 Q .D DIMP^DICOMPZ("N Z S Z=X,X="""" I $L(Z) S Z=$O("_I(DLV0)_""""_Y_""",Z,0)) I Z,Z-D0!$O(^(D0)) S X=1") S DPS(DPS)=X_" S X=X",DPS(DPS,"BOOL")=1 D DPS^DICOMPW G N:'$D(W(DPS+1)),0 ; FUNC S Y=+$O(^DD("FUNC","B",X,0)) I '$D(^DD("FUNC",Y,0)),X'?1N.N2A,X'?1"$"1U G V I Y=90!(Y=91)!(Y=92) D PRIOR^DICOMPZ G N:$D(Y),0 S DICF=X,DBOOL=$G(DBOOL,0) D ST I $G(^DD("FUNC",Y,0))="DUPLICATED" S DPS(1,"INTERNAL")="" D 1 K Y G B I "Q"'[$G(^DD("FUNC",Y,1)) D 1 G B I DICF'?1"$"1U.U D ^DICOMPY S W="" G DPS:DPS,0 S DPS(DPS,DICF)=DPS(DPS),DPS(DPS)=" S X="_DICF_W B S M=M+1,W="" G 0:$E(I,M)=")",N ; 2 ; D ST 1 S DPS(DPS,DICF)="",DPS(DPS)=" "_$G(^(1))_DPS(DPS)_" S X=X" I $D(^(2)) S %=$P(^(2),U) I %]"" S DPS(DPS,%)="" I DPS=1,$G(^(10))]"" S DPS(^(10))="" S %=$G(^(3),0) D:%'?.N .S %=1 F %Y=M+1:1 S Y=$E(I,%Y) Q:")"[Y S:Y="," %=%+1 .S DPS(DPS)=" K X"_%_DPS(DPS) S:%>1 W(DPS)=% Q ; ST ;stack N Y S DPS=DPS+1,%="",Y=K I $D(DBOOL) S DPS(DPS,"BOOL")=DBOOL K DBOOL S I 'Y S X="",DPS(DPS)=$P(" S X="_%_"X",U,%]"") Q I K(Y)="" S Y=Y-1 G S I "'"[K(Y)!(K(Y)="+"),$S(Y=1:1,1:K(Y-1)?1P!(K(Y-1)="")) S %=K(Y)_%,K=K-1,Y=Y-1 G S D DG S DPS(DPS)="" I K(K)?1P!(K(K)?2P) S DPS(DPS)=" S Y="_%_"X,X="_Y_",X=X",DPS(DPS,U)=K(K)_"Y",K=K-1 S:$D(DATE(K)) DPS(DPS,"DATE")=1 S K(K+1,2)=0 Q ; NEST() N I F I=DPS:-1 Q:'$D(DPS(I,"ST")) Q I ; DG S Y=$$DGI,X=" S "_Y_"=$G(X)" Q DGI() S DG(DLV0)=$G(DG(DLV0))+1 Q DQI_DG(DLV0)_")" ; EXPR(FILE,DICOMP,I,SUBS) ;I=input expression; DICOMP=flags S X=$G(DUZ),X(2)=$G(DUZ(2)),DICOMP=$G(DICOMP) N DUZ,J,DICOMPX,DICOMPW,DQI,DA,DICMX S DUZ=X,DUZ(0)="@",DUZ(2)=X(2) ;pretend he's programmer K X S X=I I DICOMP["m" S DICMX="X DICMX" ;Flag 'm' = allow returning multiple values S DICOMPW="",DA="X(" S DICOMPX="",DICOMP=$TR(DICOMP,"F")_"X" ;(Why strip out "F"?) We don't allow MUMPS M DICOMPX=SUBS ;list of terms to substitute D IJ^DIUTL(FILE) S FILE=$O(I(""),-1) I FILE S DICOMP=FILE_DICOMP ;FILE may be down a level or 2 K SUBS,FILE D DICOMP I '$D(X) Q S X("USED")=$G(DICOMPX) Q DICOMP0 DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;17DEC2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DICOMPI SETFUNC I DPS,$D(DPS(DPS,"SET")),'$D(W(DPS)) S T="""",D=$P(X,T)_$P(X,T,2) G BAD:$L(D)+2\5-1!(D'?.UN)!(D?1"D".E)!(DUZ(0)'="@") S X=T_D_T,DICOMPX(D)=D,Y=0 Q LIT I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y S X=""""_$$CONVQQ^DILIBF(%)_"""" Q L S T=DLV,DICN=X TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$G(^DD(J(T),.01,0))="",UP:$P(^(0),U,2)["W" S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " S DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0" D DICS^DICOMPY:DUZ(0)'="@" R I X?1"#"1.NP S X=$E(X,2,99) D ^DIC G:Y>0 A:DLV,X S X="#"_X D ^DIC G A:Y>0 N I $P(X,DG)="",X=DICN S X=$P(X,DG,2,9) G R NUMBER I X=$$EZBLD^DIALOG(7099) S Y=.001,Y(0)=0 G D ;**CCO/NI THE WORD 'NUMBER' IN A COMPUTED EXPRESSION UP S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1)) ; A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1) I DICOMP["?",DICN'="#.01",$P(Y,U,2)'=DICN,DG_$P(Y,U,2)'=DICN D G BAD:%<0,N:%-1 .N N S N(1)=DICN,N(2)=DG,N(3)=$P(Y,U,2) W !,$$EZBLD^DIALOG(8201,.N) S %=1 D YN^DICN ;**CCO/NI (SAME) E S DICO("BACK",T)=+Y S M=D X I $D(DICOMPX)#2 S %Y=J(T)_U_+Y_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%Y) DICOMPX=%Y_DICOMPX ;Take internal value of V-P Field for VPFILE Function --forgot about it when we realized that FILE Function exits! D S D=$P(Y(0),"^",2),%=T\100*100,DICN=+Y,DICOMPI=W=")" I D["V"&DICOMPI&$D(DPS($$NEST^DICOMP,"VPFILE")) S DICO("PT")=1 E S DICOMPI=DICOMPI&$D(DPS($$NEST^DICOMP,"INTERNAL")) D DATE:D["D"&'DICOMPI I D["m"!D D MUL^DICOMPZ(D) Q I $D(DICOMPX(1,J(T),+Y)) S X=DICOMPX(1,J(T),+Y) G O I D["C" S:'$D(DG(%,T,+Y)) DG(%)=DG(%)+1,DG(%,T,+Y)=DG(%) S X=DQI_DG(%,T,+Y)_")" Q:D'["p"!DICOMPI S DICN=+$P(D,"p",2),%Y=$G(^DIC(DICN,0,"GL")) Q:%Y="" G POINT GET I DICOMP["G",T#100=0 S X="$$GET^DDSVAL("_J(T)_",D0,"_+Y_",,"""_$E("E",'DICOMPI)_""")" G O D G^DICOMPY ;This will set return value X equal to something like "$P(Y(2),U,3)" O Q:DICOMPI S T=J(T) S ; S %=DLV0,DG=W=":"&'$D(DPS(DPS,"$S")) OUT I D["O"&(D'["P"!'DG)!(D["V"&'$D(DPS(DPS,"FILE"))) D Q .S X="$$EXTERNAL^DIDU("_T_","_DICN_","""","_X_")",DICO("DIERR")=1 ;S:'K K=1 S K(1)=" N DIERR S X=$G(X)"_$G(K(1)) .;D DIMP^DICOMPZ("N C,Y S Y="_X_",C="""_D_""" D:$D(^DD("_T_","_DICN_",0)) Y^DIQ S X=Y") S DICF=X D ST^DICOMP S DPS(DPS)=DICF_" S X=X" B D DPS^DICOMPW Q SET I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))" ;S X="$$SET^DIQ("_T_","_DICN_","_X_")" Q:D'["P" S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2) POINT I W=":" G MR:'$$OKFILE^DICOMPX(DICN,DICOMP) I W'=":" S D=$P($G(^DD(DICN,.01,0)),U,2) I D'["V",D'["S",D'["P" D DATE:D["D" S X="$P($G("_%Y_"+"_X_",0)),U)" Q P G P^DICOMPX ; M S T=$F(X," IN ") I T S X=$E(X,1,T-5),W=":",M=T-4,I=X_W_$E(I,T,999),T=$F(I," FILE",M) S:T&$F(DPUNC,$E(I,T)) I=$E(I,1,T-6)_$E(I,T,999) G DICOMP0 G MR:$L(X)>30 S DICF=X,T=$O(^DD("FUNC","B",X,0)) G LITDATE:'$D(^DD("FUNC",+T,3)),LITDATE:^(3) I $G(^(1))'="" D 2^DICOMP S Y(0)=0,K=K+1,K(K)=X D DATE:$G(^(2))?1"D".E,DPS^DICOMPW Q G MR:X'?1"PRIOR"4.U S Y=X,X="$P($$LAST^DIAUTL("_J(DLV0)_",D0,""*""),U)" I Y["USER",$D(^VA(200)) S $E(X,$L(X))=",2)",DICN=200,%Y="^VA(200," G POINT G DATE ; LITDATE S %DT="T" I $L(X)>2 D ^%DT I Y>0 S X=Y,Y(0)=0 D DATE Q ;may be a literal date BACKPNT S T=$O(^DIC("B",X)) I T]"",$P(T,X)=""!$D(^(X)),$D(J(0)) S T=DLV0 D ^DICOMPV I D>0 Q ;try backwards-pointer TOOK OFF CHECK FOR DICOMPW VARIABLE 3/28/2000 MR I M'>$L(I),+X'=X D MR^DICOMP G L:X]"" DDD I DICOMP["?",$D(^DDD("C")),DICOMP'["d" ; S T=$$EN^DICOMPU(X,.J,DICOMP,.DICMX) G BAD:$D(DUOUT) I T]"" W " (",T,")" D I $D(X),$D(Y) S:Y["m" DIMW="m" D:Y["D" DATE S K=K+1,K(K)=X_" S X=X" D DPS^DICOMPW S DLV=+Y Q ;.D ST^DICOMPX S D=$E(I,M,999),DICOMP=$TR(DICOMP,"?")_"d" D RCR^DICOMPZ(T) S M=0,I=D BAD K Y Q ; DATE ; S DATE(K+1)=1 Q ; SCREEN() ;Screen out certain fields as we process an atom I $D(DICO("BACK"))=11,$G(DICO("BACK",T))=Y Q 0 I Y=DA,DICO(1)=T Q 0 ;Computed field cannot refer to itself! I $P(^(0),U,2) Q '$G(DBOOL) ;A multiple cannot be manipulated as a Boolean! I $P(^(0),U,2)'["P" Q 1 N P S P=$P(^(0),U,3) I P]"",$D(@(U_P_"0)")) Q 1 ;Only allow a pointer that points to an existing file! Q 0 DICOMP1 DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;19JUNE2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F Q:'$D(DPS(DPS,"ST")) D DPS^DICOMPW S K=K+1,K(K)=X G 0:DPS INIT S T=99,DLV0=0,X="",K=1 D ST ;ST will build code to get top=level values NN I $D(K(K,1)) S DLV0=K(K,1) K K(K,1) D ST ;'1' flags a change in levels I $D(K(K,9)) F %=1:1:K K DATE(%) G S:$D(K(K))[0,K1:K(K)="" I " "[$E(K(K)) D .Q:X="" .I K(K)?1" S ".E D Q AS ..D EX I $L(K(K))+$L(X)>160 D M Q ..S K(K)=$E(K(K),4,999),X=X_"," .D EX:W,M:$L(X)+$L(K(K))>180 E I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6 D:K(K)?1P P .I "\/"[K(K),$G(K(K+1))'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")" .I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX G A:'$D(DATE(K)) DATE I $G(K(K-1))="_",X?.E1"_" S X=$E(X,1,$L(X)-1) D EXTRASB S Y=$$DGI^DICOMP,X=X_" S "_Y_"=X,X="_K(K)_" S Y=X X ^DD(""DD"") S X="_Y_"_Y",K(K)="" G A S Y=1 I $G(K(K-1))="+" S X=X_"0,X2=X,X1="_K(K) G DTC 2 G A:$D(K(K+2))[0 K DATE(K) I $D(DATE(K+2))[0,$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1 E G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0 S K=K+2 DTC S K=K+1,X=X_",X="""" D"_$P(":X2 ^ C",U,Y+1)_"^%DTC:X1" G S:'$D(K(K)) D SX G NN:'Y S K=K-1,K(K)="" G 2 ; A S W='$D(K(K,2)),X=X_K(K) K1 S K=K+1 G NN:$D(K(K))#2 S S I="" F S I=$O(M(I)),W=0 Q:I="" D M:$L(X)>235 S K=$O(M(I,"")),X=X_" S D"_I_"="_$S(DA:DQI_(K+80),1:"I("_K_",0")_")" S I=-1 D SS S:X?.E1" S X=X" X=$E(X,1,$L(X)-6) I X'?1"S X="1N.NP!(DICOMP["Z") G Q 0 ;NO GOT! Come here when parsing fails K X,DIM,DATE I DUZ(0)="@",DICOMP'["X" D .Q:DICO'[" " .S DIM=1 I $L(DICO," ")=2 F Y="OPEN","CLOSE","BREAK","USE" D I '$D(DIM) Q ..I $E(Y)=$P(DICO," ")!(Y=$P(DICO," ")) K DIM .I $D(DIM) S X=DICO D ^DIM S DICOMP="",DLV=DICO(1) Q I DICOMP'["S" S K=DICO(1) F S K=$O(I(K)) Q:K="" K I(K),J(K) I $D(X) S:$D(DICO("DIERR")) X="N DIERR "_X I $G(DICOMPQI) S X="N Y "_X Y K Y I $D(DICO("RCR")) S Y=DICO("RCR") E S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2))) S Y=Y_DIMW I $D(DICO("PT")) S Y=Y_"p"_DICO("PT") K K,DLV,DICOMP,DICMX Q ; ST S W=0,DG="" F S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) Q:DG="" D .I Y]"" S:+Y'=Y Y=""""_Y_"""" S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D:T-DG!(DG180 S X=X_I .Q:$D(DG(DLV0,DG))[0 .S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$G(D"_I_")" .E S I=DQI_+DG_")="_I .K DG(DLV0,DG) G OV:DG?.N1A VP .I $G(DICV)["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_"""" OV .I $L(I)+$L(X)>180 D M .S:'W X=X_" S " S X=X_I_",",W=2 D EX S W=0 Q ; M D SS,EX EXTRASB D DIMP^DICOMPZ(X) S W=0 Q ; SS Q:$A(X)-32 S X=$E(X,2,999) G SS ; EX S X=$E(X,1,$L(X)-W+1) Q ; SX S X=X_" S X=X",W=1 Q DICOMPU DICOMPU ;GFT/GFT - META-DATA-DICTIONARY LOOKUP;24JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN(Y,J,DICOMP,DICMX) ; Main Entry Point ;Y=expression; DICOMP=parameter string; J array by reference, as set up by IJ^DIUTL, or just FILE NUMBER; DICMX defined means multiples allowed N DATE,D,DD,DIS,DISTART,DICN,FIL,FIELD,F,FLD,DSPI,FILE,DIC,%,X,ASKED I $D(J)=1 S D=J K J S J(0)=D K DUOUT S DISTART=Y K Y I $L(DISTART)>31!($D(J)<9)!($L(DISTART)<3) Q "" ;1 or 2 characters isn't enough I '$D(DICOMP) S DICOMP="?" D DRW^DICOMPX ;Sets up DIC("S") (see tags PTQ+2 and ACCESS+2) S D="" F S D=$O(J(D)) Q:D="" S FILE(J(D))="" ;builds list of Files we know to start with ;Here we go, looping thru ^DDD S DIS=DISTART X F DICN=0:0 S DICN=$O(^DDD("C",DIS,DICN)) Q:'DICN S DIC=$G(^DDD(DICN,0)),X=$P(DIC,U,2),FIL=$P(DIC,U,3),FIELD=$P(DIC,U,4),F=$$LOOK G QX:$D(DUOUT) I F]"" S:$P(DIC,U,5) FIELD=FIELD_"="""_X_"""" G GOT ;That 5th piece would be a VALUE, like "ILLINOIS" I $L(DISTART)>2 S DIS=$O(^DDD("C",DIS)) I DIS]"",$P(DIS,DISTART)="" G X ;Couldn't find simple field name. Let's see if it's "FILE FIELD" S X=DISTART F DSPI=1:1:$L(X," ")-1 S FIL=$P(X," ",1,DSPI) I FIL]"",$L(FIL)<32 S FIL=$O(^DIC("B",FIL,0)) I FIL S FIELD=$P(X," ",DSPI+1,999) I FIELD]"",$L(FIELD)<32 S FIELD=$O(^DD(FIL,"B",FIELD,0)),F=$$LOOK Q:$D(DUOUT) G GOT:F]"" QX K ^TMP("DICOMPU",$J) Q "" ; ; LOOK() N TRY K ^TMP("DICOMPU",$J) ;In ^TMP("DICOMPU",$J,"F") we will store failure to go FORWARD ;In ^TMP("DICOMPU",$J,"B") we will store failure to go BACKWARD I 'FIL!'FIELD Q "" Q $$FIELD(FIL,FIELD) ;Following subroutine is called RECURSIVELY FIELD(F,DD) ;Can we TRANSlate File F, Field DD to the context of FILE? I '$D(^DD(F,DD,0)) Q "" I '$D(DICMX),$P(^(0),U,2) Q "" ;Can we go to a multiple field? I $D(TRY(F)) Q "" I '$$ACCESS(F,DD) Q "" ; Not if they don"t have access to that File & Field S TRY(F)="" N T M T=TRY N TRY M TRY=T K T ;Inherit everything tried MULTIPL ;First, can we get to the context by going up from a MULTIPLE N OUT,B,T,TRANS,L,D,I I $D(DICMX) S T=F,TRANS="" K D D I $D(D) S TRANS=$$TOOLONG(D,TRANS) D SAVE G OUT:$G(OUT) .F Q:'$D(^DD(T,0,"UP")) S D=T,TRANS=$O(^DD(T,0,"NM",0))_":"_TRANS,T=^DD(T,0,"UP"),D=$O(^DD(T,"SB",D,0)) .I TRANS=""!$D(TRY(T)) K D Q .I $D(FILE(T)) S D="",OUT=1 Q .S D=$$FIELD(T,D) I D="" K D FORWARD ;Next, can we go FROM our context TO the found File F? D D SAVE G OUT:$G(OUT) .N Y,KEEP,UP,FI,FLD ;Can we go from our context to File F? .S FI=1.9,KEEP="" PTQ .S TRANS=KEEP,FI=$O(^DD(F,0,"PT",FI)) I 'FI Q ;Can we get to this F FILE from another? .G PTQ:$D(TRY(FI))!$D(^TMP("DICOMPU",$J,"F",F,FI)) I FI[".",$D(^DD(FI,0,"UP")) G PTQ:'$D(DICMX) .S FLD=0 F .S FLD=+$O(^DD(F,0,"PT",FI,FLD)) I 'FLD G PTQ ;go thru all the Pointers to File F in File FI, and take those that... .S %=$P($G(^DD(FI,FLD,0)),U,2) I %'["P" G F ;...are regular pointers (not VARIABLE-POINTER)... .I +$P(%,"P",2)=FI G F ;not to itself .S TRANS=$P(^(0),U)_":" I $D(FILE(FI)) S OUT=1 Q .S T=$$FIELD(FI,FLD) I T="" S ^TMP("DICOMPU",$J,"F",F,FI)="" G PTQ .S KEEP=$$TOOLONG(T,TRANS) G F BACK ;Finally, is there a Pointer FROM the found file TO our context? ;if file's .01 field is a DINUM pointer, maybe we can get to it by Backwards-pointer syntax -- "FILE NAME:" I $P($G(^DD(F,.01,0)),U,2)["P",$P(^(0),U,5,99)["DINUM=X" S T=+$P($P(^(0),U,2),"P",2) I T-F,$D(FILE(T)),$G(^DIC(F,0))[U S TRANS=$P(^(0),U)_":" D SAVE G OUT I $D(DICMX) F T=0:0 S T=$O(FILE(T)) Q:'T!$G(OUT) D .N R,D,B,L,I ;Does File F eventually point to File T? .F D=1.9:0 S D=$O(^DD(T,0,"PT",D)) Q:'D D:'$D(TRY(D))&'$D(^TMP("DICOMPU",$J,"B",F,D,T)) Q:$G(OUT) ..S B=$$TOP(D) I B>0,B-T F L=0:0 S L=$O(^DD(T,0,"PT",D,L)) Q:'L I $P($G(^DD(D,L,0)),U,2)["P" F I=0:0 S I=$O(^DD(D,L,1,I)) Q:'I I +$G(^(I,0))=B,$P(^(0),U,3,9)="" D D SAVE Q:$G(OUT) ...S TRANS=$O(^DD(B,0,"NM",0))_":" I TRANS=":" S TRANS="" Q ...I B=F S OUT=1 Q ;if we are at File F, we have succeeded ...N FILE K TRY(F) S TRY(D)="",FILE(B)="",FILE=$$RECURSE ;Otherwise, we CHANGE THE CONTEXT ...I FILE]"" S TRANS=$$TOOLONG(TRANS,FILE) Q ...S TRANS="",^TMP("DICOMPU",$J,"B",F,D,T)="" OUT S OUT="",T=0 ;Of our possible paths, let's choose the SHORTEST I '$D(DUOUT) F %=1:1 Q:'$D(OUT(%)) S L=$L(OUT(%),":") D .I OUT]"" Q:T'>L I ":"_OUT(%)[":*" Q ;We don't like * fields .S OUT=OUT(%),T=L Q OUT ; RECURSE() G MULTIPL ; ; TOP(B) ; UP I '$D(^DD(B,0)) Q -999 I $D(^(0,"UP")) S B=^("UP") G UP Q B ; ACCESS(A,B) I DUZ(0)="@" Q 1 N Y S Y=$$TOP(A) I '$D(^DIC(Y,0)) Q 0 X DIC("S") E Q 0 I '$D(^DD(A,B,8)) Q 1 Q $TR(DUZ(0),^(8))'=DUZ(0) ; TOOLONG(A,B) I $L(A)+$L(B)+$L(FIELD)>($G(^DD("STRING_LIMIT"),255)-5) Q "" Q A_B ; SAVE I TRANS]"" D ASK I TRANS]"" D Q .;I TRANS'[":" K OUT S OUT=1 Q .S OUT($O(OUT(""),-1)+1)=TRANS S OUT=$G(DUOUT) Q ; ASK I $D(DUOUT) S TRANS="" Q ;TRANS is the return value I DICOMP'["?"!'DD!$G(DSPI) Q ;if Field Number is zero, or input was in form of 'FILE FIELD', don't ASK I $D(ASKED(FIL,FIELD)) S:'ASKED(FIL,FIELD) TRANS="" Q N DIASK W !?7 S DIASK(1)=DISTART,DIASK(3)=$P(DIC,U,2),%=$P(DIC,U),DIASK(2)=$P(%,"_",1,$L(%,"_")-1) D BLD^DIALOG(8201,.DIASK),MSG^DIALOG("WM") S %=1 D YN^DICN I %<0 S DUOUT=1 S ASKED(FIL,FIELD)=%=1 S:%-1 TRANS="" Q ; GOT K ^TMP("DICOMPU",$J) Q F_"#"_FIELD ;we've GOT the expression. DICOMPV DICOMPV ;SFISC/GFT BACKWARD-POINTERS IN COMPUTED FIELDS ;13APR2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DIX,DICOTRY,DICOLEV D DRW^DICOMPX TRY F DICOTRY=1,2 S Y=$$BACK I Y[U Q:Y=U D:$G(D)-.001 Y^DICOMPX G END S D=0 ;'D' is a flag to the calling routine, DICOMP0, saying we've found nothing here in DICOMPV END Q ; BACK() N DICOB,DICODD S DICOB=DLV0,DICODD=0 DD S DICODD=$O(^DD(J(DICOB),0,"PT",DICODD)) I DICODD'>0 S DICOB=DICOB-100,DICODD=0 G DD:DICOB'<0 Q "" ARCH S Y=DICODD I DICOMP["W",$P($G(^DD(Y,0,"DI")),U,2)["Y" G DD ;No editing RESTRICTED or ARCHIVE file! F DICOLEV=0:-1 G DD:'$D(^DD(Y,0)) Q:'$D(^(0,"UP")) S Y=^("UP") I $D(^DIC(Y,0)),$P(^(0),X)="" X DIC("S") I $T,$D(^DIC(Y,0,"GL")) S V=^("GL"),D=0 F S D=$O(^DD(J(DICOB),0,"PT",DICODD,D)) Q:'D D G Y:Y[U DINUM .I DICODD=Y,D=.01&(DICOTRY=1)&($P($G(^DD(Y,.01,0)),U,5,99)["DINUM=X")!(D=.001&(DICOTRY=2)) D YN("") I %=1 S %Y=V,X="D0" S:$D(DIFG) DIFG=1 D X(Y,D),P^DICOMPX S D=.001,Y=Y_U Q .Q:'$D(DICMX) ;Stop if expression can't be multiple-valued .N DICOUT F DIX=0:0 S DIX=$O(^DD(DICODD,D,1,DIX)) Q:DIX'>0 S J=$G(^(DIX,0)) I +J=Y S %=$P(J,U,3,9) I $S(DICOTRY=1:%="",1:%]""&("MUMPS"[%)) D G:$G(DICOUT) Q ..D YN("Cross-reference") I %<1 S Y=U,DICOUT=1 Q ..I %=1 D MP S DICOUT=1 .Q:DICOTRY=1 INDEXES .F DIX=0:0 S DIX=$O(^DD("IX","F",DICODD,D,DIX)) Q:'DIX I $P($G(^DD("IX",DIX,0)),U,4)="R",$P(^(0),U,9)=DICODD S J=$P(^(0),U,1,3) I +J=Y,$P($G(^(11.1,1,0)),U,2,4)=("F^"_DICODD_U_D) D YN("Index") G Q:%<1 I %=1 D MP G Q Q .Q G DD ; Y Q Y ; ; MP S DICN=$S(DA:DQI_(80+DICOB),1:"I("_DICOB_",0")_")",J=""""_$P(J,U,2)_"""",T=D S:$D(DIFG) DIFG=$P(J,"""",2) I DICOMP'["W" D G POP:$D(Y) S (Y,D)=0 Q .N DICOMPIX S DICOMPIX=J .S D=Y,I(DLV0+100)=V,J(DLV0+100)=D RCR .D BACKPNT^DICOMPZ Q:'$D(Y) .S Y=D,X=$P(^DD(D,.01,0),U,2) D X^DICOMPZ .S D="S (D,D0)=$QS(DIMQ,$QL(DIMQ)" I DICOLEV S D=D_DICOLEV .D DIMP^DICOMPZ(D_") I D,$D("_V_"D,0)) "_X_" "_DICMX) .D DIMP^DICOMPZ("N DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTRT)=$NA("_V_DICOMPIX_","_DICN_")),DIMSCNT=$QL(DIMQ) F S DIMQ=$Q(@DIMQ) Q:DIMQ="""" Q:$NA(@DIMQ,DIMSCNT)'=DIMSTRT "_X_" Q:'$D(D) S D=D0") .S X=X_" S X=""""" ASK D ASKE^DICOMPW I 'D,T-.01&'DS!(DICODD-Y) S D=0 E S DZ=0 D ASK^DICOMPW:'D I D<0 K T Q S %=D,D="N DIADD,DIC S DIC="_Y_$S(%=2:",DIADD=1",1:"")_",DIC(0)="""_$P("EQ",U,DS)_$E("L",D>0)_$E("W",$D(DICO(3))) CROSS I T-.01 S D=D_$P("AM",U,DS)_""",DIC(""S"")=""I $D("_V_""""_J_""","""_"_"_DICN_"_"_""",Y))"" D ^DIC S D0=+Y,DIC("_T_")="_DICN_",DIH="_Y_" D DICL^DICR:$P(Y,U,3)" E S D=D_"U"",X="_DICN_" D ^DIC S D0=+Y" DIM D DIMP^DICOMPZ(D) I '% S %=":$O(^(D0))>0",X=" S D0=$O("_V_J_","_DICN_",0))"_$S(DS:X_%,1:" S"_%_" D0=0") S X=X_" S X=$S(D0>0:D0,1:"""")" S:$D(DICOMPX(0)) X=X_","_DICOMPX(0)_"0)=X" POP S Y=Y_U,D=1,DICO("PT")=+Y D X(+Y,.01) Q ; X(Y,D) S DICN=Y ;Remember that we have used this field I $D(DICOMPX)#2 S DICOMPX=Y_U_D_$E(";",1,$L(DICOMPX))_DICOMPX Q ; YN(SHOW) N X S X=$P(^DIC(Y,0),U) S %=1 I DICOMP["?" D YOU .N N ;**CCO/NI (+ next 2 lines) 'BY SO&SO, DO YOU MEAN THE SUCH&SUCH FILE, POINTING...?' .S N(1)=DICN,N(2)=X,N(3)=$P(^DD(DICODD,D,0),U),DICV=$P(^(0),U,2) .W !,$$EZBLD^DIALOG(8202,.N) .I SHOW]"" W !," (""",$P(J,U,2),""" ",SHOW,")" .D YN^DICN I %=1 F M=M:1:$L(I)+1 Q:$F(X,$E(I,1,M))-1-M S W=$E(I,M+1) Q DICOMPW DICOMPW ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;13APR2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. COLON N DICOMPW K DP,Y S DICOMPW=DICOMP ;COME HERE WHEN INPUT ENDS IN COLON I $D(DIC)#2,$P(X,":",2)="" S X=$P(X,":"),DIC(0)="FIZO",DIC("S")="N A S A=$P(^(0),U,2) I A[""P""!(A[""p""),'A" N DICR,DO,DIY D ^DIC K DIC S X=X_":" D:Y>0 ARC I Y>0 S X="INTERNAL(#"_+Y_")",DP=+$P($P(Y(0),U,2),"P",2)_U_$P(Y(0),U,3) I I $P(Y(0),U,2)["p" S X=$P(Y(0),U,5,99),DP=+$P($P(Y(0),U,2),"p",2),DP=DP_$G(^DIC(DP,0,"GL")),Y=0 G JUMP:$P(Y(0),U,2)'["m" S DICOMPW=DICOMP+100 D IJ S Y=D_"m" Q ;computed pointer, possibly multiple I $G(Y)'>0 S X=$E(X,1,$L(X)-1),DICOMPX="",DICOMPX(0)="D(" S DICOMP=DICOMP_"S" D EN^DICOMP G Q:'$D(X) I '$D(DP) K:Y'>DICOMPW X S %=I(+Y),DP=J(+Y)_$S(%[U:%,1:U_$P(%,"""",1)_$P(%,"""",2)) G Q JUMP S:$D(DIFG) DIFG=2 S DICOMP=DICOMPW D DRW^DICOMPX G Q:'$D(^DIC(+DP,0)) S D=Y,Y=+DP X DIC("S") S Y=D I '$T K X,DIC("S") G Q IJ F D=DICOMPW\100*100:1 S X="S I("_D_",0)=D"_(D#100)_" "_X I +DICOMPW=D S X=X_" S D(0)=+X",D=Y\100+1*100,I(D)=U_$P(DP,U,2),J(D)=+DP,Y=D_U_Y Q Q S:$D(DIFG)&$D(X) DIFG("DICOMP")=DICOMPX K DICOMP,DICOMPX,DICOMPW Q ; ; M ; S (D,DS)=0,DZ="""",Y=J(DLV) I DICOMP["W" D ASKE,ASK:'D I D<0 K X Q S:DS DZ="E""" I D S DZ=$E("W",$D(DICO(3)))_"L"_DZ_$S(DLV=DLV0:"",1:",DIC(""P"")="""_$P(^DD(J(DLV-1),$O(^DD(J(DLV-1),"SB",J(DLV),0)),0),U,2)_"""") I D=2 S DZ=DZ_",X=""""""""_X_""""""""" S (%,%Y)=DLV#100,DZ="N DIC S DIC=X N X S X=DIC,"_$P("Y=-1,",U,%>0)_"DIC="""_X_""",DIC(0)=""MF"_DZ_" D ^DIC"_$P(":D"_(%-1)_">0",U,%>0),X=" S (D,D"_%_$S($D(DICOMPX(0)):","_DICOMPX(0)_%_")",1:"")_")=+Y" I D F %=%:-1:1 S X=X_",DA("_%_")=DIU("_%_")",DZ=DZ_",DIU("_%_")=$S($D(DA("_%_")):DA("_%_"),1:0),DA("_%_")=D"_(%Y-%) S %=X D DIMP^DICOMPZ(DZ) S X=X_% I W=":" S M=M+1 Q S I="#.01"_$E(I,M,999),M=0 Q ; ASKE ; S (D,DS)=0,%=1 I DICOMP["?",DICOMP["E" W !,$$EZBLD^DIALOG(8203,$$FILENAME^DIALOGZ(Y)) D YN^DICN S:%=1 DS=1 ;**CCO/NI 'WILL USER SELECT?' S:%<0 D=% Q:% D DICOMPW^DIQQQ G ASKE ; ASK ; G NO:DICOMP'["?",ASK1:DUZ(0)="@" S DIFILE=Y,DIAC="LAYGO" D ^DIAC K DIAC,DIFILE G:'% NO ASK1 W !,$$EZBLD^DIALOG(8204,$$FILENAME^DIALOGZ(Y)) ;**CCO/NI WANT TO PERMIT ADDING...? S %=2-(DICOMP["L"),D=0 D YN^DICN W ! I %<1 S D=-1 Q ASK2 Q:%=2 S D=1 Q:DZ W $$EZBLD^DIALOG(8205) ;**CCO/NI WELL, WANT TO *FORCCE* ADING...? S %=2-(DICOMP["L2") D YN^DICN I %<1 S D=-1 Q S D=3-%,DICO(2)=1 Q:%=1!'DS ASK3 W !,$$EZBLD^DIALOG(8206,$$FILENAME^DIALOGZ(Y)) D YN^DICN I %<1 S D=-1 Q ;**CCO/NI WANT AN 'ADDING NEW?' MESSAGE? Q:%=1 S DICO(3)=% Q NO S D=0 Q ; DPS ; S X=DPS(DPS),%=$O(DPS(DPS,"$")) S:$D(DPS(DPS,"BOOL")) DBOOL=DPS(DPS,"BOOL") I %["$" S X=X_"X)"_DPS(DPS,%) D .N % S %=X N X S X=% F Q:$E(X)'=" " S X=$E(X,2,999) .D ^DIM I '$D(X) S W(DPS)="BAD SYNTAX!" I $D(DPS(DPS,"DATE")) S DATE(K+1)=1 S %=$D(DATE(K)) I $D(DPS(DPS,U)) S K=K+2,K(K-1)=X,K(K)=$E(DPS(DPS,U)),X=$E(DPS(DPS,U),2,99) I %&$D(DPS(DPS,"O"))!$D(DPS(DPS,"D"))!$D(DPS(DPS,"DATE")) S DATE(K+1)=1 E I '$D(DPS(DPS,"ST")) S K(K+1,9)=0 K DPS(DPS) S DPS=DPS-1 Q ARC ; Q:DICOMP'["W" RES N N S N=+$P($P(Y(0),U,2),"P",2) I $P($G(^DD(N,0,"DI")),U,2)["Y" W !,$C(7),$$EZBLD^DIALOG(405,N) S Y=-1 ;**CCO/NI 'CANNOT EDIT RESTRICTED FILE' Q DICOMPX DICOMPX ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2SEP2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; M ;From DICOMP S DICOMPXM=M F D F Q:$D(X) D Q:'$D(X) ;Try as long a file name as possible .I M<$L(I) F M=M+1:1 S W=$E(I,M) I DPUNC[W S X=$E(I,1,M-1) Q S:'$D(X) M=DICOMPXM K DICOMPXM Q ; F I '$D(J(0)) K X Q S DIC("S")="I $P(^(0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)'[""W""" MM S DICN=X,T=DLV S:X?1"#".NP X=$E(X,2,99) TRY S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " D DICS^DICOMPY,^DIC G R:Y<0 F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1) I DICOMP["?",$P(Y,U,2)'=DICN W !?3,"By '"_DICN_"', do you mean the '"_$P(Y,U,2)_"' Subfield" S %=1 D YN^DICN I %-1 G R:%+1 K X Q S M=D,Y=+$P(Y(0),U,2),X=$P($P(Y(0),U,4),";") I +X'=X S X=""""_X_"""" S (DLV,D)=DLV0+100 F %=T\100*100:1 Q:%>T S J(DLV)=J(%),I(DLV)=I(%),DLV=DLV+1 S I(DLV)=X,X=$$CONVQQ^DILIBF(I(D)),J(DLV)=Y D S DLV0=DLV0+100 F DLV=D:1:DLV D SN REF .F Y=D+1:1:DLV S V=Y#100-1,DICN=$$CONVQQ^DILIBF(I(Y)),X=X_$S(T0 S X=$$CONVQQ^DILIBF(^(0,"GL")) G Y K X Q ; Y ; S DLV0=DLV0+100,I(DLV0)=^DIC(+Y,0,"GL"),J(DLV0)=+Y F DLV=DLV+100:-1:DLV0 D SN Q ; SN D SV(DLV0-100) S DG(DLV0)=DLV Q ; SV(%X) ;also called from DICOMPY S (T,DG(%X))=DG(%X)+1,%=DLV#100,K(K+2,1)=DLV0,DG(%X,T)=%,M(%,%X+%)=T Q ; ; OKFILE(Y,DICOMP) ;Called from DICATT6 Block, DICATT3, DICOMP0 to see if we can jump to FILE Y I DICOMP'["W",DICOMP'["?" Q 1 ;DICOMP either does or doesn't contain "W" and "?" N D,DIC,DIAC,DIFILE,% D DRW I $D(^DIC(Y,0)) X DIC("S") Q $T ; DRW ;also called from DICOMPV, and DICOMPW to filter FILE names S D=$S(DICOMP["W":"""WR""",1:"""RD""") S DIC("S")="S DIAC="_D_",DIFILE=+Y D ^DIAC I %" Q ; P ;from DINUM^DICOMPV, DICOMP0 S X=" S D0="_X_" S:'D0!'$D("_%Y_"+D0,0)) D0=-1" I $D(DICOMPX(0)) S X=X_" S "_DICOMPX(0)_"0)=D0",DICOMPX(0,DICN)="" D ST I W=":" D .S M=M+1,W="",%=$E(I,M,999) I %,+%=$P(%,")") S I=$E(I,1,M-1)_"#"_% E S I="#.01"_$E(I,M,999),M=1,W="" S DLV0=DLV0+100,I(DLV0)=%Y,J(DLV0)=DICN F DLV=DLV+100:-1:DLV0 D SN Q ; ST N X D ST^DICOMP S DPS(DPS,"ST")=1,K=K+1,K(K)=X Q DICOMPY DICOMPY ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;10:22 AM 8 Jan 2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DICOINS,DICOLEFT S K(K+1)=X,I=$E(I,M+1,999) I I'[")" K Y Q ARG D S DICOLEFT=$E(I,%+1,999),I=$E(I,1,%-1) .N C,S S S=0 .F %=1:1 S C=$E(I,%) D:C="""" S:C="(" S=S+1 S:C=")" S=S-1 Q:S<0!(C="") ..F %=%+1:1 Q:""""[$E(I,%) PREVNEXT I DICF="PREVIOUS"!(DICF="NEXT") N DICMX D D RCR^DICOMPZ(I) G BAD:'$D(Y) S DICN=X,X=DICF G OK .D SV^DICOMPX(DLV0) .S %=DLV#100,DICF=" S D"_%_"=+$O("_$$REF^DICOMPZ(DLV)_")"_$P(",-1",U,DICF="PREVIOUS")_") " D FUNC N DICMX S DICMX=DICOINS D RCR^DICOMPZ(I) I $G(Y)'["m" G BAD OK S K=K+1,K(K)=X,K(K,2)=0,K=K+1,K(K)=DICN I "TOTAL"=DICF!("COUNT"=DICF) K DATE(K-1) RES S I=DICOLEFT,M=0 Q ; FUNC S DICN=$$DGI^DICOMP,W=DLV#100,K=K+2,K(K)=" S "_DICN_"=""""" NUMBER I DICF S %X=$$DGI^DICOMP,K(K)=" S "_%X_"=0"_K(K) D L S DICOINS=DICOINS_" "_%X_"="_%X_"+1 I "_%X_"="_+DICF_",Y'?."" "" S "_DICN_"=Y Q ",DPS(DPS,"O")="" Q I $T(@DICF)]"" G @DICF BAD S DPS=0 Q ; ; MAXIMUM S %X="'>" G MM MINIMUM S %X="'<" MM D L S DICOINS=DICOINS_"&("_DICN_%X_"Y!'$L("_DICN_")) "_DICN_"=Y" Q TOTAL S DICOINS="S "_DICN_"="_DICN_"+X" Q COUNT S DICOINS="S:X'?."" "" "_DICN_"="_DICN_"+1",DICN="+"_DICN Q LAST D L S DICOINS=DICOINS_" "_DICN_"=Y" Q L S DICOINS="S Y=X S:Y'?."" """ Q ; ; W S X=$P(Y(0),U,4),Y=$P(X,";",1),X=$P(X,";",2) Q ; DICS ; S:DUZ(0)'="@" D=DICOMP["W"+8,DIC("S")=DIC("S")_" Q:'$L($G("_DIC_"Y,"_D_"))) I $TR(DUZ(0),^("_D_"))'=DUZ(0)" Q G ; D W I X="" S Y=T#100,X=$S(T0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien E D DIMP(D_"""B"",DICOB,D)) Q:D'>0 I $D("_DICOR_DICOMPXE) S D="N DICOB S DICOB="""" F S DICOB=$O("_DICOR_"""B"",DICOB)) Q:DICOB="""" "_X_" Q:'$D(D)" ;We will go thru the multiple using the B X-ref D DIMP($$I(Y)_D) I DICOPS'?1P S K(K+1,2)=1 ;If it is just a multiple, it can't be followed by an operator (see BINOP^DICOMP) S (T,DG(DLV0))=DG(DLV0)+1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T S X=X_":D"_(Y-1)_">0" DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR) Q ; CONTAINS N DICON S DICON=W="'",%=$E(I,M+DICON) I %=""!(W=")") S Y=0 Q I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q .S DICOXR=$$DGI^DICOMP .D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X .S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1 .S DBOOL=1,DIMW="" COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple! ; R(DICORM) N DICOLEFT,DICOX S DICOLEFT="",DICOX=0 F %=1:1 S W=$E(DICORM,%) Q:W="" S:W="(" DICOX=DICOX+1 I W=")" S DICOX=DICOX-1 I DICOX<0 S DICOLEFT=$E(DICORM,%,999),DICORM=$E(DICORM,1,%-1) S DICOX=$G(X) D RCR(DICORM) S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q ; RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression. N D S:+W=W W=""""_W_"""" S D="ZXM"_$$DIMC_" S"_DICOMP D ;Don't allow MUMPS. Remember where to start more nodes in X array. Allow simple numeric. .N X,DICOMP,DLV,DICMXSV,K .S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX DQI .I $D(DQI) S %=DQI N DQI S DQI=%_$$DIMC_"," .D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point .I '$D(X) K Y Q .K W M W=X .I Y["m" K DICMXSV .I $D(DICMXSV) S DICMX=DICMXSV I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE Q ; DIMP(D) ; N DIM S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01) S X(DIM)=D,X=" X "_$$DA_DIM_")" Q ; DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA) ; DIMC() N DIM S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1 Q DIM ; X ; S X="S X=$P(^(0),U)"_$S(X["D"&'$D(DPS($$NEST^DICOMP,"INTERNAL")):",Y=X X ^DD(""DD"") S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U)",X["S":",Y=$F(^DD("_+D_",.01,0),X_$C(58)) S:Y X=$P($E(^(0),Y,999),$C(59),1)",1:""),DIMW="m" Q ; I(LEV) N S S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q "" Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" " ; REF(T) ; N L,D,X,V F L=T\100*100:1:T S D=I(L) S X=$G(X)_D_$E(",",$D(X))_$S(L70 S P=P_$P(" & ^",U,P]"")_X Q . . S:P'["..." P=P_"..." Q . I P]"",DS]"" S X=P D DS . I @("$D("_DIC_"DIX))>9!$D(DF)"),DD="" S DD=DIX,DIW=% S:'DICNT DICNT=2 S:'$D(^(DD)) DICNT=0,DIUPRITE=0 . I DIC(0)'["M" S DIX="" Q . D NXTINDX^DICF2(.DIX,.DIFORCE,.DIFILEI,DIF,"","*") Q:DIX="" . D INDEX^DICUIX(.DIFILEI,"hql",.DIX) Q K DIX I DIBEGIX=DD M DIX=DISAVIX E S (DIBEGIX,DIX)=DD I DIX]"" S DIX("WAY")=1 D INDEX^DICUIX(.DIFILEI,"hl",.DIX) I DD="" S DIUPRITE=1 I $O(^DD(DIFILEI,0,"IX","AZ"))]""!($O(^DD("IX","BB",DIFILEI,"AZ"))]"") S DICNT=0 S:DZ["BAD" DICNT=0 Q ; DSPFLD ; Display list of lookup fields N X S DST=$$EZBLD^DIALOG(8063,$P(DO,U)),DS=0 F X=1:1 S DS=$O(DS(DS)) Q:DS="" D . S:X>1!$G(DS(0)) DST=DST_$$EZBLD^DIALOG(8067) . D:$L(DST)+$L(DS(DS))>70 N S DST=DST_" "_DS(DS) Q K DS S DST=DST_$E(":",DICNT) D % Q ; ASKCUR ; Ask if user wants to see existing entries N A1 S DDH=DDH+1,A1=0_U_$$EZBLD^DIALOG(8064) I DO(2)'["s",'$D(DIC("S")),'$D(DIC("V")),'$D(DF),'$D(DIC("?PARAM",DIFILEI)) S A1=A1_$$EZBLD^DIALOG(8065,DICNT) S DDH(DDH,"Q")=A1_$$EZBLD^DIALOG(8066,$P(DO,U)) S:$D(DDS) DDD=1 D ^DDSU I '$D(DDS),$D(DTOUT) S (DIOUT,DIDONE)=1 Q I $D(DDS) S %=1 I $D(DDSQ) S (DIOUT,DIDONE)=1 Q ; Process answer to question about seeing existing entries. S A1="T",DDH=+$G(DDH) S:%=1 %Y=1 I %Y'="??" D . N F S F=$E(%Y,2,99) I $E(%Y)="^",F]"" S DIFROM=F . S %Y=F Q S:%=2&(DIC(0)["L") DZ="" I (%#2)=0!(%<0&(%Y="")) S (DIOUT,DIDONE)=1 Q I DIFROM="" S DIOUT=1 Q S DIUPRITE=$S(+$P(DIFROM,"E")=DIFROM:1,DIBEGIX]"":0,1:DIUPRITE) I +$P(DIFROM,"E")=DIFROM S DIOUT=1 Q Q:DIBEGIX="" I $P(DIW,U,1)'["D" S DIOUT=1 Q N %DT,Y S X=DIFROM,%DT="T" D ^%DT S DIFROM=Y,DIUPRITE=0 I DIFROM<0 S DST=$C(7) D % Q S DIOUT=1 Q ; DSPHLP(DIC,DIFILE,DINDEX,DZ,DINOKILL) ; Display online help for lookups (^DIC) N D S D=DINDEX I $D(DIBTDH) K DIBTDH Q S:$D(DDSXEC) DIBTDH=1 ; Set only if there is eXecutable Help to prevent repeated '??' display from AST^DIEQ I DIC(0)]"" D DQ Q:$G(DINOKILL) I '$D(DDS),$G(DDH) D ^DDSU I $D(DTOUT) S Y=-1 D Q^DIC2 Q D A^DIC Q ; N D % S DST=" " Q ; % ;CALLED FROM ^DICQ1 S DDH=$G(DDH)+1,DDH(DDH,"T")=DST K DST Q ; 0 Q:$D(DTOUT)!(DIC(0)'["L") K DIW,DIUPRITE S:$D(DDS) DDD=1 D 0^DICQ1 Q ; DIY S DIY=$P(^DD(+$P(DIY,U,2),.01,0),"$L(X)>",2),DIY=$S(DIY:DIY,1:30)+7 Q ; SOUNDEX G DQ1 ; DS S:DO'[X DS(DS)=X I DO[X,$G(DZ)'["??" S DS(0)=1 Q ; ; ; ;#8063 Answer with |Filename| ;#8064 Do you want the entire ;#8065 |Number of entries| Entry ;#8066 |Filename| List ;#8067 , or ;#8068 Choose from ; couldn't find a reference SO 8/11/00 DICQ1 DICQ1 ;SFISC/GFT,TKW-HELP FOR LOOKUPS ;3JUN2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN ; Set up parameters for lister call, then display current entries. I 'DIRECUR,'$D(DDS) D Z^DDSU I DICNT>1,$D(DZ)#2 S DST=" " D:DZ["??"&'$D(DDS) %^DICQ S DST=$$EZBLD^DIALOG(8068) D %^DICQ N DISCR S:$G(DIC("S"))]"" DISCR("S")=DIC("S") I $D(DIC("V")) M DISCR("V")=DIC("V") S %=$G(DIC("?PARAM",DIFILEI,"INDEX")) I %]"" D . S (DIX,DIBEGIX)=%,DIX("WAY")=1 D INDEX^DICUIX(.DIFILEI,"hl",.DIX) Q I $O(DIC("?PARAM",DIFILEI,"PART",0)) S DIPART(1)="",%=0 D . F S %=$O(DIC("?PARAM",DIFILEI,"PART",%)) Q:'% I '(%#1) S DIPART(%)=DIC("?PARAM",DIFILEI,"PART",%) . S DIPART=DIPART(1) Q N DIFLAGS,DIFIELDS,DIIENS S DIFLAGS="MPh" I 'DIUPRITE,"PV"[$G(DIX(1,"TYPE")) D . N DIFRPRT S DIFRPRT=DIFROM_$G(DIC("?PARAM",DIFILEI,"FROM",1))_$G(DIPART) . Q:'$$CHKP^DICUIX1(.DIFILEI,.DIX,DDC,DIFRPRT,.DISCR,1) . S DIFLAGS="MPQh" K DIFROM S DIFROM="" Q I DIUPRITE S DID01=0,DIBEGIX="#" S DIIENS=$S(DIC(0)["p":",",1:DIENS) W S DIFIELDS="@;IX" D .I 'DIUPRITE,DID01!(DIC(0)["S") K DID01 Q .N EXT S EXT="$$EXT^DIC2("_DIFILEI_",.01,$P("_DIC_"Y,0),U))" .I '$D(DDS)!'$D(DDSMOUSY) S DIC("DID01")="W "" "","_EXT Q .S DIC("DID01")="W "" "" D WRITMOUS^DDSU("_EXT_")" E1 K DDD S DD="",DIY=99,DDD=$S($D(DDS):1,1:5),(DIZ,DILN)=21 I $D(DDH)>10 D LIST^DDSU Q:$D(DDSQ) I DIFROM]"" D S DIFROM(1)=DIFROM . I +$P(DIFROM,"E")=DIFROM S DIFROM=DIFROM-.00000001 Q . N M F %=$L(DIFROM):-1:1 S M=$A(DIFROM,%) I M>32 S DIFROM=$E(DIFROM,1,%-1)_$C(M-1)_$C(122) Q . Q I DIFLAGS'["Q" S %=$G(DIC("?PARAM",DIFILEI,"FROM",1)) I %]"" D . S:DIFROM="" (DIFROM,DIFROM(1))=% S %=1 . F S %=$O(DIC("?PARAM",DIFILEI,"FROM",%)) Q:'% I '(%#1) S DIFROM(%)=DIC("?PARAM",DIFILEI,"FROM",%) . Q ; L ; List current entries in the file. N DICQ D LIST^DICL(.DIFILEI,DIIENS,DIFIELDS,DIFLAGS,DDC,.DIFROM,.DIPART,DIBEGIX,.DISCR,"","DICQ","",.DIC) K DIC("DID01"),DICQ D BK^DIEQ S:'$D(DDS) DDD=3 ;D LIST^DDSU *** K DDH Q:$D(DDSQ)!($G(DTOUT)) D 0 Q ; DSP(DINDEX,DICQ,DIC,DIFILE) ; Display entries from DICQ array ; note: this routine is called from the lister, DICLIX & DICL1. N I,J,F,X,Y,DD,DDD,DIY,DILN,DIZ,DIMAP,DDH,DID01,DIQUIET,DIPGM,DST,DISPACE,DIERR,DP S DIMAP=$G(DICQ(0,"MAP")),DDH=0,DST="",DIPGM="DICQ1",$P(DISPACE," ",10)="" S:$G(DIC("DID01"))]"" DID01=DIC("DID01") N DIKEYL,DIKEY I $O(DIFILE(DIFILE,"KEY",DIFILE,0)),DIC(0)'["S" M DIKEYL=DIFILE(DIFILE,"KEY",DIFILE) I $D(DIC("W"))!($D(DID01))!($D(DIKEYL)) D ID F I=0:0 S I=$O(DICQ(I)) Q:'I S X=$G(DICQ(I,0)) I X]"" D . S DST="" . I DINDEX="#" S DST=$P(X,U)_" " S:$L(DST)<7 DST=DST_$E(DISPACE,($L(DST)+1),7) . I $D(DIKEYL) S DIKEY(+X)="" F J=0:0 S J=$O(DIKEYL(J)) Q:'J!$G(DIERR) F F=0:0 S F=$O(DIKEYL(J,F)) Q:'F!$G(DIERR) D . . I (F=.01&($D(DID01))!(DINDEX("FLISTD")[("^"_F_"^"))) D Q . . . S:DIKEY(+X)="" DIKEY(+X)=" " Q . . S Y=$$GET1^DIQ(DIFILE,+X_DIFILE(DIFILE,"KEY","IEN"),F,"","","DIERR") Q:$G(DIERR) . . I ($L(DIKEY(+X)))+($L(Y))+2>240 S DIERR=1 Q . . S DIKEY(+X)=DIKEY(+X)_$P(" ^",U,DIKEY(+X)]"")_Y Q . F J=2:1 Q:$P(DIMAP,U,J)="" S Y=$P(X,U,J) D:$P(DIMAP,U,J+1)]"" S:$L(DST_Y)<240 DST=DST_Y . . S Y=Y_" " . . I J=(DINDEX("#")+1) S Y=Y_" " . . Q . I DST]"" S Y=+X,DDH=DDH+1,DDH(DDH,Y)=DST_" " . Q S DD="",DIY=99,DDD=5,DP=DIFILE I '$G(DIC("?N",DIFILE)) S (DIZ,DILN)=21 E S (DIZ,DILN)=999 D LIST^DDSU K DICQ K DIERR,^TMP("DIERR",$J) Q ; ID ; Put code to display .01 field and Identifiers into DDH array. S DIY="I $D("_DIC_"Y,0))" I $D(DID01) S DIY=DIY_" "_DID01_" "_DIY I $D(DIKEYL) S:$D(DID01) DIY=DIY_" W "" """ S DIY=DIY_" W DIKEY(Y)" I '$D(DIC("W")) S DDH("ID")=DIY Q S DIY=DIY_" " I $L(DIC("W"))+$L(DIY)<240 S DDH("ID")=DIY_DIC("W") Q S DDH("ID")=DIY_"X DDH(""ID"",1)" S DDH("ID",1)=DIC("W") Q ; WOV N DIC,Y,DI1X,DIY,DIYX,%,C,DINAME S DIC=DIGBL,Y=DIEN,DI1X=0 W1 F S DI1X=$O(^DD(DIFILEI,0,"ID",DI1X)) Q:DI1X="" S %=^(DI1X) D . X "W "" "",$E("_DIGBL_DIEN_",0),0)",% Q ; 0 ; If LAYGO allowed, display additional help. K DDC,DIEQ,DIW,DS I DIC(0)'["L" D QQ Q I $D(%Y)#2 S:%Y="??" DZ=%Y S:%Y?1P DZ="?" S DDH=+$G(DDH) N A1,DIACCESS S DIACCESS=1 I $S($D(DLAYGO):DIFILEI-DLAYGO\1,1:1),DUZ(0)'="@",'$D(^DD(DIFILEI,0,"UP")) D CHKACC I '$G(DIACCESS) D RCR Q 10 ; Tell user that they may enter new entries to the file I DZ?1."?" S DST=" " D DS^DIEQ S DST=$$EZBLD^DIALOG(8069,$P(DO,U)) D DS^DIEQ D:DZ="?" HP D H I DO(2)["S" S DST=$$EZBLD^DIALOG(8068)_" " D %^DICQ D . N X,Y,A2,DST,DISETOC,DIMAXL S DIMAXL=0,DISETOC=$P(^DD(+DO(2),.01,0),U,3) . F X=1:1 S Y=$P($P(DISETOC,";",X),":") Q:Y="" S:$L(Y)>DIMAXL DIMAXL=$L(Y) . S DIMAXL=DIMAXL+4 . F X=1:1 S Y=$P(DISETOC,";",X) Q:Y="" S A2="",$P(A2," ",DIMAXL-$L($P(Y,":")))=" ",DST=" "_$P(Y,":")_A2_$P(Y,":",2) D DS^DIEQ . Q I DO(2)["V" D . N DG,DU,D . S DU=+DO(2),D=.01 D V^DIEQ Q ; RCR ; Recursive call to display entries on pointed-to file. I DO(2)'["P"!($G(DZ(1))=0) D QQ Q N %,D,DS,DIPTRIX S D="" S DS=^DD(+DO(2),.01,0) S DIPTRIX=$G(DIC("PTRIX",+DO(2),.01,+$P($P(DS,U,2),"P",2))) M %=DIC("PTRIX"),%(1)=DIC("?N"),%(2)=DIC("?PARAM") N DIC M DIC("PTRIX")=%,DIC("?N")=%(1),DIC("?PARAM")=%(2) K % S DIC=U_$P(DS,U,3),DIC(0)=$E("L",$P(DS,U,2)'["'") I $P(DS,U,2)["*" D . N DILCV,DICP,DIPTRIX,DISAV0 S DISAV0=DIC(0) . F DILCV=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S DICP=$F(DS,DILCV) I DICP D S DIC(0)=DISAV0 . . X $P($E(DS,1,DICP-$L(DILCV)-1),U,5,99) Q . S D=$P($G(D),U) Q S:DIPTRIX]"" D=$P(DIPTRIX,U) K DIPTRIX,DS N DO,DIFILEI,DINDEX I D="" S D="B" S DIRECUR=DIRECUR+1 D DQ^DICQ QQ Q:$D(DDH)'>10 K DDD S DD="",DIY=99,DDD=$S($D(DDS):1,1:5),(DIZ,DILN)=21 S:$D(DDS) DDC=-1 D LIST^DDSU K DDC Q ; HP N DG,X,%,DST EGP S X=$$HELP^DIALOGZ(+DO(2),.01) D S X=$G(^DD(+DO(2),.01,12)) D ;**CCO/NI PLUS NEXT LINE WRITE HELP MESSAGE FOR .01 FIELD .I X]"" F %=$L(X," "):-1:1 I $L($P(X," ",1,%))<70 S DST=$P(X," ",1,%) D DS^DIEQ,P1 Q Q ; P1 I %'=$L(X," ") S DST=$P(X," ",%+1,99) D DS^DIEQ Q ; H ; Display eXecutable help and long description for .01 field. N %,X,DIPGM S %=DIC,X=DZ,DIPGM="DICQ1" D . N DIC,D,DP,DIFILEI,DINDEX,DZ S DZ=X . S DIC=%,D=.01,DP=+DO(2) D H^DIEQ Q Q ; CHKACC ;Check file access N A1,DIFILE,DIAC,% S DIFILE=+DO(2),DIAC="LAYGO",%=0 D ^DIAC S:% DIACCESS=1 Q ; ;#8069 You may enter a new |filename|, if you wish ;#8068 Choose from DICR DICR ;SFISC/GFT-RECURSIVE CALL FOR X-REFS ON TRIGGERED FLDS ;6DEC2004 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 3 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;From a TRIGGER on field DIH,DIG ;DIU is old value, DIV new AUDIT I $P(^DD(DIH,DIG,0),U,2)["a" D ;NOIS ISB-1102-31285 .N DIANUM,DIIX,C,DP .I DIU]"" S X=DIU,DIIX=2_U_DIG,DP=DIH D AUDIT^DIET .I DIV]"",^DD(DIH,DIG,"AUDIT")'="e"!(DIU]"") S X=DIV,DIIX=3_U_DIG,DP=DIH D AUDIT^DIET ;Don't audit NEW if there's no OLD and mode is EDIT ONLY Q:'$O(^DD(DIH,DIG,1,0))&'$D(^DD("IX","F",DIH,DIG)) N DICRIENS,DICRBADK I $D(^DD("KEY","F",DIH,DIG)) D Q:$G(DICRBADK) . N DICRFDA,DICRMSG,DIERR . D SAVE . S DICRIENS=$$IENS(DIH,.DA) . S DICRFDA(DIH,DICRIENS,DIG)=DIV . I '$$KEYVAL^DIE("","DICRFDA","DICRMSG") D .. S DICRBADK=1 .. S X=DIU X $$HSET(DIH,DIG) . D RESTORE ; I DIU]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIU Q:'DIW I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,2)) S DB(0,DIH,DIG,DIW,2)=1 D SAVE X ^(2) D RESTORE I DIV]"" F DIW=0:0 S DIW=$O(^DD(DIH,DIG,1,DIW)),X=DIV Q:'DIW I $P(^(DIW,0),U,3)=""!'$D(DB(0,DIH,DIG,DIW,1)) S DB(0,DIH,DIG,DIW,1)=1 D SAVE X ^(1) D RESTORE ; I $D(^DD("IX","F",DIH,DIG)) D . N DICRCTRL,DICRVAL,I . D SAVE . S:$D(DICRIENS)[0 DICRIENS=$$IENS(DIH,.DA) . S DICRVAL(DIH,DICRIENS,DIG,"O")=DIU . S DICRVAL(DIH,DICRIENS,DIG,"N")=DIV . S:$G(DICRREC)]"" DICRCTRL="r" . S DICRCTRL("VAL")="DICRVAL(" . D INDEX^DIKC(DIH,.DA,DIG,"",.DICRCTRL) . D:$G(DICRREC)]"" @DICRREC . D RESTORE Q Q ; SAVE F DB=1:1 Q:'$D(DB(DB)) F Y="DIC","DIV","DA" S %="" F DB=DB:0 S @("%=$O("_Y_"(%))") Q:%="" S DB(DB,Y,%)=@(Y_"(%)") F %="DIC","DIW","DIU","DIV","DIH","DIG","DB","DG","DA","DICR" S DB(DB,%)="" I $D(@%)#2 S DB(DB,%)=@% K DA F Y=-1:1 Q:'$D(DIV(Y+1)) I Y+1 S DA=DIV(Y) F %=Y-1:-1:0 S DA(Y-%)=DIV(%) Q ; RESTORE F DB=1:1 Q:'$D(DB(DB+1)) F Y="DIC","DIV","DA" K @Y S %="" F DB=DB:0 S %=$O(DB(DB,Y,%)) Q:%="" S @(Y_"(%)=DB(DB,Y,%)") S Y="" F %=0:0 S Y=$O(DB(DB,Y)) Q:Y="" S @Y=DB(DB,Y) K DB(DB) K:DB=1 DB Q ; DICL N I K DIC("S"),DLAYGO I '$P(Y,U,3) K DIC Q DICADD ; S (D0,DIV(0))=+Y,DIV(U)=Y I DIC S DIH=DIC,DIC=^DIC(DIC,0,"GL") E S @("DIH=+$P("_DIC_"0),U,2)") S DICR=$S($D(DA)#2:DA,1:0),DA=D0 F DIG=.001:0 S DIG=$O(DIC(DIG)) Q:DIG'>0 D U:DIC(DIG)]"" S DA=DICR,Y=DIV(U) K DIC Q ; U S %=$P(^DD(DIH,DIG,0),U,4),Y=$P(%,";",2),%=$P(%,";",1),X="",DIV=DIC(DIG) I @("$D("_DIC_DIV(0)_",%))") S X=^(%) G P:Y,Q:Y'?1"E"1N.NP S D=+$E(Y,2,9),Y=$P(Y,",",2),DIU=$E(X,D,Y) I DIU?." " S DIU="" S:$L(X)+10 K DA,DIH,DIG,DIV Q ; TRIG(DICRLIST,DICROUT) ;Modify the trigger logic of fields that trigger fields ;in DICRLIST so that they call ^DICR unconditionally. ;In: ; DICRLIST(file#,field#) = array of potentionally triggered fields ;Out: ; DICROUT(file,field)="" (of triggering field modified) ; N DICRFIL,DICRFLD S DICRFIL="" F S DICRFIL=$O(DICRLIST(DICRFIL)) Q:'DICRFIL D . S DICRFLD="" . F S DICRFLD=$O(DICRLIST(DICRFIL,DICRFLD)) Q:'DICRFLD D TRMOD(DICRFIL,DICRFLD,.DICROUT) Q ; TRMOD(DICRFIL,DICRFLD,DICROUT) ;Modify the trigger logic of fields that ;trigger a field so that they call ^DICR unconditionally. ;In: ; DICRFIL = file# of triggered field ; DICRFLD = triggered field# ;Out: ; DICROUT(file,field)="" (of triggering field modified) ; ;Loop through 5 node to get triggering fields/xrefs N DICRN,DICRFL,DICRFD,DICRXR S DICRN=0 F S DICRN=$O(^DD(DICRFIL,DICRFLD,5,DICRN)) Q:'DICRN D . S DICRXR=$G(^DD(DICRFIL,DICRFLD,5,DICRN,0)) . S DICRFL=+$P(DICRXR,U),DICRFD=+$P(DICRXR,U,2),DICRXR=+$P(DICRXR,U,3) . Q:'DICRFL!'DICRFD!'DICRXR . D MOD(DICRFL,DICRFD,DICRXR,.DICROUT) Q ; MOD(DICRFL,DICRFD,DICRXR,DICROUT) ;Modify trigger logic ;In: ; DICRFL = file# of triggering field ; DICRFD = field# of triggering field ; DICRXR = xref# of trigger ;Out: ; DICROUT(file,field)="" (if trigger was modified) ; Q:'$D(^DD(DICRFL,DICRFD,1,DICRXR)) N DICRMOD,DICRND,DICRSTR,DICRVAL ; ;Loop through xref nodes S DICRND=0 F S DICRND=$O(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)) Q:'DICRND D . S DICRVAL=$G(^DD(DICRFL,DICRFD,1,DICRXR,DICRND)),DICRMOD=0 . F DICRSTR="D ^DICR:$O(^DD(DIH,DIG,1,0))>0","D ^DICR:$N(^DD(DIH,DIG,1,0))>0" D .. F Q:DICRVAL'[DICRSTR D ... S DICRVAL=$P(DICRVAL,DICRSTR)_"D ^DICR"_$P(DICRVAL,DICRSTR,2,999) ... S DICRMOD=1 . Q:'DICRMOD . S ^DD(DICRFL,DICRFD,1,DICRXR,DICRND)=DICRVAL . S DICROUT(DICRFL,DICRFD)="" Q ; IENS(FIL,DA) ;Build IENS N I,IENS S IENS=DA_"," F I=1:1:$$FLEV^DIKCU(FIL) S IENS=IENS_DA(I)_"," Q IENS ; HSET(FIL,FLD) ;Hard set a value in the file Q:$P($G(^DD(FIL,FLD,0)),U)="" "" ; N HSET,ND,PC,OROOT S PC=$P($G(^DD(FIL,FLD,0)),U,4) S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." "!("0 "[PC) "" S:ND'=+$P(ND,"E") ND=""""_ND_"""" ; S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA," I PC S HSET="S $P("_OROOT_ND_"),U,"_PC_")=X" E S HSET="S $E("_OROOT_ND_"),"_+$E(PC,2,999)_","_$P(PC,",",2)_")=X" Q HSET DICRW DICRW ;SFISC/XAK-SELECT A FILE ;17SEP2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. R D DT S D=8101,DIC(0)="QEI",DIA=$G(^DISV(DUZ,"^DIC(")) ;**CCO/NI 'OUTPUT FROM WHAT FILE' D R1,DIC K DIAC,DIFILE,DIC("S") Q:$D(DTOUT) G R:'$T,AU:+Y=1.1,A:+Y=.6 R2 I DUZ(0)'="@" S DICS="I 1 Q:'$D(^(8)) F DW=1:1:$L(^(8)) I DUZ(0)[$E(^(8),DW) Q" K DIA Q ; AU S D=8105,DIC(0)="QEI" S:'$D(DIC("S")) DIC("S")="I $D(DDA)!$D(^DIA(+Y,0))" S:DIA ^DISV(DUZ,"^DIC(")=DIA D DIC Q:'$D(DIC) G AU:Y<0 S DIA=+Y,Y="1.1^"_$P(Y,U,2)_" AUDIT",DIC="^DIA(DIA," Q A S:'$D(DIC("S")) DIC("S")="S DIFILE=Y,DIAC=""DD"" D ^DIAC I %",DDA="" D AU Q:'$D(DIC) S %=$P(^DIC(DIA,0),U),Y=DIA D SUB I DIA'>0!$D(DTOUT)!$D(DUOUT) K DIC Q I '$D(^DDA(DIA,0)) W !," No DD AUDIT entries!" K DIC Q S Y=".6^"_$P(Y,U,2)_"DD AUDIT",DIC="^DDA(DIA," Q SUB I $D(DIT) S L=L+1,DFL(L)=$O(^DD(+Y,0,"NM","")),(DFF,DFF(L))=+Y,Y=-1 S DIC="^DD("_Y_"," Q:$O(^DD(Y,"SB",0))'>0 Q:$D(DIT) S DIC(0)="AEQIZ",DIC("A")="Select "_%_" SUB-FILE: " S DIC("S")="I $P(^(0),U,2)" D ^DIC Q:Y<0!$D(DTOUT) S Y=+$P(Y(0),U,2) S DIA=Y,%=$P($P(^DD(DIA,0),U)," SUB-FIELD") I $D(DIT) S X=$P($P(Y(0),U,4),";",1),DSUB(L)=$S(X:X,1:""""_X_"""")_"," G SUB ; R1 S DIC("S")="S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %" Q ; ; ; DT ; I $D(IO)#2,$D(IO(0))#2,IO=IO(0),IO="" E W:'$G(DIQUIET) ! DTNOLF ; DT entry point without doing a line feed. S:$D(DUZ)#2-1 DUZ=0 S:$D(DUZ(0))#2-1 DUZ(0)="" S X=DUZ(0)="@" D 1 I '$D(DTIME) S DTIME=300 I '$D(DILOCKTM) S DILOCKTM=+$G(^DD("DILOCKTM"),1) K %DT,DT S:$D(IO(0))[0 IO(0)=$I D NOW^%DTC S DT=X,U="^" K DIK,DIC,%I,DICS,%,%H Q ;**KILL VARIABLES ; ; ; 0 S X=0 1 D:'$D(DISYS) OS^DII Q W ; D DT S D=$S('$D(DDS1):8100,1:DDS1),DIC(0)=$E("L",$D(DLAYGO)>0)_"EQI" ;**CCO/NI 'INPUT TO' D W1,DIC Q:$T!($D(DTOUT)) G W:'$P(Y,U,3) K DIC Q W1 S DIC("S")="I Y>.19,Y-1,Y-1.1,Y-.6,Y-.403,Y-.404,Y-.31 S DIFILE=+Y,DIAC=""WR"" D ^DIAC I %" Q DIC W ! S:D D=$$EZBLD^DIALOG(D) S U="^",DIC="^DIC(" ;**CCO/NI GET THE DIALOG TEXT I DUZ(0)'="@",DIC(0)'["L",$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) S DIC=$S($D(^VA(200,"AFOF")):"^VA(200,",1:DIC_"3,")_"DUZ,""FOF""," I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_Y_",0)")) X:$D(DIC("S")) DIC("S") I S Y=Y_U_$P(^DIC(Y,0),U),D=D_$P(Y,U,2)_"// " W D S %=$T R X:DTIME E W $C(7) S X=U,DTOUT=1,Y=-1 K DIC Q I '$D(@(DIC_"0)")) W " There are no selectable files." K DIC S Y=-1 Q S:DIC["FOF" DIC(0)=DIC(0)_"O" I X="",% G WW S DIC("W")=$P($T(WW1),";",3) D ^DIC I $D(DTOUT) K DIC Q GOT I $D(^DIC(+Y,0,"GL")) K DIC S DIC=^("GL") Q I U[X K DIC Q WW X $P($T(WW1),";",3) G GOT ;**CCO/NI SIMPLER XECUTE ; D D DT S D=8102,DIC(0)="LQEI",DIC("S")="I Y'<2 S DIFILE=+Y,DIAC=""DD"" D ^DIAC I %" ;**CCO/NI 'MODIFY WHAT FILE' D DIC S:DUZ(0)'="@" DICS="I 1 Q:'$D(^(9)) Q:^(9)=U F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q" Q:$T!($D(DTOUT)) G D:'$P(Y,U,3) K DIC Q DIAR ; D DT S D=$S($D(DIAX):8103,1:8104),DIC(0)="QEI" D R1 S DIC("S")="I Y'<2 "_DIC("S") ;**CCO/NI 'EXTRACT' or 'ARCHIVE' D DIC G R2:$D(DTOUT)!(X="^")!(X="")!(Y>0&($P($G(^DD(+Y,0,"DI")),U)'["Y")) W:$P($G(^DD(+Y,0,"DI")),U)["Y" !,$C(7),"SORRY, THIS IS ALREADY AN ARCHIVE FILE!" G DIAR Q T ; COMP/MERGE D DT S D=8106,DIC=1,DIC(0)="QEI" D W1,DIC Q:$T!($D(DTOUT)) G T ;**CCO/NI 'COMPARE' ; WW1 ;;W:$X>53 !?9 I Y-1.1,Y-.6,$D(^DIC(+Y,0,"GL")),^("GL")'["[",$D(@(^("GL")_"0)")) S %=+$P(^(0),U,4) W ?40,$$EZBLD^DIALOG(%=1+8300,%) ;**CCO/NI NUMBER OF ENTRIES DICRW1 DICRW1 ;SFISC/XAK-SELECT A FILE ;11:06 AM 12 Oct 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. L ;LIST DD'S S DIB(1)=0 S D=8101.1 D C2 G C4:U[X&(Y<0),L:Y<0 ;**CCO/NI 'START WITH WHAT FILE' C3 S D=8101.2 D C2 G C3:Y<0&(X'[U) ;**CCO/NI 'GO TO WHAT FILE' ERR I Y GO TO C4 I X[U!'$D(DIC) K DIC Q S X=DIB(1),DIB(1)=+Y,Y=X Q C2 D R1^DICRW D:$D(DDUC) DU S DIC(0)="QEI" D DIC^DICRW K DIAC,DIFILE Q:X[U!'$D(DIC)!(Y=-1) S:DIB(1)=0 DIB(1)=+Y Q DU S DIC("S")="I Y'<2 "_DIC("S") Q DICU DICU ;SEA/TOAD-VA FileMan: Lookup Utilities ;12APR2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; REQIDS(DIFILE,DITARGET) ; ; return REQUIRED IDENTIFIERS file attribute ; DIFILE = file#, DITARGET = target array N DIATTRBT S DIATTRBT="REQUIRED IDENTIFIERS" S @DITARGET@(DIATTRBT,.01)="" N DIFIELD S DIFIELD=0 F S DIFIELD=$O(^DD(DIFILE,0,"ID",DIFIELD)) Q:'DIFIELD D . I $D(^DD(DIFILE,"RQ",DIFIELD)) S @DITARGET@(DIATTRBT,DIFIELD)="" Q ; RID(DIFILE) ; ; return a string listing a file's required identifiers ; DIFILE = file# N DILIST S DILIST=".01" N DID S DID="" F S DID=$O(^DD(DIFILE,0,"ID",DID)) Q:'DID D . I $D(^DD(DIFILE,"RQ",DID)) S DILIST=DILIST_U_DID Q DILIST ; RECALL(DIFILE,DIEN,DIUSER) ; RECALLX ; input from DILFD ; ; ENTRY POINT--save a user's selection for use with space-bar recall ; procedure, all passed by value ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DICLERR S DICLERR=$G(DIERR) K DIERR ; 30 S DIFILE=$G(DIFILE) I +DIFILE'=DIFILE!(DIFILE<0) D ERR(202,"","","","file") Q S DIEN=$G(DIEN) I DIEN="" S DIEN="," I '$$IEN^DIDU1(DIEN) D ERR(202,"","","","IEN string") Q S DIUSER=+$G(DIUSER) ; 32 N DIOROOT,DIOUT S DIOUT=0 D I DIOUT Q . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) S DIOUT=1 Q . S DIOROOT=$$ROOT^DILFD(DIFILE,DIEN,"Q") . I DIOROOT'?1"^"1.7AN1"(".ANP,DIOROOT'?1"^%".7AN1"(".ANP D Q ;JIM SELF --ALLOW LC GLOBAL NAMES . . D ERR(402,DIFILE,"","","","","",DIOROOT) S DIOUT=1 S ^DISV(DIUSER,$E(DIOROOT,1,28))=$E(DIOROOT,29,$L(DIOROOT))_+DIEN I DICLERR'=""!$G(DIERR) D . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) Q ; FILE(DIFILE,DIDA,DIFLAGS,DIROOT) ; ; entry point -- given a root, calculate the file # and DA ; DO NOT USE UNTIL $QS & $QL AVAILABLE N DIGLOBAL I $G(DIFLAGS)'["O" S DIGLOBAL=DIROOT E S DIGLOBAL=$$CREF^DIQGU(DIROOT),DIROOT=DIGLOBAL S DIFILE=+$P($G(@DIGLOBAL@(0)),U,2),DIDA="" N DA,DIENTRY S DA=1,DIENTRY=0 ; LOOP N DICHAR,DIL,DILEAD,DIQL,DIQS,DIQSL F D Q:'DIQL . STRIP . . ; S DIQL=$QL(DIGLOBAL) Q:'DIQL . ; S DIQS=$QS(DIGLOBAL,DIQL) . N DIQSL S DIQSL=$L(DIQS)+1 I +DIQS'=DIQS S DIQSL=DIQSL+2 . S DIL=$L(DIGLOBAL),DILEAD=DIL-DIQSL . S $E(DIGLOBAL,DILEAD+1,DIL-1)="" . S DICHAR=$E(DIGLOBAL,DILEAD) . I DICHAR="," S $E(DIGLOBAL,DILEAD)="" . E I DICHAR="(" S $E(DIGLOBAL,DILEAD,DILEAD+1)="" . E S DIGLOBAL="ERROR: "_DIGLOBAL,DIQL=0 . ENTRY . I DIENTRY D . . S DIFILE(DA)=+$P($G(@DIGLOBAL@(0)),U,2) . . S DIROOT(DA)=DIGLOBAL . . S DIDA(DA)=DIQS,DA=DA+1 . S DIENTRY='DIENTRY Q ; ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3,DIROOT) ; ; ; error logging procedure ; RECALL ; N DIPE,DI F DI="FILE","IENS","FIELD",1:1:3,"ROOT" S DIPE(DI)=$G(@("DI"_DI)) D BLD^DIALOG(DIERN,.DIPE,.DIPE) S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) Q DICU1 DICU1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Get IDs & Index ;26JUNE2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; IDENTS(DIFLAGS,DIFILE,DIDS,DIWRITE,DIDENT,DINDEX) ; ; get definition of fields to return with each entry ; ID1 ; prepare to build output processor: ; S DIDS=";"_DIDS_";" I DIDS[";@;" S DIDS("@")="" E S:DIDS'[";-WID;" DIDS("WID")="" S:DIDS=";;" DIDS("FID")="" N DICRSR,DICOUNT S (DICRSR,DICOUNT)=0 I DIFLAGS["P" S DICRSR=1,DIDENT(-3)="IEN" N DIFORMAT,DIDEFALT S DIDEFALT=$S(DIFLAGS["I":"I",1:"E") ; ID1A ; for Lister: add indexed fields to DIDENT array (to build 1 nodes) ; I DIFLAGS[3,DIFLAGS'["S",DIDS'[";-IX",'$D(DIDS("@")) D . S DIDENT=-2,DIDENT(-2)=1 . D THROW^DICU11(DIFLAGS,.DIDENT,.DIDS,.DICRSR,.DICOUNT,DIDEFALT,.DINDEX) . S DIDENT=0 ; ID2 ; decide whether to auto-include the .01 in the field list ; will come out in 1 node for Lister, in "ID" nodes for Finder ; N DIUSEKEY S (DIUSEKEY,DIDENT)=0 I '$D(DIDS("@")),DIDS'[";-.01;",DIFLAGS'["S" D . I DIFLAGS[4 S DIUSEKEY="1F" Q . I DIDS[";.01;"!(DIDS[";.01E") Q . S DIUSEKEY=1 N DISUB F DISUB=1:1:DINDEX("#") D Q:'DIUSEKEY . . Q:$G(DINDEX(DISUB,"FIELD"))'=.01 ;**GFT . . S DIUSEKEY=DINDEX(DISUB,"FILE")'=DIFILE . Q I DIUSEKEY S DIDENT(-2)=1,DIDENT=.01 N DICODE,DIDEF,DIEFROM,DIETO,DINODE,DIPIECE,DISTORE,DITYPE,DIFRMAT2 N DILENGTH,DIOUTI S DILENGTH=$L(DIDS,";"),DIOUTI=0 ; ID3 ; Process auto-included .01 field (if included) on first pass, ; Start loop to process each field from DIFIELDS parameter ; and Identifiers. ; F D Q:$G(DIERR)!DIOUTI . S DIFORMAT="" . I DIUSEKEY D Q . . D BLD S DIUSEKEY=$S(DIUSEKEY="1F":"F",1:0) . . S:DIDENT=-2 DIDENT=.01 Q . D Q:'DIDENT . . S DIUSEKEY=0 . . ; Find next Identifier . . I $D(DIDS("FID")) D Q . . . S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT)) . . . I 'DIDENT K DIFRMAT2 . . . I DIDENT="" S:DIDS=";;" DIOUTI=1 K DIDS("FID") . . ID4 . . ; Find next field in DIFIELDS input parameter. . . . . S DICOUNT=DICOUNT+1 . . S DIDENT=$P(DIDS,";",DICOUNT) . . I DIDENT="",DICOUNT'1 S DIEXP="DIVAL" Q . . Q:'$D(DINDEX("ROOTCNG",1)) . . S DIEXP="$G(@DINDEX(1,""ROOT"")@(DINDEX(1)))" Q . I DIFORMAT="E",$G(DINDEX(DISUB,"GETEXT")) D . . I DISUB>1,DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") S DIEXP="DINDEX(DISUB,""EXT"")" Q . . I DINDEX(DISUB,"GETEXT")=3 S DIEXP="$$TRANOUT(DISUB,"_DIEXP_")" Q . . S:DINDEX(DISUB,"GETEXT")=2 DIEXP="DIVAL" . . S DIEXP=$$FORMAT(DIDENT,DIEXP,0,DIFORMAT,DIDEFALT,DIFLAGS) . . I DINDEX="B" S DIEXP="$S('$D(DIMNEM):"_DIEXP_",1:DINDEX(DISUB))" . . Q . I $G(DICF2) S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP Q . I DIFLAGS["P" S DICRSR=DICRSR+1 . S DIDENT(DICRSR,DISUB0,DISUB,DIFORMAT)=DIEXP . S DIMAP="IX("_DISUB_")" S:DIFORMAT="I" DIMAP=DIMAP_"I" . I DIFLAGS["P" S $P(DIDENT(-3),U,DICRSR)=DIMAP Q . I DIDENT'=-2 S DIDENT(-3,0,DISUB,DIMAP)="" Q ; GETFORM(DIDENT,DIFORMAT,DIDS,DICOUNT) ; ; Strip E or I off specifier and set into DIFORMAT N DILENGTH S DILENGTH=$L(DIDENT) S DIFORMAT=$E(DIDENT,DILENGTH) I $TR(DIFORMAT,"EI")="" D . N DIFIRST S DIFIRST=$E(DIDENT,DILENGTH-1) I $TR(DIFIRST,"EI")="" D Q . . S $E(DIDENT,DILENGTH-1)="",$P(DIDS,";",DICOUNT)=DIDENT . . S DIFORMAT=DIFIRST,DICOUNT=DICOUNT-1 . . S $E(DIDENT,DILENGTH-1)="" . S $E(DIDENT,DILENGTH)="" E S DIFORMAT="" Q ; FORMAT(DIFIELD,DICODE,DIUSEKEY,DIFORMAT,DIDEFALT,DIFLAGS) ; ; Format fetch code to return either internal or external N DIFILE S DIFILE="DIFILE" I DIFIELD'>0 S DIFILE="DINDEX(DISUB,""FILE"")",DIFIELD="DINDEX(DISUB,""FIELD"")" I DIFORMAT="E" D . N F S F="""""" I DIFLAGS["h" S F="""h""" . S DICODE="$$EXTERNAL^DIDU("_DIFILE_","_DIFIELD_","_F_","_DICODE_")" Q DICODE ; WRITEID(DIFILE,DIDENT,DICRSR) ; ; WRITE Identifiers Loop: add WRITE identifiers to output processor: ; for WRITE IDs we save the code as is ; N DICODE S DIDENT=$O(^DD(DIFILE,0,"ID"," "),-1),DIDENT=$O(^(DIDENT)) F Q:DIDENT="" D S DIDENT=$O(^DD(DIFILE,0,"ID",DIDENT)) . S DICODE=$G(^DD(DIFILE,0,"ID",DIDENT)) Q:DICODE="" . I DIFLAGS["P" S DICRSR=DICRSR+1 . S DIDENT(DICRSR,DIDENT,0)="N DIMSG "_DICODE . S:DIFLAGS["P" $P(DIDENT(-3),U,DICRSR)="WID("_DIDENT_")" Q Q ; DICU2 DICU2 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup Tools, Return IDs ;28APR2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; IDS(DIFILE,DIEN,DIFLAGS,DINDEX,DICOUNT,DIDENT,DILIST,DI0NODE) ; ; ; ENTRY POINT--add an entry's identifiers to output ; I1 ; setup 0-node and ID array interface, and output IEN ; I DIFLAGS["h" N F,N,I M F=DIFILE S N=$G(DI0NODE),I=+$G(DIEN) N DIFILE,DI0NODE,DIEN M DIFILE=F S DIEN=I S:N]"" DI0NODE=N K F,N,I I '$D(DI0NODE) S DI0NODE=$G(@DIFILE(DIFILE)@(+DIEN,0)) N DID,DIDVAL I DIFLAGS["P" N DINODE S DINODE=+DIEN E S @DILIST@(2,DICOUNT)=+DIEN ; I1A ; output primary value (index for Lister, .01 for Finder) ; I DIFLAGS'["P",$D(DIDENT(-2)) D . N DIOUT S DIOUT=$NA(@DILIST@(1,DICOUNT)) . I DIFLAGS[3 N DISUB D Q . . F DISUB=0:0 S DISUB=$O(DIDENT(0,-2,DISUB)) Q:'DISUB D . . . I DINDEX("#")'>1 D SET(0,-2,DISUB,DIOUT,.DINDEX,.DIFILE) Q . . . N I S I=$NA(@DIOUT@(DISUB)) D SET(0,-2,DISUB,I,.DINDEX,.DIFILE) . I $D(DIDENT(0,-2,.01)) D SET(0,-2,.01,DIOUT,"",.DIFILE) . Q ; I2 ; start loop: loop through output values ; I DIFLAGS["P" N DILENGTH S DILENGTH=$L(DINODE) N DICODE,DICRSR,DIOUT,DISUB S DICRSR=-1 F S DICRSR=$O(DIDENT(DICRSR)) Q:DICRSR=""!($G(DIERR)) S DID="" F S DID=$O(DIDENT(DICRSR,DID)) Q:DID=""!($G(DIERR)) S DISUB="" F D Q:DISUB=""!$G(DIERR) . I DIFLAGS'["P",DID=-2 Q . S DISUB=$O(DIDENT(DICRSR,DID,DISUB)) Q:DISUB="" . K DIDVAL I20 . ; output indexed field if "IX" was in FIELDS parameter . I DID=0 D Q . . D SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE) . . I DIFLAGS["P" D ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST) Q . . M @DILIST@("ID",DICOUNT,0,DISUB)=DIDVAL Q . I3 . ; output field . ; distinguish between computed and value fields . . I DID D Q:$G(DIERR) . . ; process fields that are not computed. . . I DIFLAGS["E" N DIERR ;ERROR IN DATA WILL NOT STOP THE LISTING --GFT . . I $G(DIDENT(DICRSR,DID,0,"TYPE"))'="C" D . . . D SET(DICRSR,DID,DISUB,"DIDVAL",.DINDEX,.DIFILE) Q . . I4 . . ; computed fields . . E D . . . N %,%H,%T,A,B,C,D,DFN,I,X,X1,X2,Y,Z,Z0,Z1 . . . N DA D DA^DILF(DIEN,.DA) ;M DA=DIEN S DA=$P(DIEN,",") PATCH 165 MAY,2011 . . . N DIARG S DIARG="D0" . . . N DIMAX S DIMAX=+$O(DA(""),-1) . . . N DIDVAR F DIDVAR=1:1:DIMAX S DIARG=DIARG_",D"_DIDVAR . . . N @DIARG F DIDVAR=0:1:DIMAX-1 S @("D"_DIDVAR)=DA(DIMAX-DIDVAR) . . . S @("D"_DIMAX)=DA . . . X DIDENT(DICRSR,DID,0) S DIDVAL=$G(X) COMPDT . . .I $P($G(^DD(DIFILE,DID,0)),U,2)["D" N Y S Y=DIDVAL X:Y ^DD("DD") S DIDVAL=Y . . I5 . . ; set field into array or pack node . . . . I DIFLAGS'["P" M @DILIST@("ID",DICOUNT,DID)=DIDVAL . . E D ADD(.DIFLAGS,.DINODE,.DILENGTH,DIDVAL,DIEN,DILIST) . I6 . ; output display-only identifier . . E D . . N %,D,DIC,X,Y,Y1 . . S D=DINDEX . . S DIC=DIFILE(DIFILE,"O") . . S DIC(0)=$TR(DIFLAGS,"2^fglpqtuv104") . . M Y=DIEN S Y=$P(DIEN,",") . . S Y1=$G(@DIFILE(DIFILE)@(+DIEN,0)),Y1=DIEN . . I7 . . ; execute the identifier's code . . . . N DIX S DIX=DIDENT(DICRSR,DID,0) . . X DIX . . I $G(DIERR) D Q . . . N DICONTXT I DID="ZZZ ID" S DICONTXT="Identifier parameter" . . . E S DICONTXT="MUMPS Identifier" . . . D ERR^DICF4(120,DIFILE,DIEN,"",DICONTXT) . . I8 . . ; set output from identifier into output array or pack node . . N DIGFT S DIGFT=$NA(@DILIST@("ID","WRITE",DICOUNT)) I DID?1"C"1.2N S DIGFT=$NA(@DILIST@("ID",DICOUNT,DID)) ;**GFT . . N DI,DILINE,DIEND S DI="" S:DIFLAGS'["P" DIEND=$O(@DIGFT@("z"),-1) . . I $O(^TMP("DIMSG",$J,""))="" S ^TMP("DIMSG",$J,1)="" . . F D Q:DI=""!$G(DIERR) . . . S DI=$O(^TMP("DIMSG",$J,DI)) Q:DI="" . . . S DILINE=$G(^TMP("DIMSG",$J,DI)) . . . I DIFLAGS["P" D ADD(.DIFLAGS,.DINODE,.DILENGTH,DILINE,DIEN,DILIST,DI) Q . . . S DIEND=DIEND+1,@DIGFT@(DIEND)=DILINE . . . Q . . K DIMSG,^TMP("DIMSG",$J) ; I9 ; for packed output, set pack node into output array ; I '$G(DIERR),DIFLAGS["P" S @DILIST@(DICOUNT,0)=DINODE Q ; ; SET(DICRSR,DIFID,DISUB,DIOUT,DINDEX,DIFILE) ; Move data to DIOUT. N F1,F2 M F1=DIFILE N DIFILE M DIFILE=F1 S F1=$O(DIDENT(DICRSR,DIFID,DISUB,"")),F2=$O(DIDENT(DICRSR,DIFID,DISUB,F1)) F F1=F1,F2 D:F1]"" . I DIDENT(DICRSR,DIFID,DISUB,F1)["DIVAL" N DIVAL S @DINDEX(DISUB,"GET") . N X S @("X="_DIDENT(DICRSR,DIFID,DISUB,F1)) . I $G(DIERR),DIFLAGS["h" K DIERR,^TMP("DIERR",$J) S X=DINDEX(DISUB) . I X["""" S X=$$CONVQQ^DILIBF(X) . I +$P(X,"E")'=X S X=""""_X_"""" . I F2="" S @(DIOUT_"="_X) Q . S O=$NA(@DIOUT@(F1)),@(O_"="_X) Q Q ; TRANOUT(DISUB,DIVL) ; Execute TRANSFORM FOR DISPLAY on index value N X S X=DIVL N DICODE S DICODE=$G(DINDEX(DISUB,"TRANOUT")) I DICODE]"" X DICODE Q X ; ADD(DIFLAGS,DINODE,DILENGTH,DINEW,DIEN,DILIST,DILCNT) ; ; ; for Packed output, add DINEW to DINODE, erroring if overflow ; xform if it contains ^ ; A1 N DINEWLEN,DELIM S DINEWLEN=$L(DINEW),DELIM=$S($G(DILCNT)'>1:"^",1:"~") S DILENGTH=DILENGTH+1+DINEWLEN I DILENGTH>$G(^DD("STRING_LIMIT"),255) D ERR^DICF4(206,"","","",+DIEN) Q ;**HERE IS WHERE A PACKED STRING WAS FORCED TO BE ONLY 255 CHARACTERS LONG I DIFLAGS'[2,DINEW[U S DIFLAGS="2^"_DIFLAGS D ENCODE(DILIST,.DINODE) I DIFLAGS[2,DINEW[U!(DINEW["&") S DINEW=$$HTML^DILF(DINEW) Q:$G(DIERR) S DINODE=DINODE_DELIM_DINEW Q ; ENCODE(DILIST,DINODE) ; ; ; ADD: HTML encode records already output (we found an embedded ^) ; procedure: loop through list encoding &s ; E1 N DILINE,DIRULE S DIRULE(1,"&")="&" N DIREC S DIREC=0 F S DIREC=$O(@DILIST@(DIREC)) Q:'DIREC D . S DILINE=@DILIST@(DIREC,0) Q:DILINE'["&" . S @DILIST@(DIREC,0)=$$TRANSL8^DILF(DILINE,.DIRULE) I DINODE["&" S DINODE=$$TRANSL8^DILF(DINODE,.DIRULE) Q ; DICUF DICUF ;SEA/TOAD,SF/TKW-FileMan: Lookup Tools, Files ;12APR2008 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. ; ; FILE(DIFILE,DIFIEN,DIFLAGS) ; ; retrieve and calculate info about indexed file ; F1 ; set and check source file number. ; S DIFILE=+$G(DIFILE) I 'DIFILE D ERR(202,"","","","","file") Q ; F2 ; get the file's .01 definition; quit & error if bad ; N DINODE S DINODE=$G(^DD(DIFILE,.01,0)) I DINODE="" D ERR($S('$D(^DD(DIFILE)):401,1:406),DIFILE) Q I $P(DINODE,U,2)["W" D ERR(407,DIFILE) Q ; F3 ; set and check the Lister's IENS parameter ; S DIFIEN=$G(DIFIEN) I DIFIEN="" S DIFIEN="," I '$$IEN^DIDU1(DIFIEN) D Q . I '$$IEN^DIDU1(DIFIEN_",") D ERR(202,"","","","","IENS") Q . E D ERR(304,"",DIFIEN) Q I $P(DIFIEN,",")'="" D ERR(306,"",DIFIEN) Q ; F4 ; calculate the source file's global root (open & closed) ; S DIFILE(DIFILE)=$$ROOT^DIQGU(DIFILE,DIFIEN,1,1) Q:$G(DIERR) I DIFILE(DIFILE)'?1"^"1A.ANP,DIFILE(DIFILE)'?1"^%".ANP D Q ;JIM SELF --ALLOW LC GLOBAL NAMES . D ERR(402,DIFILE,DIFIEN,"",DIFILE(DIFILE)) S DIFILE(DIFILE,"O")=$$OREF^DIQGU(DIFILE(DIFILE)) Q ; SCREEN(DIFLAGS,DIFILE,DISCREEN) ; ; Set user defined and whole file screen variables. ; I $G(DISCREEN("S"))="" S DISCREEN("S")=$G(DISCREEN) I $G(DISCREEN("V"))]"",$G(DISCREEN("V",1))']"" S DISCREEN("V",1)=DISCREEN("V") S DISCREEN("F")="" I DIFLAGS'["U" D . Q:$P($G(@DIFILE(DIFILE)@(0)),U,2)'["s" . S DISCREEN("F")=$G(^DD(DIFILE,0,"SCR")) . Q Q ; VPDATA(DINDEX,DISCREEN) ; Add variable pointer info to DINDEX array for executing DIC("V") type screen N DISUB,F,I,F1,F2,G,Y F DISUB=1:1:DINDEX("#") I $G(DISCREEN("V",DISUB))]"" D . S F1=DINDEX(DISUB,"FILE"),F2=DINDEX(DISUB,"FIELD") Q:'F1!('F2) . F F=0:0 S F=$O(^DD(F1,F2,"V","B",F)) Q:'F D . . S I=$O(^DD(F1,F2,"V","B",F,0)) Q:'I . . S Y(0)=$G(^DD(F1,F2,"V",I,0)) Q:Y(0)="" . . X DISCREEN("V",DISUB) Q:'$T . . S G=$G(^DIC(F,0,"GL")) Q:G="" . . S DINDEX(DISUB,"VP",G)="" Q . Q Q ; ERR(DIERN,DIFILE,DIIENS,DIFIELD,DIROOT,DI1,DI2,DI3) ; ; ; error logging procedure ; E1 N DIPE,P N DI F DI="FILE","IENS","FIELD","ROOT",1:1:3 D . S P=$G(@("DI"_DI)) Q:P="" . S DIPE(DI)=P D BLD^DIALOG(DIERN,.DIPE,.DIPE) Q ; DICUIX DICUIX ;SEA/TOAD,SF/TKW-FileMan: Lookup Tools, Indexes ;8APR2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; INDEX(DIFILE,DIFLAGS,DINDEX,DIFROM,DIPART,DINUMBER,DISCREEN,DILIST,DIOUT) ; ; ; build DINDEX array data for index ; I1 ; try to find Index in Index file ; N DICODE,DIGET,DILENGTH,DINODE,DISUB,DITEMP,DITEMP2,DITO,DITOIEN,DITYPE,DIWAY,DIXIEN S DINDEX("FLIST")="",DINDEX("AT")=1,DIFROM("IEN")=+$G(DIFROM("IEN")),DIXIEN="",DIGET=1 S:DINDEX'="#" DIXIEN=$O(^DD("IX","BB",DIFILE,DINDEX,"")) I 'DIXIEN D XREF(.DIFILE,.DIFLAGS,.DINDEX,.DIPART,.DIFROM) Q ; I2 ; in Index file, build list of subscript data ; S DINODE=^DD("IX",DIXIEN,0) S DINDEX("IXTYPE")=$P(DINODE,U,4) S:DIFLAGS["4" DINDEX("IXFILE")=DIXIEN S DINDEX("#")=0 S DISUB=$O(^DD("IX",DIXIEN,11.1,"AC","Z"),-1) I $G(DIFROM(DISUB+1)) M DIFROM("IEN")=DIFROM(DISUB+1) S (DISUB,DIOUT)=0 N S F D Q:'DISUB Q:DIOUT . S DISUB=$O(^DD("IX",DIXIEN,11.1,"AC",DISUB)) Q:'DISUB S S=$O(^(DISUB,0)) Q:'S . S DINDEX("#")=DISUB,DIGET=1 . S DINODE=$G(^DD("IX",DIXIEN,11.1,S,0)) . I DIFLAGS["l" N X D S DINDEX(DISUB,"PROMPT")=X . . S X=$P(DINODE,U,8) Q:X]"" EGP . . I $P(DINODE,U,3),$P(DINODE,U,4) S X=$$LABEL^DIALOGZ($P(DINODE,U,3),$P(DINODE,U,4)) ;**CCO/NI . . Q . S DINDEX(DISUB,"FIELD")=$P(DINODE,U,4) . S DINDEX(DISUB,"FILE")=$P(DINODE,U,3) . I $P(DINODE,U,2)["C"!(DINDEX(DISUB,"FILE")="") S DINDEX(DISUB,"FIELD")="" . I DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD") D . . I $G(^DD("IX",DIXIEN,11.1,S,4))]"" S DINDEX(DISUB,"TRANCODE")=^(4) . . I $G(^DD("IX",DIXIEN,11.1,S,2))]"" D . . . I $G(^DD("IX",DIXIEN,11.1,S,3))="" S DIGET=0 Q . . . S DINDEX(DISUB,"TRANOUT")=^DD("IX",DIXIEN,11.1,S,3),DIGET=3 Q . . I "KSMU"[DINDEX("IXTYPE") S DIGET=2 . . Q . S DILENGTH=$P(DINODE,U,5) I 'DILENGTH S DILENGTH=30 ;!(DILENGTH>100) ;GETS THE LENGTH FROM THE DEFINITION OF THE INDEX . S DIWAY=$S($P(DINODE,U,7)="B":-1,1:1) . D COMMON1^DICUIX2 . Q I DIOUT S @DILIST@(0)="0^"_DINUMBER_"^0" D OUT^DICL Q D:DIFLAGS'["q" COMMON2^DICUIX2 S DINDEX("FLIST")=DINDEX("FLIST")_"^" I DIFLAGS'["l",DIFLAGS'["h" Q N F,F1,F2,I S F=DINDEX("FLIST") F I=1:1:DINDEX("#") I $G(DINDEX(I,"GETEXT"))=0 S F1=$G(DINDEX(I,"FILE")),F2=$G(DINDEX(I,"FIELD")) I F1=DIFILEI,F2 D . S F1=$F(F,("^"_F2_"^")) Q:'F1 S F1=F1-2 . S $E(F,(F1-$L(F2)),F1)="" Q S DINDEX("FLISTD")=F Q ; XREF(DIFILE,DIFLAGS,DINDEX,DIPART,DIFROM) ; ; Index is in "IX" nodes ; X1 ; Set DINDEX for search through upright file ; I DINDEX="#" D Q . S DINDEX("#")=0,DINDEX(1,"FILE")=DIFILE,DINDEX(1,"ROOT")=DIFILE(DIFILE),DINDEX(1,"TYPE")="N" . N X S X=$S($G(DIFROM(1)):DIFROM(1),DIPART(1):DIPART(1),1:$G(DIFROM("IEN"))) . S (DIFROM,DIFROM(1))=X S:X DIFROM("IEN")=X . I DIFLAGS["l"!(DIFLAGS["h") S DINDEX("FLISTD")="" . D:DIFLAGS'["q" COMMON2^DICUIX2 Q S DINDEX("#")=1,DINDEX("IXTYPE")="R" S DINDEX(1,"FILE")=$O(^DD(DIFILE,0,"IX",DINDEX,"")) ; X2 ; Build DINDEX for index in IX nodes. ; S DIOUT=0,DILENGTH=30 S DINDEX(1,"FIELD")="" I DINDEX(1,"FILE") S DINDEX(1,"FIELD")=$O(^DD(DIFILE,0,"IX",DINDEX,DINDEX(1,"FILE"),"")) I DINDEX(1,"FIELD")="",DINDEX="B" D . S DINDEX(1,"FILE")=DIFILE . S DINDEX(1,"FIELD")=.01 Q I DIFLAGS[3,DINDEX="B",'$D(@DIFILE(DIFILE)@("B")) D . D TMPB^DICUIX1(.DITEMP,DIFILE) . S DIFILE(DIFILE,"NO B")=DITEMP Q I DIFLAGS["l" S DINDEX(1,"PROMPT")="" I DINDEX(1,"FILE"),DINDEX(1,"FIELD") D I DINDEX("IXTYPE")="*" K DINDEX S DINDEX="" Q EGP2 . I DIFLAGS["l" S DINDEX(1,"PROMPT")=$$LABEL^DIALOGZ(DINDEX(1,"FILE"),DINDEX(1,"FIELD")) ;**CCO/NI FIELD LABEL . N I,X,Y . F I=0:0 S I=$O(^DD(DINDEX(1,"FILE"),DINDEX(1,"FIELD"),1,I)) Q:'I S X=$G(^(I,0)) I $P(X,U,2)=DINDEX S Y=$G(^(1)) D Q . . S X=$E($P(X,U,3),1,2) . . S DINDEX("IXTYPE")=$S(X="":"R",X="KW":"K",X="SO":"S",(X="TR")!(X="BU"):"*",X]"":X,1:"R") . . I "KSMU"[DINDEX("IXTYPE") S DIGET=2 . . S DILENGTH=+$P(Y,"$E(X,1,",2) . . S:'DILENGTH DILENGTH=30 Q ;!(DILENGTH>100) . Q I $G(DIFROM(2)) S DIFROM("IEN")=DIFROM(2) S DISUB=1,DIWAY=1,DIOUT=0 N I,X,Y D COMMON1^DICUIX2 I DIOUT S @DILIST@(0)="0^"_DINUMBER_"^0" D OUT^DICL Q D:DIFLAGS'["q" COMMON2^DICUIX2 S DINDEX("FLIST")=DINDEX("FLIST")_"^" I DIFLAGS["l"!(DIFLAGS["h") D . I DIGET=2 S DINDEX("FLISTD")="^^" Q . S DINDEX("FLISTD")=DINDEX("FLIST") Q S DITEMP=$G(DIFILE(DIFILE,"NO B")) I DITEMP]"" D BLDB^DICUIX1(DIFILE(DIFILE),DITEMP) Q ; ; DICUIX1 DICUIX1 ;SF/TOAD/TKW-FileMan: Lookup Tools, Indexes (called by DICUIX) ;4JUL2008 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. ; GET(DITOP,DIFILE,DIFIELD,DIDEF,DICODE) ; ; get the definition and fetch code for a field ; G1 ; handle .001 fields, fetch field definition, & handle undefineds ; I DIFIELD=.001 S DICODE="DIEN",DIDEF="" Q S DIDEF=$G(^DD(DIFILE,DIFIELD,0)),DICODE="" I DIDEF="" D ERR^DICU1(501,DIFILE,"","",DIFIELD) Q ; G2 ; piece out the fields data type, & handle multiples and WPs ; N DITYPE S DITYPE=$P(DIDEF,U,2) I DITYPE D Q . I $P($G(^DD(+DITYPE,.01,0)),U,2)["W" S DITYPE="Word-processing" . E S DITYPE="Multiple" . D ERR^DICU1(520,DIFILE,"",DIFIELD,DITYPE) ; G3 ; handle computed fields ; I DITYPE["C" D Q .I DITYPE["m" D ERR^DICU1(520,DIFILE,"",DIFIELD,"Multiple Computed") Q ;**GFT . S DICODE=$P(DIDEF,U,5,9999) . S DIDEF=$P(DIDEF,U,1,4) ; G30 ; Handle whole file x-refs I DIFILE'=DITOP S DICODE="DINDEX(DISUB)" Q G4 ; get field's storage location, handle ?, build node fetch code ; N DISTORE S DISTORE=$P(DIDEF,U,4) N DINODE S DINODE=$P(DISTORE,";") N DIPIECE S DIPIECE=$P(DISTORE,";",2) I DINODE="",$P(DIPIECE,"E")'="",'DIPIECE S (DICODE,DIDEF)="" Q I DINODE=0,DIFILE=DITOP S DINODE="DI0NODE" E S DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))" ; G5 ; build field fetch code (piece or extract) & quit ; I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")" E D . N DIEFROM S DIEFROM=$P($E(DIPIECE,2,9999),",") . N DIETO S DIETO=$P(DIPIECE,",",2) . S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")" Q ; FIELD(DIFILE,DIFIELD,DINDEX) ; ; ; return code to fetch field value prior to screen execution ; F1 ; handle .01 & computeds, build node expression ; I DIFIELD=.01 Q "DINDEX(1)" N DISTORE S DISTORE=$P(DINDEX(1,"DEF"),U,4) N DINODE S DINODE=$P(DISTORE,";") N DIPIECE S DIPIECE=$P(DISTORE,";",2) I 'DINODE,$P(DIPIECE,"E")'="",'DIPIECE Q "X" I DINODE=0 S DINODE="DI0NODE" E S DINODE="$G(@DIFILE(DIFILE)@(+DIEN,"""_DINODE_"""))" ; F2 ; build fetch code from node expression ; N DICODE I DIPIECE S DICODE="$P("_DINODE_",U,"_DIPIECE_")" E D . N DIEFROM S DIEFROM=$P($E(DIPIECE,2,9999),",") . N DIETO S DIETO=$P(DIPIECE,",",2) . S DICODE="$E("_DINODE_","_DIEFROM_","_DIETO_")" Q DICODE ; GETTMP(DITEMP,DISUB) ; Return name of unique entry in ^TMP global. I $G(DISUB(1))']"" S DISUB(1)=$G(DISUB) N I S DITEMP="^TMP(" F I=0:0 S I=$O(DISUB(I)) Q:'I I DISUB(I)]"" D . N X S X=DISUB(I) I +$P(X,"E")'=X S X=""""_X_"""" . S DITEMP=DITEMP_X_"," N DIKJ,J F DIKJ=$J:.01 S J=DITEMP_DIKJ_")" I '$D(@J) L +@J Q S @J="",DITEMP=J L -@J Q ; TMPB(DITEMP,DIFILE) ; Set place for temporary "B" index on file N DISUB S DISUB(1)="DICLB",DISUB(2)=DIFILE D GETTMP(.DITEMP,.DISUB) S DITEMP=$E(DITEMP,1,($L(DITEMP)-1)) Q ; BLDB(DIROOT,DITEMP) ; Build temporary "B" index on file N DIENTRY,DIVALUE S DIENTRY=0,DITEMP=DITEMP_")" F S DIENTRY=$O(@DIROOT@(DIENTRY)) Q:'DIENTRY D . S DIVALUE=$P($G(@DIROOT@(DIENTRY,0)),U) Q:DIVALUE="" . S @DITEMP@(DIVALUE,DIENTRY)="" . Q Q ; TMPIDX(DISUB,DITEMP,DITEMP2,DINDEX) ; Set data to build temporary index on Lister call with Pointer/VP in index. S DITEMP2=DITEMP D GETTMP^DICUIX1(.DITEMP,"DICL") S DITEMP=$E(DITEMP,1,($L(DITEMP)-1)) S DINDEX("ROOTCNG",DISUB)="" Q ; CHKP(DIFILE,DINDEX,DINUMBER,DIFRPRT,DISCREEN,DICQ1) ; Check whether to build temporary index on Lister call with Pointer/VP in first subscript of index. N DIN1,DIN2,X,I,D S DIN2=0 S DIN1=+$P($G(@DIFILE(DIFILE)@(0)),U,4) N DIF,DIVPTR M DIF=DIFILE S DIVPTR=$S(DINDEX(1,"TYPE")="V":1,1:0) D FOLLOW^DICL3(.DIF,"",DINDEX(1,"NODE"),1,0,"",DINDEX(1,"FIELD"),DINDEX(1,"FILE"),DIVPTR,1,.DISCREEN) F I=1:1 S X=+$P($G(DIF("STACKEND",I)),U,2) Q:'X D . S X=$G(^DIC(X,0,"GL")) Q:X="" S X=$G(@(X_"0)")) . S DIN2=DIN2+$P(X,U,4) S D=1 D . N F1,F2 S F1=DINDEX(1,"FILE"),F2=DINDEX(1,"FIELD") . I 'DIVPTR S I=$P($G(^DD(F1,F2,0)),U,2) S:I["*" D=.5 Q . F I=0:0 S I=$O(^DD(F1,F2,"V",I)) Q:'I I $G(^(I,1))]"" S D=.5 Q . S D=D*.5 Q S DIN2=$S(DINUMBER!(DIFRPRT]""):DIN2/(40*D),1:DIN2/(20*D)) I $G(DICQ1),DIFRPRT]"" S DIN2=DIN2/2 I DIN2>DIN1,DIN1>500,'$G(DICQ1) Q 0 Q DIN2>DIN1 ; DICUIX2 DICUIX2 ;VEN/TOAD,SF/TKW - Lookup: Build Index Data ; 1/25/13 12:32pm ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; ; Contents ; ; COMMON1: Load Data-subscript Data into DINDEX ; $$BACKFROM: Return From Value for Backward Collation ; COMMON2: Load IEN-subscript Data into DINDEX ; DAT: Process FROM and PART for dates ; $$ORDERQ: Is File Like Order File: Dinumed but No B Index? ; ; COMMON1 ; Load Data-subscript Data into DINDEX ; N DIFR,DIPRT S DIFR=$G(DIFROM(DISUB)),DIPRT=$G(DIPART(DISUB)) I DINDEX(DISUB,"FILE")=DIFILE S DINDEX("FLIST")=DINDEX("FLIST")_"^"_DINDEX(DISUB,"FIELD") I DIFLAGS["q" D C3 Q S DINDEX(DISUB,"USE")=0 D . I DIFROM("IEN") S DINDEX(DISUB,"USE")=1 Q . S:$G(DIFROM(DISUB+1))]"" DINDEX(DISUB,"USE")=1 ; C1 ; 1. Decide which direction to traverse this subscript ; S DINDEX(DISUB,"WAY")=DIWAY*DINDEX("WAY") ; calculate direction I DIFLAGS[4,DIFLAGS'["l" S DINDEX(DISUB,"WAY")=1 ; override? I $G(DINDEX("WAY","REVERSE")) S DITO(DISUB)=DIFR,DIFR="" ; C2 ; 2. Adjust From & To to fit max subscript length ; I DIFLAGS[4 S DINDEX(DISUB,"LENGTH")=DILENGTH I DIFLAGS[3 D . S DIFR=$E(DIFR,1,DILENGTH) . S DIPRT=$E(DIPRT,1,DILENGTH) . I $D(DITO(DISUB)) S DITO(DISUB)=$E(DITO(DISUB),1,DILENGTH) ; C3 ; 3. Build code to extract indexed field from data ; I 'DINDEX(DISUB,"FILE")!('DINDEX(DISUB,"FIELD")) S DINODE="",DICODE="DINDEX(DISUB)" E D GET^DICUIX1(DIFILE,DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),.DINODE,.DICODE) I $G(DIERR) D . S DINODE="",DICODE="DINDEX(DISUB)" . D BLD^DIALOG(8099,DINDEX) S DINDEX(DISUB,"GET")="DIVAL="_DICODE ; C4 ; 4. Find & record subscript data-type info ; S DITYPE=$P(DINODE,U,2) N % S %="F" D S DINDEX(DISUB,"TYPE")=% . Q:DIFLAGS["Q" . I DITYPE["P" S %="P" S:$$ORDERQ(+$P(DITYPE,"P",2)) %="F",DITYPE="F" Q ;TRICK: TREAT FILE 100 POINTERS AS FREE-TEXT! . I DITYPE["D" S %="D" Q . I DITYPE["S" S %="S" Q . I DITYPE["V" S %="V" Q . I DITYPE["N" S %="N" ; Q:DIFLAGS["q" I DISUB=1 D . S DITEMP=$S($D(DIFILE(DIFILE,"NO B")):DIFILE(DIFILE,"NO B"),1:DIFILE(DIFILE,"O")_"DINDEX") . I "VP"[DINDEX(DISUB,"TYPE") D . . S DINDEX(1,"NODE")=DINODE Q:DIFLAGS[4 . . I DIFLAGS'["Q",$$CHKP^DICUIX1(.DIFILE,.DINDEX,+$G(DINUMBER),DIFR_DIPRT,.DISCREEN) D Q . . . D TMPIDX^DICUIX1(1,.DITEMP,.DITEMP2,.DINDEX) . . S DINDEX("AT")=2 ; I DISUB>1 D . I DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") S DINDEX(DISUB,"GET")="DIVAL=$G(DINDEX(DISUB,""EXT""))" . I DIFLAGS[3,"VP"[DINDEX(DISUB,"TYPE"),DIFLAGS'["Q",'$D(DINDEX("ROOTCNG")) D TMPIDX^DICUIX1(DISUB,.DITEMP,.DITEMP2,.DINDEX) Q . S DITEMP=DITEMP_"DINDEX("_(DISUB-1)_")" ; S DINDEX(DISUB,"ROOT")=DITEMP_")",DITEMP=DITEMP_"," I $D(DITEMP2) D . S:DISUB>1 DITEMP2=DITEMP2_"DIX("_(DISUB-1)_")" . S DINDEX(DISUB,"IXROOT")=DITEMP2_")",DITEMP2=DITEMP2_"," ; C5 ; 5. Set Any More? ; S DINDEX(DISUB,"MORE?")=0 I +$P(DIPRT,"E")=DIPRT,DITYPE'["D" D . ; . Q:DIFLAGS["X" ; no partial-numeric matches if require exact . N PNM S PNM=0 ; suppress PNM for pointers or variable pointers? . I "VP"[$E(DITYPE) D Q:'PNM ; at least for these cases: . . I DIFLAGS["l",DIC(0)["U" Q ; classic, untransformed lookup . . I DIFLAGS[3,DIFLAGS["Q" Q ; Lister, quick list . . I DIFLAGS[4,DIFLAGS["Q" Q ; Finder, quick lookup . . S PNM=1 ; otherwise, allow it on ptrs or vptrs . ; . I DINDEX(DISUB,"WAY")=-1 S DINDEX(DISUB,"MORE?")=1 Q . I +$P(DIFR,"E")=DIFR!(DIFR="") S DINDEX(DISUB,"MORE?")=1 ; C6 ; 6. Handle partial matches, incl. setting From ; I DIPRT]"" D . I DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") Q:DIFLAGS'["l" Q:DISUB>1 . I DITYPE["D",DIFLAGS[3 D Q . . N I S I=$S(DINDEX(DISUB,"WAY")=1:"0000000",1:9999999) . . D DAT(.DIFR,DIPRT,I,DINDEX(DISUB,"WAY"),.DIOUT) . Q:$E(DIFR,1,$L(DIPRT))=DIPRT . I DINDEX(DISUB,"WAY")=1 D Q . . I DIFR]](DIPRT_$S(+$P(DIPRT,"E")=DIPRT:" ",1:"")) S DIOUT=1 Q . . I +$P(DIPRT,"E")=DIPRT,DIPRT<0 S DIFR=$S(DIPRT[".":$P(DIPRT,".")-1,1:"") Q . . I +$P(DIPRT,"E")=DIPRT,+$P(DIFR,"E")=DIFR,DIFR>DIPRT Q . . S DINDEX(DISUB,"USE")=1 . . S DIFR=DIPRT_$S(+$P(DIPRT,"E")'=DIPRT:"",DIFR]]DIPRT:" ",1:"") . ; . I DIFR'="",DIPRT]]DIFR S DIOUT=1 Q . I +$P(DIPRT,"E")=DIPRT,DIFR?.1"-"1.N.E Q . S DINDEX(DISUB,"USE")=1 . S DIFR=$$BACKFROM(DIPRT) ; start from end of partial matches ; S DINDEX(DISUB)=$G(DIFR) I DIFR]"" S DINDEX(DISUB,"FROM")=DIFR I DIPRT]"" S DINDEX(DISUB,"PART")=DIPRT I $D(DITO(DISUB)) S DINDEX(DISUB,"TO")=DITO(DISUB) ; C7 ; 7. Handle subscripts with data-type transforms ; I $G(DIDENT(-5)) D . I $D(DINDEX(DISUB,"TRANOUT")) S DINDEX(DISUB,"GETEXT")=DIGET Q . N T S T=DITYPE I T'["D",T'["S",T'["P",T'["V",T'["O" Q . I DIFLAGS[3,"PV"[DINDEX(DISUB,"TYPE"),(DISUB>1!($D(DINDEX("ROOTCNG",1)))) D . . I DINDEX(DISUB,"FILE")'=DIFILE S DIGET=0 Q . . S DIGET=2 . S DINDEX(DISUB,"GETEXT")=DIGET ; QUIT ; end of COMMON1 ; ; BACKFROM(DIPART) ; Return From Value for Backward Collation ; ;;private;function;clean;silent;SAC compliant ; input: DIPART = the partial-match value ; output = From value for backward collation ; called by: ; COMMON1, at C6+18 ; BACKFROM^DICF1 ; calls: none ; N DIFROM S DIFROM=DIPART_"{{{{{{{{{{" ; QUIT DIFROM ; return From value ; end of $$BACKFROM ; ; COMMON2 ; Load IEN-subscript Data into DINDEX ; N DIEN S DIEN=DINDEX("#")+1 S:DINDEX'="#" DINDEX(DIEN,"ROOT")=DITEMP_"DINDEX("_(DIEN-1)_"))" I $D(DITEMP2) S DINDEX(DIEN,"IXROOT")=DITEMP2_"DIX("_(DIEN-1)_"))" I $G(DINDEX("WAY","REVERSE")),DIFROM("IEN") S DINDEX(DIEN,"TO")=DIFROM("IEN"),DIFROM("IEN")="" S DINDEX(DIEN)=DIFROM("IEN") I DINDEX(DIEN)=0,DINDEX("WAY")=-1 S DINDEX(DIEN)="" I DIFROM("IEN") S DINDEX(DIEN,"FROM")=DIFROM("IEN") S DINDEX(DIEN,"WAY")=DINDEX("WAY") ; QUIT ; end of COMMON2 ; ; DAT(DIFR,DIPRT,DIAPP,DIWAY,DIOUT) ; Process FROM and PART for dates ; N L,P,DIPART S L=$L(DIFR),P=$L(DIPRT),DIPART=DIPRT I L

0 S DIC(0)="AEQZ",DIC("A")=" Select SUB-FILE: ",DIC("S")="I $P(^(0),U,2)" D ^DIC G KL:$D(DTOUT) I Y>0 S (DFF,Y)=+$P(Y(0),U,2) G SUB G KL:X[U O K DIC S:DFF-DUB DIC("S")="I Y-5" S DIC="^DOPT(""DID"",",DIC(0)="AEQ",DIC("B")=1 D ^DIC G KL:Y<0 O1 K DIC S DIC="^DD(DFF," I +Y=3 D D EN^DIP G KL .I $D(^DIC(DFF)) S DIB(1)=$O(^DD($O(^DIC(DIB(1)))),-1) .S DIS(0)="I $D(^DD(DFF,D0,0))",DIOEND="G L^DIDC" .S DIOBEG="S L=0 I $G(DQI),$D(^UTILITY($J,2)) S ^(1.5)=""W $O(^DD(DIB,0,""""NM"""",0)),"""" """" W:'$D(^DIC(DIB)) """"SUB-"""" W """"FILE """""",^(2)=""X ^(1.5) ""_^(2)" I +Y=4,'$D(DIFORMAT) D MOD^DID2 G KL:X[U S L=0,FLDS="",BY="@.001" I +Y=5 S (FR,TO)=.01,DHIT="S F(1)=DUB",DHD="W """" D H1^DIDG",DIOEND="D T^DID" G G I +Y=8 D G KL:DIDTYP="",KL:DIDFLD=-1,G . S DIDTYP=$$ASKTYP Q:DIDTYP="" . S DIDFLD=$$ASKFLD(DFF) Q:DIDFLD=-1 . S (FR,TO)=.01,DHIT="S F(1)=DFF" . S DHD="W """" D IXHEAD1^DID" . S DIOEND="D IX^DID" I +Y=9 S (FR,TO)=.01,DHIT="S F(1)=DFF",DHD="W """" D KEYHEAD1^DID",DIOEND="D KEY^DID" G G S DHIT="D ^DID1",DHD="W """" D ^DIDH",(FR,TO)="",DIOEND="D END^DID" I +Y=6 S DHIT="D ^DIDG",DIOEND="D END^DIDG" I +Y=2 S DHIT="D ^DIDX",DIDX=0,%=2 I '$D(DIFORMAT) D AH^DIDX G KL:%<1 I +Y=7 S DHIT="S (X1,X2)=DFF D ^DIDC",DHD="@" S DIOEND="D IOF^DID" I "^1^2^4^"[(U_+Y_U),'$D(DIGR) D ASKRANGE(DFF,BY,.FR,.TO) G:FR=-1 KL S DIDRANGE=FR]"" G Q:DIB=0 S DIOEND(1)=DIOEND,DIOEND="D LOOP^DID" D EN1^DIP G KL LOOP I $D(Y),Y=U Q X DIOEND(1) I $D(M),M=U Q I IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T Q S DN=1,D0=0,DIB=$O(^DIC(+DIB)) Q:DIB>DIB(1)!(+DIB'=DIB) S (F(1),DUB,DFF)=DIB,DC="," D ^DIO2 I $D(M),M=U Q G LOOP ; END ; I $D(^UTILITY($J,"P")) W !!!?6,"FILES POINTED TO",?44,"FIELDS",! D PTR^DIDC D K ^UTILITY($J,"P") G IOF:DHIT["DIDX"!$G(DIDRANGE) D IX I M=U S DN=0 Q T ; S S=0,M=1 T1 S S=S+1 D:$Y+3>IOSL HDR^DIDG Q:M=U W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):") S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA="" F S DA=$O(@DFF@("F"_F(1),DA)) Q:DA="" D Q:M=U . S DUB=0 F S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:'DUB D Q:M=U .. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL K %1 G Q:M=U,T1:S<4 IOF W:IOST'?1"C".E @IOF Q ; TEMPL I $Y+3>IOSL D HDR^DIDG Q:M=U W !,$P(%1,U),?30 G:DFF["DIST" FORM S W="",Y=$P(%1,U,2) I Y D DD^%DT W Y W ?50,"USER #"_+$P(%1,U,5),?61 I $D(@(DFF_"(DUB,""ROU"")")) W ^("ROU")_$P("*",U,DFF["DIBT")_" " I $D(^("H")) S Y=^("H"),%=$L(Y) W:65+%>IOM ! W " ",?IOM-%-1,$E(Y,1,IOM-4) G DES:DFF'="^DIBT" I $D(^("DIPT")) W ?55 S Y=" '"_^("DIPT")_"' Print Template always used" W:$X+$L(Y)>IOM ! W ?IOM-$L(Y)-1,Y I $D(^(2)) S D0=DUB,DICMX="W !?4,X" X $P(^DD(.401,1620,0),U,5,99) F Y=1:1 Q:'$D(^DIBT(DUB,"O",Y,0)) W " " S %=^(0),D=IOM-$L(%)-5 W:$X>D !?$S(D>55:55,1:D) W % DES N A1,%1,X S A1=$P($G(@(DFF_"(DUB,""%D"",0)")),U,3) F %1=0:0 S %1=$O(@(DFF_"(DUB,""%D"",%1)")) Q:%1'>0 Q:+A1&(%1>A1) S X=^(%1,0) W !,?5,X Q W:DFF["DIBT" ! Q DT G DT^DIO2 ; EN ; Q:'$D(DIC) I 'DIC,$D(@(DIC_"0)")) S DIC=+$P(^(0),U,2) Q:'DIC!'$D(^DIC(DIC,0,"GL")) S (DFF,DUB,DIB,DIB(1))=DIC G O:'$D(DIFORMAT) S Y=DIFORMAT I 'Y S Y=$O(^DOPT("DID","B",Y,0)) Q:Y>9!'Y G O1 ; FORM ; S Y=$P(%1,U,5) I Y D DD^%DT W ?30,Y W ?50,"USER #"_+$P(%1,U,4) ; N B,L,P S L=1,L(1)=U S P=0 F S P=$O(^DIST(.403,DUB,40,P)) Q:'P D Q:M=U . Q:$D(^DIST(.403,DUB,40,P,0))[0 S B=$P(^(0),U,2) D:B BLOCK Q:M=U . S B=0 F S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B D BLOCK Q:M=U S %1=0 F S %1=$O(@DFF@(DUB,15,%1)) Q:'%1 W:$D(^(%1,0))#2 !?5,^(0) W ! Q BLOCK ; N I F I=1:1:L I L(I)[(U_B_U) G BLOCKQ S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U Q:$D(^DIST(.404,B,0))[0 S %1=^(0) ; I $Y+3>IOSL D HDR^DIDG Q:M=U W !?2,$P(%1,U) W:$P(%1,U,2)]"" ?32,"DD #"_$P(%1,U,2) BLOCKQ Q ; IX ;Print index details N DIDPG,DIDFLG S DIDPG("H")="W """" D IXHEAD^DID S:M=U PAGE(U)=1" D WRLN^DIKCP("",0,.DIDPG) Q:M=U I DHIT="S F(1)=DFF" D . S DIDFLG=$S(DIDTYP="B":"",DIDTYP="T":"O",1:"FR")_$E("M",'$G(DIDFLD)) E S DIDFLG="RM" S DIDFLG=DIDFLG_"SL2"_$E("N",$D(DINM)#2) D PRINT^DIKCP(F(1),$G(DIDFLD),DIDFLG,.DIDPG) Q ; IXHEAD S DC=DC+1 I IOST?1"C".E W $C(7) R M:DTIME S:'$T M=U Q:M=U IXHEAD1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W $S("B"[$G(DIDTYP):"INDEX AND CROSS-REFERENCE",DIDTYP="T":"TRADITIONAL CROSS-REFERENCE",1:"NEW-STYLE INDEX") W " LIST -- FILE #"_DIB_$S($G(DIDFLD):", FIELD #"_DIDFLD,1:"") W:$D(DIFF)&($Y) @IOF S DIFF=1 W "INDEX AND CROSS-REFERENCE LIST -- FILE #"_DIB,?(IOM-20),$$OUT^DIALOGU(DT,"FMTE",2)_" "_$$EZBLD^DIALOG(7095,DC) ;**CCO/NI DATE FORMAT, 'PAGE' S M="",$P(M,"-",IOM)="" W !,M Q ; KEY ;Print keys N DIDPG S DIDPG("H")="W """" D KEYHEAD^DID S:M=U PAGE(U)=1" D WRLN^DIKKP("",0,.DIDPG) Q:M=U D PRINT^DIKKP(F(1),"","ML2",.DIDPG) Q ; KEYHEAD S DC=DC+1 I IOST?1"C".E W $C(7) R M:DTIME S:'$T M=U Q:M=U KEYHEAD1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W "KEY LIST -- FILE #"_DIB,?(IOM-20),$$OUT^DIALOGU(DT,"FMTE",2)_" "_$$EZBLD^DIALOG(7095,DC) ;**CCO/NI DATE FORMAT, 'PAGE' S M="",$P(M,"-",IOM)="" W !,M Q ; ASKFLD(DIDFILE) ;Ask for a single field Q:'$G(DIDFILE) "" ; N %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,DZ,X,Y,DTOUT,DUOUT S DIC="^DD("_DIDFILE_",",DIC(0)="QAEN" S DIC("S")="I '$P(^(0),U,2)&($P(^(0),U,2)'[""C"")" S DIC("A")="Which field: ALL// " D ^DIC K DIC Q $S(X="":"",1:+Y) ; ASKTYP() ;Ask for type of cross-reference N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="SAM^T:TRADITIONAL;N:NEW;B:BOTH" S DIR("A")="What type of cross-reference (Traditional or New)? " S DIR("B")="Both" S DIR("?",1)="Enter 'T' to print only traditional cross-references." S DIR("?",2)=" Traditional cross references are stored in the data" S DIR("?",3)=" dictionary under ^DD(file#,field#,1)." S DIR("?",4)=" " S DIR("?",5)="Enter 'N' to print only new-style cross-references." S DIR("?",6)=" New-Style cross references are stored in the Index file." S DIR("?",7)=" " S DIR("?")="Enter 'B' to print both kinds of cross-references." D ^DIR Q $S($D(DIRUT):"",1:Y) ; ASKRANGE(DIDFILE,DIDBY,DIDFR,DIDTO) ;Ask for a range of fields Q:'$G(DIDFILE) ; N %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,DZ,X,Y,DTOUT,DUOUT S DIC="^DD("_DIDFILE_",",DIC(0)="QAEN" S DIC("A")="Start with field: FIRST// " D ^DIC K DIC I X="" S (DIDFR,DIDTO)="" Q I Y=-1 S (DIDFR,DIDTO)=-1 Q S DIDFR=$S(DIDBY[".001":+Y,1:$P(Y,U,2)) ; S DIC="^DD("_DIDFILE_",",DIC(0)="QAEN" S DIC("A")="Go to field: " D ^DIC K DIC I X="" S DIDTO="" Q I Y=-1 S (DIDFR,DIDTO)=-1 Q S DIDTO=$S(DIDBY[".001":+Y,1:$P(Y,U,2)) ; S:DIDTO']]DIDFR %=DIDTO,DIDTO=DIDFR,DIDFR=% Q ; FILELST(DIDROOT) ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DIDARRAY D EN4^DIQGDD M @DIDROOT=DIDARRAY Q ; FILE(DIQGR,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU G EN2^DIQGDDF ; FIELDLST(DIDROOT) ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DIDARRAY D EN5^DIQGDD M @DIDROOT=DIDARRAY Q ; FIELD(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU G EN1^DIQGDD ; GET1(DIQGR,DA,DIQGPARM,DR,DIQGETA,DIQGERRA,DIQGIPAR) ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU G EN3^DIQGDD ; PIECE(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;CLOSEDREF,PIECE,FLAG,ATTRIBUTE,TARGETARRAY,ERRORARRAY,INTERNAL ;PROCEDURE CALL AND * * RETURN RESULTS IN TARGET ARRAY * * I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU G EN6^DIQGDD0 DID1 DID1 ;SFISC/XAK,JLT-STD DD LIST ;16JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DJ(Z)=D0,DDL1=14,DDL2=32 G B ; L S DJ(Z)=0 A S DJ(Z)=$O(^DD(F(Z),DJ(Z))) I DJ(Z)'>0 S:DJ(Z)="" DJ(Z)=-1 W !! S Z=Z-1 Q B S N=^DD(F(Z),DJ(Z),0) K DDF I $D(DIGR),Z<2!(DJ(Z)-.01) X DIGR E G ND D HD:$Y+$L(X)+6>IOSL Q:M=U W !!,F(Z),",",DJ(Z) LABEL W ?(Z+Z+12),$P(N,U),?DDL2+4," "_$P(N,U,4) F X=0:0 S X=$O(^DD(F(Z),DJ(Z),.008,X)) Q:'X S W=$P($G(^(X,0)),U) I W]"",$D(^DI(.85,X,0)) S I=$P(^(0),U,2)_": " W !?(Z+Z+12-$L(I)),I,W ;**CCO/NI DISPLAY FOREIGN LABELS S X=$P(N,U,2) WP I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" D S X="" .S X="WORD-PROCESSING #"_+X D S X="(NOWRAP)" D:W["L" S X="(IGNORE ""|"")" D:W["X"!(W["x") S X="(UNEDITABLE)" D:W["I" S X="(AUDITED)" D:$G(^("AUDIT"))]"" ..W:$L(X)+$X+5>IOM !?18 W " ",X F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","m","p" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" S:W="p" W="POINTER" S:W="m" W="MULTIPLE" W ?40," "_W G ND:M=U TYPE S W=+$P(X,"t",2) I W,$D(^DI(.81,W,0)) S W=" ("_$P(^(0),U)_" Data Type)" D W G ND:M=U I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U I X["V" S I=0 F S I=$O(^DD(F(Z),D0,"V",I)) Q:I'>0 S %Y=$P(^(I,0),U) I $D(^DIC(%Y,0)),$D(@(^(0,"GL")_"0)")) S ^UTILITY($J,"P",$E($P(^(0),U),1,30),0)=%Y,^(F(Z),DJ(Z))=0 I 'X D P .N Y,NM S:X["P" Y=U_$P(N,U,3),NM=+$P(X,"P",2) I X["C" S NM=+$P(X,"p",2) I NM S Y=$G(^DIC(NM,0,"GL")) .Q:'$D(Y) N PF I Y[U,$D(@(Y_"0)")) S W=" TO "_$P(^(0),U)_" FILE (#"_NM_")",PF=$E($P(^(0),U),1,30) .E S PF="UNDEFINED FILE"_$S(NM:" (#"_NM_")",1:""),W=" ***** TO AN "_PF_$S(Y[U:", STORED IN "_$$CREF^DILF(Y),1:"")_" *******",PF="}"_PF,NM="" W:($L(W)+$X)'0 W=W_$P(^DD(+X,%,0),U)_"(#"_%_")"_$S($P(^(0),U,2)["R":"[R]",1:"")_", " I %'>0 S:W?.E1", " W=$E(W,1,$L(W)-2) D W G ND:M=U Q ; ;Print "WRITE" identifiers I '$D(DINM) S %=" " F S %=$O(^DD(+X,0,"ID",%)) Q:%="" D Q:M=U . N DIDLN,DIDPG . S DIDLN(1)=$G(^DD(+X,0,"ID",%)) Q:DIDLN(1)?."^" . S DIDLN(0)=""""_%_""": " . S DIDLN(0)=$J("",DDL2-DDL1-$L(DIDLN(0)))_DIDLN(0) . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" . D WRPHI^DIKCP1(.DIDLN,IOM-1-DDL2,DDL1,DDL2-DDL1,1,.DIDPG) G:M=U ND ; I $D(^DD("KEY","B",+X)) D G:M=U ND . N DIDPG . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" . D PRINT^DIKKP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) I $D(^DD("IX","B",+X)) D G:M=U ND . N DIDPG . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" . D LIST^DIKCP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X D L N K DDN1 I X["X" S DDN1=1 W !,?DDL1,"NOTES:",?DDL2,"XXXX--CAN'T BE ALTERED EXCEPT BY PROGRAMMER" W ! G ND:M=U S W=0 I $O(^DD(F(Z),DJ(Z),5,W))'="",'$D(DDN1) W !?DDL1,"NOTES:" TR S W=$O(^DD(F(Z),DJ(Z),5,W)) S:W="" W=-1 G IX:W'>0 S I=^(W,0),%=+I I '$D(^DD(%,$P(I,U,2),0))!$D(W(I)) K ^DD(F(Z),DJ(Z),5,W) G TR S W(I)=0 S WS=W D WR^DIDH1 W ! S W=WS K WS G TR IX S F=0 F G ND:M=U S F=$O(^DD(F(Z),DJ(Z),1,F)) Q:F'>0 W !?DDL1,"CROSS-REFERENCE:" D IX1 S:F="" F=-1 I $D(^DD("IX","F",F(Z),DJ(Z))) D S:M=U DN=0 . N DIDPG,DIDFLAG . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" . S DIDFLAG="L"_DDL1_"C"_(DDL2-DDL1)_"T1" . D PRINT^DIKCP(F(Z),DJ(Z),$E("R",$G(DIDRANGE))_"FS"_DIDFLAG_$E("N",$D(DINM)#2),.DIDPG) Q:M=U . D:'$G(DIDRANGE) LIST^DIKCP(F(Z),DJ(Z),"RS"_DIDFLAG,.DIDPG) ND S X="" G:M'=U A:Z>1 Q IX1 S W=^(F,0)_" " K DDF W ?DDL2,W,! G ND:M=U D TP:$P(W,U,3)["TRIG" I '$D(DINM) S X=0 F %=0:0 S X=$O(^DD(F(Z),DJ(Z),1,F,X)) Q:X="" I X'="%D",X'="DT" S W=^(X) S:$L(W)<248 W=X_")= "_W K:X=3 DDF D W W ! G ND:M=U Q:'$D(^("%D")) ; N DIDI,DIDN,DIDZ,DIWF,DIWL,DIWR,X K ^UTILITY($J,"W") S DIWF="W",DIWL=DDL2+1,DIWR=IOM,DIDZ=Z S DIDN=$P($G(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",0)),U,3),DIDI=0 F S DIDI=$O(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",DIDI)) Q:'DIDI!(DIDN&(DIDI>DIDN)) S X=^(DIDI,0) D ^DIWP I $D(DN),'DN S M=U Q I M'=U D ^DIWW I $D(DN),'DN S M=U I M'=U W ! E K DIOEND S Z=DIDZ K ^UTILITY($J,"W") Q ; TP S X=+$P(^(0),U,4) I F(Z)-X,$D(^DIC(X,0))#2 S ^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=X,^(F(Z),DJ(Z))=6 Q W F K=0:0 W:$D(DDF) ! S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1 K:'X DDF Q:$Y+60 D DE^DIDH1 G:M=U Q SC ; I $D(^DD(F(Z),DJ(Z),12.1)),'$D(DINM) I X["P"!(X["S") W !?DDL1,"SCREEN:" S W=^(12.1) D W I $D(^(12)) W !?DDL1,"EXPLANATION:" S W=^(12) D W G Q:M=U I '$D(DINM),$D(^DD(F(Z),DJ(Z),4)),^(4)]"" W !?DDL1,"EXECUTABLE HELP:" S W=^(4) D W G Q:M=U I $D(^(9.02))#2 W !?DDL1,"SUM:" S W=^(9.02) D W G Q:M=U AUD S W=$G(^DD(F(Z),DJ(Z),"AUDIT")) I "n"'[W D G:M=U Q . W !?DDL1,"AUDIT: " . S W=$S(W="y":"YES, ALWAYS",W="e":"EDITED OR DELETED",1:W) D W Q:M=U . S W=$G(^DD(F(Z),DJ(Z),"AX")) . I '$D(DINM),W]"" W !?DDL1,"AUDIT CONDITION: " D W PRELKUP I '$D(DINM),DJ(Z)=.01,$G(^DD(F(Z),DJ(Z),7.5))]"" W !?DDL1,"PRE-LOOKUP: " S W=^(7.5) D W G:M=U Q DEL N DIDND I '$D(DINM) S DIDND=$O(^DD(F(Z),DJ(Z),"DEL","")) I DIDND]"" D G:M=U Q W ! . W !?DDL1,"DELETE TEST: " . F D S DIDND=$O(^DD(F(Z),DJ(Z),"DEL",DIDND)) Q:DIDND=""!(M=U) W !! .. S W=$$QT(DIDND)_",0)= " D W Q:M=U .. S W=$G(^DD(F(Z),DJ(Z),"DEL",DIDND,0)) D W LAYGO I '$D(DINM),DJ(Z)=.01 S DIDND=$O(^DD(F(Z),DJ(Z),"LAYGO","")) I DIDND]"" D G:M=U Q W ! . N J W !?DDL1,"LAYGO TEST: " . F D S DIDND=$O(^DD(F(Z),DJ(Z),"LAYGO",DIDND)) Q:DIDND=""!(M=U) W !! .. S W=$$QT(DIDND)_",0)= " D W Q:M=U .. S W=$G(^DD(F(Z),DJ(Z),"LAYGO",DIDND,0)) D W D I $D(^DD(F(Z),DJ(Z),8.5)) W !?DDL1,"DELETE AUTHORITY: " S W=^(8.5) D W G Q:M=U I X'["C",$D(^(9))#2,^(9)]"" W !?DDL1,"WRITE AUTHORITY:" S W=^(9) D W G Q:M=U RD I $D(^(8))#2,^(8)]"" W !?DDL1,"READ AUTHORITY:" S W=^(8) D W G Q:M=U I $D(^(10))#2,^(10)]"" W !?DDL1,"SOURCE OF DATA:" S W=^(10) D W G Q:M=U I $O(^(11,0))>0 W !?DDL1,"DATA DESTINATION:" S I=0 F S I=$O(^DD(F(Z),DJ(Z),11,I)) Q:I="" S:$D(^DIC(.2,+^(I,0),0)) W=$P(^(0),U) I S I=-1 D W G Q:M=U I $O(^DD(F(Z),DJ(Z),20,0))>0 W !?DDL1,"GROUP:" S I=0 F S I=$O(^DD(F(Z),DJ(Z),20,I)) Q:I="" S W=$P(^(I,0),U) I S I=-1 D W Q ; W F K=0:0 S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y W ! I $Y+6>IOSL S DC=DC+1 D ^DIDH I $D(^DD(F(Z),DJ(Z),0)) Q ; Q G ND^DID1 ; MOD ;FROM DID S X=U,%=2 W !,"WANT THE LISTING TO INCLUDE MUMPS CODE" D YN^DICN Q:%<0 S:%=2 DINM=1 I '% W !?5,"Enter YES, to see the MUMPS code as in the STANDARD listing.",!?5,"Enter NO, to eliminate MUMPS code from the listing." G MOD MOD2 S %=2 W !,"WANT TO RESTRICT LISTING TO CERTAIN GROUPS OF FIELDS" D YN^DICN S:%=2 X=0 Q:%<0!(%=2) I '% W !?5,"Enter YES, to select the Groups you wish to see in this listing.",!?5,"Enter NO, to see all fields." G MOD2 W ! S DP="",L=""","_$S(Y-2:"DJ(Z)",1:"D1")_"))" G R "Include GROUP: ",X:DTIME S:'$T X=U,DTOUT=1 I X[""""!($L(X)>30)!(X'?.ANP) W $C(7),!,"SORRY, THAT ISN'T WHAT A 'GROUP' NAME CAN LOOK LIKE",! G G Q:X[U I X'?."?" S C="!" S:X?1"'"1E.E X=$E(X,2,99),C="&'" S DP=DP_C_"$D(^DD(F(Z),""GR"","""_X_L W !,"And " G G I X="" S:DP]"" DIGR="I "_$E(DP,2,999) Q W !?5,"To list only those fields which have a particular 'GROUP'",!?5,"(or several 'GROUPS') associated with them, Enter the GROUP NAME",! W ?5,"To screen out a group, Type ""'"" in front of its name.",! G G ; QT(X) ;Quote X if noncanonic Q:X=+$P(X,"E") X S X=$NA(X(X)),X=$E(X,3,$L(X)-1) Q X DIDC DIDC ;SFISC/STAFF-CONDENSED DD ;26APR2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. TODAY S DM="",Y=DT,X="I $Y+3>IOSL W $C(7) D P" X ^DD("DD") S DAT=Y ;**CCO/NI TODAY'S DATE EN S N(0)=$O(^DD(X1),-1),I=0 F S N(0)=$O(^DD(N(0))) Q:N(0)'>0!(N(0)>X2) S NAME=$O(^DD(N(0),0,"NM",0)) I NAME'="" S P=0 D P,P2 G:DM["^" EXIT EXIT K %DT,%ZIS,DAT,I,J,K,K1,M,N,N1,NAME,MO,P,X,X1,X2,Y,KK,NF,NY,POP S D0="B",M=DM K DM Q P S P=P+1 I IOST?1"C-".E R:P'=1 DM:DTIME Q:DM["^"!'$T W:$D(DIFF)&($Y) @IOF S DIFF=1 W !!,"CONDENSED DATA DICTIONARY---",NAME," FILE"," (#",N(0),")" I $D(^%ZOSF("UCI"))#2 X ^("UCI") W ?47,"UCI: "_Y W ?63,$S($G(^DD(N(0),0,"VR"))]"":" VERSION: "_$P(^("VR"),U),1:" ") W !!,"STORED IN: ",$S($D(^DIC(N(0),0,"GL")):^("GL"),1:""),?58,DAT,?70,"PAGE ",P W ! F I=0:1:IOM-1 W "-" G P1:P'=1 W !!,?50,"FILE SECURITY" W !,?35,"DD SECURITY : ",$S($D(^DIC(N(0),0,"DD")):^("DD"),1:""),?58,"DELETE SECURITY: ",$S($D(^("DEL")):^("DEL"),1:"") W !,?35,"READ SECURITY : ",$S($D(^("RD")):^("RD"),1:""),?58,"LAYGO SECURITY : ",$S($D(^("LAYGO")):^("LAYGO"),1:"") W !,?35,"WRITE SECURITY : ",$S($D(^("WR")):^("WR"),1:"") AFOF I $D(^VA(200,"AFOF",N(0))) W !?10,"(NOTE: Kernel's File Access Security applies to this File.)",! W !,"CROSS REFERENCED BY:",!,?5 S NY="" F KK=1:1 S NY=$O(^DD(N(0),0,"IX",NY)) Q:NY="" S NF=+$O(^(NY,0)),N1=+$O(^(NF,0)) D .N % S %=0 F S %=$O(^DD(NF,N1,1,%)) Q:'% I $D(^(%,0)),+^(0)=N(0),$P(^(0),U,2)=NY W:$X>50&($L($P(^DD(NF,N1,0),"^",1)>20)) !,?5 W " ",$P(^DD(NF,N1,0),"^",1),"(",NY,") " D LIST^DIKCP(N(0),"","M") P1 W !!!,?33,"FILE STRUCTURE",!! W "FIELD",?10,"FIELD",!,"NUMBER",?10,"NAME",! Q P2 S M(0)=0 F K1=0:0 S M(0)=$O(^DD(N(0),M(0))),K=0 Q:+M(0)'>0!(M(0)?1U.U) X X Q:DM["^" W !,M(0),?10,$P(^DD(N(0),M(0),0),U,1)," " D M I J S K=K+1 D MO Q:DM["^" Q MO X X Q:DM["^" S N(K)=+$P(^DD(N(K-1),M(K-1),0),U,2) S M(K)=0 F L=0:0 S M(K)=$O(^DD(N(K),M(K))) Q:M(K)'>0 X X Q:DM["^" W !,?10+((K-1)*5),M(K),?15+((K-1)*5),$P(^DD(N(K),M(K),0),U,1)," " D M I J S K=K+1 D MO Q:DM["^" Q:DM["^" X X Q:DM["^" S K=K-1 Q M S J=$P(^(0),U,2) W $S(+J:"(Multiple-"_+J,1:"("_J),"), [",$P(^(0),U,4),"]" Q PTR ; S F=0,I=0 F S F=$O(^UTILITY($J,"P",F)) Q:F="" D PT S F=-1 Q PT W !,F_" " I ^(F,0) W:$X>24 !?19 W "(#"_^(0)_") " S %=0 F S %=$O(^UTILITY($J,"P",F,%)) Q:%="" W ?33," ",$S(%=F(1):"",1:$P(^DD(%,0)," SUB-FIELD",1)_":") S S=0 F S S=$O(^UTILITY($J,"P",F,%,S)) Q:S="" W ?34,$P(^DD(%,S,0),U)," (#"_S_")",! S (%,S)=-1 Q ; L ; CUSTOM LOOP I $G(Y)=U!($G(M)=U) G Q I DJ,IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T G Q K ^UTILITY($J,0) DD S DIB=$O(^DD(+DIB)) G:DIB>DIB(1)!(+DIB'=DIB) Q G:$D(^(DIB,0))[0 DD I $G(DIPP(0,"IX"))["^DD(DFF,""AUDIT""",$O(^DD(DIB,"AUDIT",""))="" G DD:'$D(^DIC(DIB)) D G:'DIB!(DIB>DIB(1)) Q . F S DIB=$O(^DIC(+DIB)) Q:'DIB!(DIB>DIB(1)) Q:$O(^DD(DIB,"AUDIT",""))]"" SUBFILES M DPP=DIPP F Y="S","N","Q","H","L" D ;IF THERE ARE SUBTOTALS, ETC, ZERO THEM OUT .N C,V S C=Y_"(V)" F V=0:0 S V=$O(@C) Q:V="" S @C=0 S L=0,DISEARCH=1,DFF=DIB,DJ=DIJS,DPQ=DIPQ,M=DIMS S:'$D(DIA) DC="," G ^DIO Q S DFF=DIB(1) G STOP^DIO4 DIDG DIDG ;SFISC/RWF-GLOBAL MAP ;10JAN2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K W S DJ(Z)=D0,F=0,W=F(Z),M=1,DP=0 W ! UP I $D(^DD(W,0,"UP")) S Y=^("UP"),N=$O(^DD(Y,"SB",W,0)) I $D(^DD(Y,N,0)) S F=F+1,W(F)=$P($P(^(0),U,4),";",1),W=Y G UP S W=$S($D(^DIC(W,0,"GL")):^("GL"),1:"^("),Y=0 F N=F:-1:1 S W=W_"D"_Y_","_$S(+W(N)=W(N):W(N),1:""""_W(N)_"""")_",",Y=Y+1 S DID(Z-1)=W K W ; L S DN(Z)="" A S DN(Z)=$O(^DD(F(Z),"GL",DN(Z))),DP(0)=0 I DN(Z)="" D POP Q S DID(Z)=DID(Z-1)_"D"_(F+Z-1)_","_DN(Z) I $O(^DD(F(Z),"GL",DN(Z),""))=0 S DP="" E S W=DID(Z)_")=" W ! D WL Q:M=U B S DP=$O(^DD(F(Z),"GL",DN(Z),DP)) G PUSH:DP=0,A:DP="" S DF=$O(^DD(F(Z),"GL",DN(Z),DP,0)) I DP(0)+1IOSL HDR Q:M=U W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):") S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA="" F S DA=$O(@DFF@("F"_F(1),DA)) Q:DA="" D Q:M=U . S DUB=0 F S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:DUB'>0 D Q:M=U .. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL K %1 Q:M=U G T1:S<4 Q Q TEMPL I $Y+3>IOSL D HDR Q:M=U N % S %=$S($D(^("ROU")):"Compiled: "_^("ROU"),'$D(^("ROU"))&($D(^("ROUOLD"))):"Previously Compiled: "_^("ROUOLD"),1:"") I %]"",DFF["DIBT" S %=%_"*" I DFF'["DIST" W !,DFF,"("_DUB_")= ",$P(%1,U)_" "_% E D FORM Q WL I $Y+4>IOSL S %1=W D HD Q:M=U S W=%1 I W[DID(Z) S W="" F I=1:1 S Y=$P(W," ",I)_" " Q:$P(W," ",I,99)="" W:$X+$L(Y)+2>IOM !,?$L(DID(Z)),"==>" W Y Q W W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5245 L=L+1,L(L)=U S L(L)=L(L)_B_U Q:$D(^DIST(.404,B,0))[0 S %1=^(0) ; I $Y+3>IOSL D HDR Q:M=U W !?2,"^DIST(.404,"_B_")= ",$P(%1,U) BLOCKQ Q DIDGFTPT DIDGFTPT ;GFT/GFT -- GET ALL ENTRIES THAT POINT TO ENTRY GFTIEN IN FILE GFTFILE;14OCT2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; W !!,"THIS UTILITY TRIES TO FIND ALL ENTRIES IN ALL FILES POINTING TO A CERTAIN FILE",! D DT^DICRW N DIC,DIR,X,Y,GFTIEN,GFTANY,GFTFILE,GFTALL,DIRUT,DIBT,GFTIENLIST K ^TMP($J) S DIC=1,DIC(0)="AEQM" D ^DIC Q:Y<0 S GFTFILE=+Y,GFTANY=$P(^DIC(GFTFILE,0),U) S DIR(0)="S^1:One particular "_GFTANY_" Entry;2:All "_GFTANY_" Entries;3:Non-existent "_GFTANY_" Entries" S X="" F S X=$O(^DIBT("F"_GFTFILE,X)) Q:X="" F Y=0:0 S Y=$O(^DIBT("F"_GFTFILE,X,Y)) Q:'Y I $D(^DIBT(Y,1))>1 S DIBT(Y)="" I $O(DIBT(0)) S DIR(0)=DIR(0)_";4:Entries from a "_GFTANY_" Search Template" S DIR("A")="Find pointers to" S DIR("B")=$P($P(DIR(0),";",2),":",2) D ^DIR K DIR Q:$G(DIRUT) I Y=4 S DIC=.401,DIC("S")="I $D(DIBT(+Y))",GFTANY=Y D ^DIC Q:Y'>0 K DIBT,DIC M GFTIENLIST=^DIBT(+Y,1) G ZIS S DIC=GFTFILE,DIC("A")="Find pointers to "_GFTANY_" Entry: ",GFTANY=Y,GFTIENLIST=0 I Y=1 D ^DIC Q:Y<0 S GFTIENLIST=+Y ZIS D ^%ZIS Q:$G(POP) U IO W ! S $Y=0 START K DIC D DEPEND(GFTFILE,.GFTIENLIST,,"M"_GFTANY) ;NOW WE HAVE ALL INFO S GFTIEN="" F S GFTIEN=$O(^TMP($J,GFTFILE,GFTIEN)) Q:GFTIEN="" D Q:'$D(GFTIEN) .S X=$$GET1^DIQ(GFTFILE,GFTIEN,.01) I X]"" Q:GFTANY=3 .E S X="NON-EXISTENT ENTRY # "_GFTIEN .W !!,"***",$P(^DIC(GFTFILE,0),U),": " W X,"***" .F I=0:0 Q:'$D(GFTIEN) S I=$O(^TMP($J,GFTFILE,GFTIEN,I)) Q:'I W !,"FILE ",I," (",$P(^DIC(I,0),U),")" F J=0:0 S J=$O(^TMP($J,GFTFILE,GFTIEN,I,J)) Q:'J D Q:'$D(GFTIEN) ..S Y=$O(^(J,"")) ..W !?9,"`",J,?22,$$GET1^DIQ(I,J,.01) ..F Q:Y="" W:$X>(IOM-30) ! W ?IOM-30,$P(@("^DD("_Y_",0)"),U) S Y=$O(^TMP($J,GFTFILE,GFTIEN,I,J,Y)) ..I $E($G(IOST))="C",$G(IOSL,24)-3<$Y S DIR(0)="E" D ^DIR S $Y=0 I 'Y K GFTIEN K ^TMP($J) I '$G(GFTALL) W !!! D ^%ZISC Q ; ; DEPEND(GFTFILE,IEN,GFTWHERE,GFTPARAM) ; I $G(GFTPARAM)["M" N GFTANY S GFTANY=+$P(GFTPARAM,"M",2) S:$G(GFTWHERE)="" GFTWHERE=$NA(^TMP($J)) K @GFTWHERE ;output array I $D(IEN)<9 S GFTIEN(GFTFILE,+IEN)="" ;IEN can be either a scalar... E M GFTIEN(GFTFILE)=IEN ;...or an array N A,B S A=0 F S A=+$O(^DD(GFTFILE,0,"PT",A)) Q:'A D . S B=0 F S B=+$O(^DD(GFTFILE,0,"PT",A,B)) Q:'B D . . D CHASE(A,B,.GFTRCR) COMPUTED S A=0 F S A=+$O(^DD(GFTFILE,0,"PTC",A)) Q:'A D .S B=0 F S B=+$O(^DD(GFTFILE,0,"PTC",A,B)) Q:'B D ..D CHASE(A,B,.GFTRCR) Q ; ; CHASE(FILE,FIELD,GFTRCR) ;BUILD AN 'XEC' THAT WILL GO THRU FILE REMEMBERING FIELD'S POINTERS I FILE=.6!(FILE=1.1) Q ;NOT AUDIT FILES N GFTF,X,I,J,V,XEC,A,B,D0,D1,D2,D3,D4,D5,D6,D7,D8,D9,DICMX,DIDGFTPT,GFTFISCR S GFTF=FILE,L=0,PUT="",DIDGFTPT=1 ;want this defined for special FILE SCREENS UP F S I=$G(^DD(GFTF,0,"UP")) Q:'I S L=L+1,X=$O(^DD(I,"SB",GFTF,0)) Q:'X S J=$P($G(^DD(I,X,0)),U,4) Q:J'[";0" S GFTF=I,J(L)=$P(J,";") Q:'$D(^DIC(GFTF,0,"GL")) S J=^("GL"),I="" I $G(^DD(GFTF,0,"SCR"))]"" S GFTFISCR=^("SCR") F A=L:-1:0 S X="D"_(L-A),PUT=PUT_"_D"_A_"_"",""",I=I_"F "_X_"=0:0 S "_X_"=$O("_J_X_")) Q:'"_X_" I $D(^("_X_",0)) " I A S J=J_X_","""_J(A)_"""," D Q:'$D(XEC) ;NOW WE HAVE 'L' AS LEVEL AND 'I' AS 'L' FOR LOOPS .S X=$P($G(^DD(FILE,FIELD,0)),U,4) Q:X="" S A=$P(^(0),U,2),FIELD=FILE_","_FIELD,V=$P(X,";",2) .I 'V Q:A'["C" Q:A'["p" S DICMX=$P(^(0),U,5,99),XEC="X DICMX I X" I A["m" D Q ..S XEC=I_"S DIDGFTPT=D0 "_DICMX,DICMX="D PUT^DIDGFTPT(+$G(D),DIDGFTPT,"""_FIELD_""")" ;m=MULTIPLE COMPUTED POINTER .I V S XEC="S X=$P($G(^("""_$P(X,";")_""")),""^"","_+V_") I X" D:A["V" ..S XEC=XEC_",$P(X,"";"",2)="""_$$CONVQQ^DILIBF($P(^DIC(GFTFILE,0,"GL"),U,2))_"""" .S XEC=I_XEC_" D PUT(+X,D0,"""_FIELD_""")" XEC X XEC Q ; PUT(XVAL,Y,FIELD) I '$D(GFTIEN(GFTFILE,XVAL)) Q:$G(GFTANY)<2 I $D(GFTFISCR) X GFTFISCR E Q ;FILE SCREEN! N IENS,L,S S IENS=D0_"," F L=1:1 S S=$G(@("D"_L)) Q:S="" S IENS=S_","_$G(IENS) S @GFTWHERE@(GFTFILE,XVAL,GFTF,Y,FIELD,IENS)="" Q ; ; ALL ;Do all files (SO) D ^%ZIS U IO N GFTFILE S GFTFILE=1.99999 F S GFTFILE=$O(^DIC(GFTFILE)) Q:'GFTFILE D . I GFTFILE=80.2 Q . I GFTFILE=80.3 Q . N GFTIEN,GFTANY,GFTALL . S GFTIEN=0,GFTANY=3,GFTALL=1 . D START .Q ; D ^%ZISC Q DIDH DIDH ;SFISC/GFT,XAK-HDR FOR DD LISTS ;13SEP2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; D ^DIDH1 I $G(M)=U S DN=0 Q K DDV,%F,M1 Q ; ; XR S X=2,J=0,DG=F(Z) W:$Y ! XL S J=$O(^DD(DA,0,"IX",J)) I J="" S F(Z)=DG Q F K=0:0 S K=$O(^DD(DA,0,"IX",J,K)) G XL:K'>0 F N=0:0 S N=$O(^DD(DA,0,"IX",J,K,N)) Q:N'>0 I 1 S F(Z)=K,DJ(Z)=N X:$D(DIGR) DIGR D:$T XL1 XL1 F %=0:0 S %=$O(^DD(K,N,1,%)) Q:'%!(M=U) I $D(^(%,0)),+^(0)=DA,$P(^(0),U,2)=J W:X=2 !,"CROSS",! W $P(", ^REFERENCED BY: ",U,X) S X=$P(^DD(K,N,0),U)_"("_J_")" W:($L(X)+$X+4)'IOSL I '$D(DIU) D H S X=2 Q ; ; ; POINT ; CALLED BY ^DD(1,.01,"DEL",.5,0) N W1,DDPT,DDC,DDV,X1 S M="" S W1="W:$Y ! W !,""POINTED TO BY: "",?15" I $O(^DD(DA,0,"PT",""))'="" S DDPT=1 S X="" F S X=$O(^DD(DA,0,"PT",X)) Q:X="" S DG=0 F S DG=$O(^DD(DA,0,"PT",X,DG)) Q:DG="" D W:$D(^DD(DA,0,"PT",X,DG)) !?15 I '$D(DIU) D H G Q:M=U .I $S('$D(^DD(X,DG,0)):1,$P(^(0),U,2)["V":0,1:$P($P(^(0),U,2),"P",2)-DA) K ^DD(DA,0,"PT",X,DG) Q .D PD S W1="W:$Y ! W !,""POINTED TO BY COMPUTED POINTER: "",!?15" I $O(^DD(DA,0,"PTC",""))'="" S DDPT=1 S X="" F S X=$O(^DD(DA,0,"PTC",X)) Q:X="" S DG=0 F S DG=$O(^DD(DA,0,"PTC",X,DG)) Q:DG="" D W:$D(^DD(DA,0,"PTC",X,DG)) !?15 I '$D(DIU) D H G Q:M=U .S %=$P($G(^DD(X,DG,0)),U,2) I $P(%,"Cp",2)-DA,$P(%,"mp",2)-DA K ^DD(DA,0,"PTC",X,DG) Q .D PD S (DG,X)=-1 K W1,DDPT Q ; PD ; S %=X,%F=DG WR I '$D(IOM) S IOP="HOME" N %X D ^%ZIS Q:POP I $D(DDPT) X W1 K DDPT S X1=$P(^DD(%,%F,0),U)_" field (#"_%F_")" UP I $L(X1)+$L(%)+$L($O(^DD(%,0,"NM",0)))>225 S X1=X1_" etc... ^" G L1 S X1=X1_" of the "_$O(^(0)) I $D(^DD(%,0,"UP")) S X1=X1_" sub-field (#"_%_")",%=^("UP") G UP S X1=X1_" File (#"_%_") ^" L1 F DDC=1:1 S DDV=$P(X1," ",DDC)_" " Q:DDV["^" W:$L(DDV)+$X>IOM !,?19 W DDV K DDC,DDV,X1 Q ; TRIG ;CALLED BY ^DD(1,.01,"DEL","TRB",0) S W1="W:$Y ! W !,""A FIELD IS"",!,""TRIGGERED BY :"",?15",DDPT=1 K X S X="" F S X=$O(^DD(DA,"TRB",X)) Q:X="" I X-DA,'$D(^DD(DA,"SB",X)) S %=0 F S %=$O(^DD(DA,"TRB",X,%)) Q:%="" S %X=0 F S %X=$O(^DD(DA,"TRB",X,%,%X)) Q:%X="" S %Y=0 F S %Y=$O(^DD(DA,"TRB",X,%,%X,%Y)) Q:%Y'>0 D TT S %Y=-1 I $D(X)>9 S %X=0 F S %X=$O(X(%X)) Q:%X="" S X=0 F S X=$O(X(%X,X)) Q:X="" S %F=X,%=%X D WR:$D(^DD(%,X,0)) W !?15 D:'$D(DIU) H I 1 K X,%X,%Y,W1,DDPT Q ; TT S X(X,%)=0 I $D(^DD(X,%,0)) Q:$P(^(0),U,2) I $D(^(1,%X,0)),^(0)["TRIGGER" Q K X(X,%),^DD(DA,"TRB",X,%,%X,%Y) Q H I $D(IOSL),$Y+4>IOSL S DC=DC+1 D ^DIDH1 G Q:M=U Q W F K=0:1 W:$D(DDF) !?25 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1 K DDF Q PTR(X) ;finds pointers to file being deleted N Y,Z S (Y,Z)=0 I $O(^DD(X,0,"PT",Y))="" Q Z D Q Z . F S Y=$O(^DD(X,0,"PT",Y)) Q:Y="" I $$FNO^DILIBF(Y)'=X S Z=1 Q . Q DIDH1 DIDH1 ; SFISC/ALL - HDR FOR DD LISTS; 16NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DIDHI,DIDHJ,DIC,W,M1 D .N I,J D IJ^DIUTL(DFF) M DIDHJ=J,DIDHI=I S DIDHJ=$O(J(""),-1) S M=1 I DC=1 S (F(1),DA)=DFF,Z=1 E I $Y,IOST?1"C".E W $C(7) R M:DTIME I M=U!'$T K DIOEND S M=U,DN=0 Q S M1=$S($G(^DD(F(1),0,"VR"))]"":" (VERSION "_$P(^("VR"),U)_") ",1:"") I IOST?1"C".E S DIFF=1 W:$D(DIFF)&($Y) @IOF S DIFF=1 W $S(DHIT["DIDX":"BRIEF",DHIT["DIDG":"GLOBAL MAP",$D(DINM):"MODIFIED",1:"STANDARD") W " DATA DICTIONARY #"_DFF_" -- "_$O(^DD(DFF,0,"NM",0))_" "_$S(DIDHJ:"SUB-",1:"")_"FILE " S DIC=^DIC(DUB,0,"GL") D .N X,Y TODAY .S W=$$OUT^DIALOGU(DT,"FMTE","2D")_" "_$$EZBLD^DIALOG(7095,DC) W ?(IOM-$L(W)-1),W ;**CCO/NI TODAY'S DATE, 'PAGE' S M=IOM\2,S=" ",W="" I $D(^DD("SITE")) S W="SITE: "_^("SITE")_" " I $D(^%ZOSF("UCI"))#2 X ^("UCI") S W=W_"UCI: "_Y W ! I DHIT["DIDX" W W,?(IOM-$L(M1)-1),M1 S W="",$P(W,"-",IOM)="" W !,W S W="" G Q^DIDH W "STORED IN ",DIC F I=1:1 Q:'$D(DIDHI(I)) W "D",I-1,",",DIDHI(I),"," I 'DIDHJ D .I $O(@(DIC_"0)"))'>0 W " *** NO DATA STORED YET ***" Q .S I=$P(^(0),U,4) W:I " ("_I_" ENTR"_$S(I=1:"Y)",1:"IES)") W " ",W,?(IOM-$L(M1)-1),M1 D:DHIT'["DIDG" .W !!,"DATA",?14,"NAME",?36,"GLOBAL",?50,"DATA",!,"ELEMENT",?14,"TITLE",?36,"LOCATION",?50,"TYPE" G W ! F I=1:1:IOM-1 W "-" S W="" Q:DC>1!$G(DIDRANGE) FIRST F DG=0:0 S DG=$O(^DIC(DA,"ALANG",DG)) Q:'DG I $D(^(DG,0)) S DIWR=$P(^(0),U) I $D(^DI(.85,DG,0)) W !,$P(^(0),U)," FILE NAME: ",DIWR ;**SHOW FOREIGN FILE NAMES PAGE1 I 'DIDHJ,'$$WP^DIUTL($NA(^DIC(DA,"%D"))) S M="^" Q I DIDHJ D I M=U Q .S W=DIDHJ(DIDHJ-1),W=$NA(^DD(W,+$O(^DD(W,"SB",DFF,"")))) I '$$WP^DIUTL($NA(@W@(21))) S M=U Q .I $D(@W@(23)) W !,"TECHNICAL DESCRIPTION:",! I '$$WP^DIUTL($NA(@W@(23))) S M=U .F I=8,9 I $D(@W@(I)) W !,?15,$P("READ^WRITE",U,I-7)," ACCESS: ",^(I) I DHIT["DIDG" D Q . D XR^DIDH Q:M=U . N DIDPG S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" . D LIST^DIKCP(DA,"","C15",.DIDPG) Q:M=U . D WRLN^DIKCP1("",0,.DIDPG) Q:DHIT["DIDX"!(M=U) W ! F %=1:1:4 S X=$P("SCR^DIC^ACT^DIK",U,%) I $G(^DD(DA,0,X))]"" W !,$P("FILE SCREEN (SCR-node) ^SPECIAL LOOKUP ROUTINE ^POST-SELECTION ACTION ^COMPILED CROSS-REFERENCE ROUTINE",U,%)_": " S W=^(X) D W^DIDH G Q:M=U W:$P($G(^DD(DA,0,"DI")),U)["Y" !,"THIS IS AN ARCHIVE FILE." W:$P($G(^DD(DA,0,"DI")),U,2)["Y" !,"EDITING OF FILE IS NOT ALLOWED." F N="DD","RD","WR","DEL","LAYGO","AUDIT" I $D(^DIC(DA,0,N)) W !?(Z+Z+14-$L(N)),N," ACCESS: ",^(N) AFOF I $D(^VA(200,"AFOF",DA)) W !!?8,"(NOTE: Kernel's File Access Security applies to this File.)",! I $O(^DD(DA,0,"ID",""))]"" W !,"IDENTIFIED BY: " S X=0 F S X=$O(^DD(DA,0,"ID",X)) Q:X="" Q:'$D(^DD(DA,X,0)) S I1=$P(^(0),U)_" (#"_X_")"_$S($P(^(0),U,2)["R":"[R]",1:"") W:($L(I1)+$X)+1>IOM ! W ?15,I1 I $O(^DD(DA,0,"ID",X)) W ", " S:X="" X=-1 ; ;Print "WRITE" identifiers I '$D(DINM) S X=" " F S X=$O(^DD(DA,0,"ID",X)) Q:X="" D Q:M=U . N DIDLN,DIDPG . S DIDLN(1)=$G(^DD(DA,0,"ID",X)) Q:DIDLN(1)?."^" . S DIDLN(0)=""""_X_""": " . S DIDLN(0)=$J("",15-$L(DIDLN(0)))_DIDLN(0) . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" . D WRPHI^DIKCP1(.DIDLN,IOM-16,0,15,1,.DIDPG) Q:M=U ; I $D(^DD("KEY","B",DA)) D . N DIDPG . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" . D PRINT^DIKKP(DA,"","C20",.DIDPG) D POINT^DIDH Q:M=U D TRIG^DIDH,XR^DIDH Q:M=U I $D(^DD("IX","B",DA)) D Q:M=U W ! . N DIDPG . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" . D LIST^DIKCP(DA,"","C15",.DIDPG) CREATED W !! S N=$G(^DIC(DA,"%A")),Y=$P(N,U,2) I Y X ^DD("DD") W ?3,"CREATED ON: "_Y I $S($D(^VA(200,0)):1,1:$D(^DIC(3,0))),^(0)["NEW PERSON"!(^(0)["USER")!(^(0)["EMPLOY"),$D(^(+N,0)) W " by "_$P(^(0),U) S Y=+$G(^DIC(DA,"%MSC")) I Y X ^DD("DD") W " LAST MODIFIED: "_Y Q Q W W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5IOM !?DDL2 W DDV Q:$L(DDV1)>$L(W) I $Y+6>IOSL S DC=DC+1 D DIDH1 K DDV,DDV1 Q DE ; W !?DDL1,$P("DESCRIPTION:^TECHNICAL DESCR:",U,%Y=23+1) I '$$WP^DIUTL($NA(^DD(F(Z),DJ(Z),%Y)),DDL2+1) S M="^" Q DIDT DIDT ;SFISC/GFT-DATE/TIME UTILITY ;27JUL2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. %DT ; I $G(DUZ("LANG"))>1,($G(^DI(.85,DUZ("LANG"),20.2))]"") X ^(20.2) Q CONT ; K % S:$D(%DT)[0 %DT="" S:$G(DIQUIET)!($D(DDS)#2)!($D(ZTQUEUED)) %DT=$P(%DT,"E")_$P(%DT,"E",2) G NA:%DT'["A" W !,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B")_"//",1:"") R X:$S($D(DTIME):DTIME,1:300) S:'$T X="^",DTOUT=1 G:$L(X)>39 1 I $D(%DT("B")),X="" S X=%DT("B") I "^"[X S Y=-1 K %I,% Q NA S %(0)=X G 1:X'?.ANP,1:$P(X,"@")?15.N,1:$P(X,"@",2)?15.N,1:$L(X)>39 F %=1:1:$L(X) Q:X?.UNP S Y=$E(X,%) I Y?1L S X=$E(X,1,%-1)_$C($A(Y)-32)_$E(X,%+1,99) ;UPPER CASE I %DT["E",X?."?" D HELP^%DTC G B I %DT["N",X?.N G NO I X?1.A,(X["MID"!(X["NOON")) S X="@"_X I X'?1"NOV".E,X?1"N".1"OW".1P.E G N^%DTC:%DT["T"!(%DT["R")&(%DT'["M") S X=$E(X,2,99),X="T"_$P(X,"OW")_$P(X,"OW",2) I X?1.N." "1.2A!(X?1.N1":"2N." ".2A)!(X?1.N1":"2N1":"2N." ".2A) S X="T@"_X I X?7N1"."1.N G R I X'["@",%DT'["R" G R I %DT'["T",%DT'["R" G NO I %DT["M" G NO S Y=$P(X,"@",2,9),X=$P(X,"@") F %=2,3 S %I=$P(Y,":",%) I %I?1N.E,%I'?2N.PA G 1 S:X="" X="T" S Y=$P(Y,":")_$P(Y,":",2)_$P(Y,":",3,9),%I=Y I Y?1.A S Y=$S(Y["MID":2400,Y["NOON":1200,1:"") T G G:Y?4N,G1:Y?6N&(%DT["S"),1:Y'?1.6N." ".1(1"AM",1"A",1"A.M",1"PM",1"P",1"P.M").P I %DT["R",Y="" G NO S %I=$P(1_%I,+(1_Y),2) S:%I]"" Y=$P(Y,%I) I Y?5.6N G:%DT'["S" 1 S %(3)=$E(Y,$L(Y)-1,$L(Y)),Y=$E(Y,1,$L(Y)-2) G 1:%(3)>59 I Y?1.2N G:Y'<13 1 S Y=Y_"00" S:$E(Y)=0 %I="A" I %I["A" S Y=$S(Y=1200&'$G(%(3)):2400,Y>1159:Y-1200,1:Y) E I Y?1.2"0"2N G:%I["P" 1 E I Y<1200,%I["P"!(Y<600) S Y=Y+1200 ;ASSUME PM G G 1:Y>2400,1:Y#100>59,1:('Y&('$G(%(3)))) S %(1)=$S('Y:".0000",1:Y/10000) G R G1 G 1:Y>240000!'Y,1:$E(Y,3,4)#100>59,1:$E(Y,5,6)#100>59 S %(1)=Y/1000000 R I %DT["F"!(%DT["P") D TY S %(9)=% 7 G 8:X'?7N1".".E&(X'?7N) S Y=$E(X,8,16),%=$E(Y_"000000",2,7) I Y,%DT'["T"!(%DT["M") G NO I %DT["E",(%'?.N)!(%>240000)!($E(%,3,4)>59)!($E(%,5,6)>59) G NO S:Y %(1)=+Y S X=$E(X,4,7)_($E(X,1,3)+1700),%(7)=1 I %DT["I",'$D(%("ALPHA")) S X=$E(X,3,4)_$E(X,1,2)_$E(X,5,9) 8 S %I=0,%="" I X'?.N G T^%DTC:"T+-"[$E(X),U:X["^",1:$E(X)?1P,MTH:X?3.A&(%DT["M"),X I X?8N,X>17999999,$E(X,5,8)<1300 S X=$E(X,5,8)_$E(X,1,4),%("ALPHA")=1 ;MAY BE '200101231' FOR 2001DEC31 I %DT'["X",X\300=6!(X?2N) S (%I(1),%I(2))=0,%I(3)=X G 3 F %I=0:1 S Y=$E(X,1,2),X=$E(X,3,9) G OT:Y="" D G:%I="" 1 . I %DT["X",%DT'["M",%I<2,'Y S %I="" Q . S:%I=2 Y=Y_X,X="" . I %DT["X",%I=2,$L(Y)>2,Y'>1799 S %I="" Q . S %I(%I+1)=Y Q ; X S Y=$E(X),X=$E(X,2,99) I Y?1N G A:%?.N,Y ;PEEL OFF CHARACTER-BY-CHARACTER I Y?1A G A:%?.A,Y OT D:%]"" % G 1:%I>3,X:Y?1P,1:Y]"",@%I Y D % S %=Y G 1:%I>3,X A S %=%_Y G X TY S %=$H#1461,%=$H\1461*4+(%\365)+141-(%=1460) Q 0 ; 1 W:%DT["E"&'$D(DIER) $C(7),$S('$D(DDS):" ??",1:"") ;INPUT IS BAD! B G %DT:%DT["A",NO U S X="^",%(0)=X NO S Y=-1 G Q:%DT'["A",Q:X["^" W $C(7)," ??" G %DT 2 I %DT["M" S %I(3)=%I(2),%I(2)=0 G 3 I %I(2)>31!'%I(2),%DT'["X" S %I(3)=%I(2),%I(2)=0 G 1:'%I(2)&$G(%(1)) G 3 D TY S %I(3)=% D PF^%DTC:$D(%(9)) G C 3 I %I(1)>1700 S %("YF")=%I(1),%I(1)=%I(2),%I(2)=%I(3),%I(3)=%("YF") ;YEAR FIRST: ALLOW '2010-1-31' I %I(3)?2N D G C . I '$D(%(9)) D TY S %(9)=% . N A S A=$E(%(9))*100 . I $E(%(9),2,3)=%I(3) S %I(3)=A+%I(3) Q . I %DT["P" S %I(3)=$S(%I(3)<$E(%(9),2,3):A,1:A-100)+%I(3) Q . I %DT["F" S %I(3)=$S(%I(3)>$E(%(9),2,3):A,1:A+100)+%I(3) Q . S %I(3)=A+%I(3) . I %(9)-%I(3)>80 S %I(3)=%I(3)+100 Q . I %I(3)-%(9)>20 S %I(3)=%I(3)-100 . Q S %I(3)=%I(3)-1700 G 1:%I(3)'?3N C I %DT["I",'$D(%("ALPHA")),'$D(%("YF")),%I(2)>0 S %=%I(2),%I(2)=%I(1),%I(1)=% ;INTERNATIONAL: REVERSE MONTH/DAY I %I(2)="00",'$G(%(7)) G 1 I %DT["M",$G(%I(2)) G 1 I %I(1)>12!(%I(1)="00") G 1 I %I(2)>28,$E("303232332323",%I(1))+28<%I(2),%I(1)-2!(%I(2)-29)!(%I(3)#4)!('(%I(3)#100)&(%I(3)+1700#400)) G 1 D I %DT["M",$G(%I(2)) S %I(2)=0 D P E I $D(%(1)) S:$D(%(3)) %(1)=$E(%(1)_"000",1,5)_%(3) S Y=+(Y_%(1)) I '$E(Y,6,7),Y["." G 1 I %DT["E" S %=Y D DD W " ("_Y_")" S Y=% I $D(%DT(0)) S %=%DT(0),%I=$S(%["-":Y,1:-Y) D:'% Z I $S(%DT["S":%,1:%\.0001/10000)+%I>0 G 1 Q S X=%(0) K %,%I,%H Q ; Z I $P("NOW",%(0))="" S %=Y E D NOW^%DTC S:%DT(0)["-" %=-% Q ; DD I $G(DUZ("LANG"))>1 S Y=$$OUT^DIALOGU(Y,"DD") Q Q:'Y S Y=$S($E(Y,4,5):$E($P($T(M)," ",$E(Y,4,5)+2),1,3)_" ",1:"")_$S($E(Y,6,7):$E(Y,6,7)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":"."_$P(Y,".",2),1:"") I Y["." S Y=$P(Y,".")_"@"_$E(Y_0,14,15)_":"_$E(Y_"000",16,17)_$S($E(Y,18,19):":"_$E(Y_0,18,19),1:"") I $D(%DT)#2,%DT["S",Y["@",$P(Y,":",3)="" S Y=Y_":00" Q ; P S Y=%I(3)_$E(%I(1)+100,2,3)_$E(%I(2)+100,2,3) Q ; MTH S %=X D % G:%I>3 1 S %I(2)=0 D TY S %I(3)=% D:$D(%(9)) PF^%DTC G D % ;I %DT["I",%?3.A S %I=9 Q I %?3.A S %=$F($T(M)," "_%) I %>0 S %=$L($E($T(M),6,%-1)," ") D:%I=1 S %("ALPHA")=1 ;ONLY MONTH IS ALPHA . N T S T=%I(1),%I(1)=%,%=T I $D(%("ALPHA")) S %I=9 S:%<1&(%'="00")&(%I'=2) %I=9 S %I=%I+1,%I(%I)=%,%="" M ;; JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER DIDTC DIDTC ;SFISC/XAK-DATE/TIME OPERATIONS ;3JAN2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; D N %T I 'X1!'X2 S X="",%Y=0 Q S X=X1 D H S X1=%H,X=X2,X2=%Y+1 D H S X=X1-%H,%Y=%Y+1&X2 K %H,X1,X2 Q ; C N %,%T,%Y S X=X1,X2=$J($G(X2),0,0) I 'X S (X,%H)="" Q D H S %H=%H+X2 D YMD S:$P(X1,".",2) X=X_"."_$P(X1,".",2) K X1,X2 Q S S %=%#60/100+(%#3600\60)/100+(%\3600)/100 Q ; H ;called from DIG, DIP4 I X<1410000 S (%H,%T)=0,%Y=-1 Q S %Y=$E(X,1,3),%M=$E(X,4,5),%D=$E(X,6,7) S %T=$E(X_0,9,10)*60+$E(X_"000",11,12)*60+$E(X_"00000",13,14) TOH N DILEAP D . N Y S Y=%Y+1700 S:%M<3 Y=Y-1 . S DILEAP=(Y\4)-(Y\100)+(Y\400)-446 Q S %H=$P("^31^59^90^120^151^181^212^243^273^304^334","^",%M)+%D S %=('%M!'%D),%Y=%Y-141 S %H=(%H+(%Y*365)+DILEAP+%),%Y=$S(%:-1,1:%H+4#7) K %M,%D,% Q ; DOW D H S Y=%Y K %H,%Y Q ; DW D H S Y=%Y,X=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",Y+1)_"DAY" S:Y<0 X="" Q ; 7 I '%H S (%,X)="" Q S %=(%H>21608)+(%H>94657)+%H-.1,%Y=%\365.25+141,%=%#365.25\1 S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1 S X=%Y_"00"+%M_"00"+%D Q ; YX ;called from DIV, etc D YMD S Y=X_% Q:Y="" G DD^%DT ; YMD ;called from DIP5. Documented entry point for converting a date/time %H in $H format into a date (in X) and time (in %) in FileMan internal format. I %H[",0" S %=%H N %H S %H=%-1_",86400" N %D,%M,%Y D 7 S %=$P(%H,",",2) D S Q ; ; T ;from %DT F %=1:1 S Y=$E(X,%) Q:"+-"[Y G 1^%DT:$E("TODAY",%)'=Y S X=$E(X,%+1,99) G PM:Y="" I X?1.N1"M" S %H=$H D MONTH G D^%DT I +X'=X D DMW S X=% G:'X 1^%DT PM S @("%H=$H"_Y_X) D TT G 1^%DT:%I(3)'?3N,D^%DT ; ; N ;from %DT F %=2:1 S Y=$E(X,%) Q:"+-"[Y G 1^%DT:$E("NOW",%)'=Y I Y="" S %H=$H D %H G RT S X=$E(X,%+1,99) I X?1.N1"H" S X=X*3600,%H=$H,@("X=$P(%H,"","",2)"_Y_X),%=$S(X<0:-1,1:0)+(X\86400),X=X#86400,%H=$P(%H,",")+%_","_X G RT I X?1.N1"'" S X=X*60,%H=$H,@("X=$P(%H,"","",2)"_Y_X),%=$S(X<0:-1,1:0)+(X\86400),X=X#86400,%H=$P(%H,",")+%_","_X G RT I X?1.N1"M" S %H=$H D %H,MONTH G RT1 D DMW G 1^%DT:'% S @("%H=$H"_Y_%),%H=%H_","_$P($H,",",2) D %H RT D TT RT1 S %=$P(%H,",",2) D S S %=X_$S(%:%,1:.24) I %DT'["S" S %=+$E(%,1,12) Q:'$D(%(0)) S Y=% G E^%DT ; ; PF ;from %DT S %H=$H D YMD S %(9)=X,X=%DT["F"*2-1 I @("%I(1)*100+%I(2)"_$E("> <",X+2)_"$E(%(9),4,7)") S %I(3)=%I(3)+X Q ; ; MONTH ;Add months to current date S Y=Y_+X D TT S %=%I(1)+Y,%I(1)=%-1#12+1,%I(3)=%I(3)+(%-$S(%>0:1,1:12)\12) S %="31^"_($$LEAP(%I(3))+28)_"^31^30^31^30^31^31^30^31^30^31" I %I(2)>$P(%,U,%I(1)) S %I(2)=$P(%,U,%I(1)) S X=%I(3)_"00"+%I(1)_"00"+%I(2) Q ; LEAP(X) ;Return 1 if leap year S:X<1700 X=X+1700 Q '(X#4)&(X#100)!'(X#400) ; TT N %M,%D,%Y D 7 S %I(1)=%M,%I(2)=%D,%I(3)=%Y Q ; NOW S %H=$H,%H=$S($P(%H,",",2):%H,1:%H-1) D TT S %=$P(%H,",",2) D S S %=X_$S(%:%,1:.24) Q ; DMW S %=$S(X?1.N1"D":+X,X?1.N1"W":X*7,X?1.N1"M":X*30,+X=X:X,1:0) Q ; %H I '$P(%H,",",2) S %H=%H-1 Q I $P(%H,",",2)<60&(%DT'["S") S $P(%H,",",2)=60 Q ; COMMA ; S %D=X<0 S:%D X=-X S %=$S($D(X2):+X2,1:2),X=$J(X,1,%),%=$L(X)-3-$E(23456789,%),%L=$S($D(X3):X3,1:12) F %=%:-3 Q:$E(X,%)="" S X=$E(X,1,%)_","_$E(X,%+1,99) S:$D(X2) X=$E("$",X2["$")_X S X=$J($E("(",%D)_X_$E(" )",%D+1),%L) K %,%D,%L Q ; ; ; HELP S DDH=$S($D(DDH):DDH,1:0),A1="Examples of Valid Dates:" D % I %DT["M" D G 0 . S A1=" "_$S(%DT["I":1.1957,1:"JAN 1957 or JAN 57")_$S(%DT'["N":" or 0157",1:"") D % . S A1=" T (for this month)" D % . S A1=" T+3M (for 3 months in the future)" D % . S A1=" T-3M (for 3 months ago)" D % . S A1="Only month and year are accepted. You must omit the precise day." D % S A1=" "_$S(%DT["I":"20.1.1957",1:"JAN 20 1957 or 20 JAN 57")_" or "_$S(%DT["I":"20/1",1:"1/20")_"/57"_$S(%DT'["N":" or "_$S(%DT["I":200157,1:"012057"),1:"") D % S A1=" T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc." D % S A1=" T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc." D % S A1="If the year is omitted, the computer " D D % . I %DT["P" S A1=A1_"assumes a date in the PAST." Q . I %DT["F" S A1=A1_"assumes a date in the FUTURE." Q . S A1=A1_"uses CURRENT YEAR. Two digit year" D % . S A1=" assumes no more than 20 years in the future, or 80 years in the past." . Q I %DT'["X" S A1="You may omit the precise day, as: "_$S(%DT["I":1,1:"JAN,")_" 1957" D % I %DT'["T",%DT'["R" G 0 S A1="If only the time is entered, the current date is assumed." D % S A1="Follow the date with a time, such as "_$S(%DT["I":"20.1",1:"JAN 20")_"@10, T@10AM, 10:30, etc." D % S A1="You may enter a time, such as NOON, MIDNIGHT or NOW." D % S A1="You may enter NOW+3' (for current date and time Plus 3 minutes" D % S A1=" *Note--the Apostrophe following the number of minutes)" D % I %DT["S" S A1="Seconds may be entered as 10:30:30 or 103030AM." D % I %DT["R" S A1="Time is REQUIRED in this response." D % 0 Q:'$D(%DT(0)) S A1=" " D % S A1="Enter a date which is "_$S(%DT(0)["-":"less",1:"greater")_" than or equal to " D % S Y=$S(%DT(0)["-":$P(%DT(0),"-",2),1:%DT(0)) D DD^%DT:Y'["NOW" I '$D(DDS) W Y,"." K A1 Q S DDH(DDH,"T")=DDH(DDH,"T")_Y_"." K A1 Q ; % I '$D(DDS) W !," ",A1 Q S DDH=DDH+1,DDH(DDH,"T")=" "_A1 Q Q DIDU DIDU ;SEA/TOAD-VA FileMan: DD Tools, External Format ;21AUG2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ; ; ; convert a value from internal to external format ; used all over lookup routines ; XTRNLX ; ; ; support for documented entry point $$EXTERNAL^DILFD ; branch from DILFD or DIQGU ; E1 ; set up DBS environment variables ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DICLERR S DICLERR=$G(DIERR) K DIERR ; E2 ; handle bad input variables ; I $G(DINTERNL)="" Q "" S DIMSGA=$G(DIMSGA) S DIFLAGS=$G(DIFLAGS) I DIFLAGS'?.1(1"F",1"L",1"U",1"i",1"h",1"A") D ERR(DIMSGA,301,"","","",DIFLAGS) Q "" I $G(DIFIELD)'>0 D ERR(DIMSGA,202,"","","","FIELD") Q "" ; E3 ; get field definition and type, handle bad file or field ; I $G(DIFILE)<0 D ERR(DIMSGA,202,"","","","FILE") Q "" N DINODE S DINODE=$G(^DD(DIFILE,DIFIELD,0)) I DINODE="" D Q "" . I '$D(^DD(DIFILE)) D ERR(DIMSGA,401,DIFILE) . E D ERR(DIMSGA,501,DIFILE,"",DIFIELD,DIFIELD) N DITYPE S DITYPE=$P(DINODE,U,2) ; E4 ; initialize loop control, transform code, pointer chain window, ; pointer file info, and resolved value variables ; N DICHAIN,DIDONE,DIOUT S (DICHAIN,DIDONE,DIOUT)=0 N DIXFORM S DIXFORM="" N DINEXT,DIPREV,DIPREVF S (DINEXT,DIPREV,DIPREVF)="" N DIEN,DIHEAD,DIROOT S DIEN="" N DIEXTRNL S DIEXTRNL="" ; E5 ; handle output transforms (see docs for effects of flags) ; under right conditions, execute output transform on value & quit ; F D I DIDONE!$G(DIERR)!DIOUT Q . I DIFLAGS["U",DIXFORM'="",DITYPE'["P",DITYPE'["V" S DITYPE=DITYPE_"O" . I DITYPE["O",DIFLAGS'["i",DIFLAGS'["h" D I DIDONE!$G(DIERR) Q . . I DIFLAGS["F",DICHAIN Q . . I DIFLAGS["L",DITYPE["P"!(DITYPE["V") Q . . I DIXFORM=""!(DIFLAGS'["U") S DIXFORM=$G(^DD(DIFILE,DIFIELD,2)) . . I DIXFORM="" Q . . I DIFLAGS["U",DITYPE["P"!(DITYPE["V") Q . . N Y S Y=DINTERNL X DIXFORM . . I $G(DIERR) D ERR^DICF4(120,DIFILE,DIEN,"","Output Transform") Q . . S DIEXTRNL=Y,DIDONE=1 . E6 . ; continue with loop only for pointers or variable pointers . . I DITYPE S DIOUT=1 Q . I DITYPE'["P",DITYPE'["V" S DIOUT=1 Q . E7 . ; if the value's not numeric, it's not valid; note that throughout . ; module we return two different errors depending on whether the . ; value passed in is bad, or one found in the pointer chain is . . I 'DINTERNL D Q . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"pointer") Q . . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"pointer") . E8 . ; get pointed to file's root and # . . I DITYPE["P" S DIROOT=$P(DINODE,U,3),DINEXT=+$P($P(DINODE,U,2),"P",2) D Q:$G(DIERR) . . I DIROOT="DIC(.2," S DINEXT=.2 . . I 'DINEXT!(DIROOT="") D ERR(DIMSGA,537,DIFILE,,DIFIELD) . . Q . I DITYPE["V" S DIROOT=$P(DINTERNL,";",2),DINEXT="" D Q:$G(DIERR) . . I DIROOT="" D ERR(DIMSGA,348,,,,DINTERNL) Q . . S DIHEAD=$G(@(U_DIROOT_"0)")) . . I DIHEAD="" D Q . . . D HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT) . . S DINEXT=+$P(DIHEAD,U,2) I 'DINEXT D Q . . . D ERR(DIMSGA,404,"","","",$$CREF^DILF(U_DIROOT)) . E9 . ; ensure pointed to data file exists, and advance file #s . . I '$D(@(U_DIROOT_"+DINTERNL)")) D Q . . N DI S DI="pointer to File #" . . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,DI_DINEXT) Q . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,DI_DINEXT) . S DIPREV=DIFILE,DIFILE=DINEXT . E10 . ; advance pointer value, file characteristics, & pointer window . ; ensure pointed to record exists, & its .01 has a DD . ; set flag that we are now in the pointer chain . . S DIEN=+DINTERNL . S DINTERNL=$P($G(^(DIEN,0)),U) ;***** Naked ***** . I DINTERNL="" D ERR(DIMSGA,603,DIFILE,"",.01,DIEN) Q . S DINODE=$G(^DD(DIFILE,.01,0)) . S DITYPE=$P(DINODE,U,2) . I DITYPE="" D ERR(DIMSGA,510,DIFILE,"",.01) Q . S DIPREVF=DIFIELD,DIFIELD=.01 . S DICHAIN=1 . S:DIFILE=.2 DIDONE=1 Q ; E11 ; exit if we executed an output transform or ran into an error ; ; Special "i" flag returns internal value at end of pointer chain I DIFLAGS["i" Q DINTERNL I DIFILE=.2 Q DINTERNL I DIDONE Q DIEXTRNL I $G(DIERR) Q "" ; E12 ; handle illegal data types (pointers, word processings, and multiples) ; I DITYPE["C" D ERRPTR("Computed") Q "" I DITYPE["W" D ERRPTR("Word Processing") Q "" I DITYPE S DITYPE=$P($G(^DD(+DITYPE,.01,0)),U,2) D Q "" . I DITYPE["W" D ERRPTR("Word Processing") Q . D ERRPTR("Multiple") Q ; E13 ; handle sets of codes ; I DITYPE["S" D Q DIEXTRNL . N DICODES S DICODES=$P(DINODE,U,3) . N DISTART S DISTART=$F(";"_DICODES,";"_DINTERNL_":") . I 'DISTART S DIEXTRNL="" D Q . . I 'DICHAIN D ERR(DIMSGA,730,DIFILE,"",DIFIELD,DINTERNL,"code") Q . . D ERR(DIMSGA,630,DIFILE,DIFIELD,"",DIEN,DINTERNL,"code") SET . S DISTART=DINTERNL D PARSET^DIQ(DICODES,.DISTART) S DIEXTRNL=DISTART ; E14 ; handle dates, and return all others as they are ; I DITYPE["D",DINTERNL D Q DIEXTRNL . S DIEXTRNL=$$DATE^DIUTL(DINTERNL) ;**CCO/NI . I DIEXTRNL'="" Q . I 'DICHAIN D ERR(DIMSGA,330,"","","",DINTERNL,"date") Q . D ERR(DIMSGA,630,DIFILE,"",DIFIELD,DIEN,DINTERNL,"date") I DICLERR'=""!$G(DIERR) D . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) Q DINTERNL ; HEADER(DIFILE,DIEN,DIFIELD,DITYPE,DICHAIN,DINTERNL,DINEXT) ; ; ; pick a header error and log it ; EXTERNAL ; I DITYPE["P" D ; pointer . I 'DINEXT!'$D(^DD(DINEXT)) D ERR(DIMSGA,537,DIFILE,"",DIFIELD) Q . D ERR(DIMSGA,403,DINEXT) ; E D ; variable pointer . I DICHAIN D ERR(DIMSGA,648,DIFILE,"",DIFIELD,DIEN,DINTERNL) Q . D ERR(DIMSGA,348,"","","",DINTERNL) Q ; ERR(DIMSGA,DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ; ; ; error logging procedure ; EXTERNAL ; I $G(DIFLAGS)["A",$$ALLOW(DIERN) S DIDONE=1 Q N DIPE,DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI)) D BLD^DIALOG(DIERN,.DIPE,.DIPE,DIMSGA,"F") S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2)) Q ; ERRPTR(DITYPE) ; ; ; error logging shell for errors 520 & 537 ; EXTERNAL ; I DICHAIN D ERR(DIMSGA,537,DIPREV,"",DIPREVF) Q D ERR(DIMSGA,520,DIFILE,"",DIFIELD,DITYPE) Q ; ALLOW(X) ;If ALLOW appears, do not call erroneous data an error N I,T F I=3:1 S T=$T(ALLOW+I) Q:T?.P I T[X Q:T'["ALLOW" K T Q Q '$D(T) ; 202 The input parameter that identifies the |1 ; 301 The passed flag(s) '|1|' are unknown or in ; 330 The value '|1|' is not a valid |2|. ALLOW ; 348 The passed value '|1|' points to a file th ; 401 File #|FILE| does not exist. ; 403 File #|FILE| lacks a Header Node. ; 404 The File Header node of the file stored at ; 501 File #|FILE| does not contain a field |1|. ; 510 The data type for Field #|FIELD| in File # ; 520 A |1| field cannot be processed by this ut ; 537 Field #|FIELD| in File #|FILE| has a corru ; 603 Entry #|1| in File #|FILE| lacks the requi ; 630 In Entry #|1| of File #|FILE|, the value ' ALLOW ; 648 In Entry #|1| of File #|FILE|, the value ' ; 730 The value '|1|' is not a valid |2| accordi ALLOW ; DIDU1 DIDU1 ;SEA/TOAD-VA FileMan: DD Tools, IENS Check ;10:39 AM 8 Jul 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; IEN(DIENS,DIFLAGS) ; ;ENTRY POINT--return whether the IEN String is valid ;extrinsic function, all passed by value I $G(DIENS)="" Q 0 I $G(DIFLAGS,"N")'="N" Q 0 S DIFLAGS=$G(DIFLAGS) N DICHAR,DICRSR,DIPIECE,DISEQ,DIOUT,DIVALID S DIPIECE="",DISEQ="",DIOUT=0,DIVALID=1 F DICRSR=1:1 D I DIOUT Q .S DIPIECE=$P(DIENS,",",DICRSR) .I DIPIECE="" D Q ..I $P(DIENS,",",DICRSR,999)="" S DIOUT=1 Q I1 ..I DICRSR=1 Q ..S DIOUT=1,DIVALID=0 ..Q .I +DIPIECE=DIPIECE S DIVALID=DIPIECE>0,DIOUT='DIVALID Q .I DIFLAGS["N" S DIVALID=0,DIOUT=1 Q .S DICHAR=$E(DIPIECE,1,2) I DICHAR'="?+" S DICHAR=$E(DICHAR) .I DICHAR'="+",DICHAR'="?",DICHAR'="?+" S DIOUT=1,DIVALID=0 Q .I $P(DIPIECE,DICHAR,2,9999)?1N.N D Q ..S DISEQ=$P(DIPIECE,DICHAR,2,999) ..S DIOUT=+DISEQ'=DISEQ!$D(DISEQ(DISEQ)),DIVALID='DIOUT Q I2 .S DIOUT=1,DIVALID=0 .Q Q $E(DIENS,$L(DIENS))=","&DIVALID ; PROOT(DIFILE,DIENS) ; ;ENTRY POINT--return the global root of a subfile's parent ;extrinsic function, all passed by value Q $$ROOT^DILFD($$PARENT(DIFILE),$P(DIENS,",",2,999),1) ; PARENT(DIFILE) ; ;ENTRY POINT--return the file number of a subfile's parent ;extrinsic function, all passed by value Q $G(^DD(DIFILE,0,"UP")) ; PARENTS(DIFILE,DIRULE) ; ;IEN--return the file's parents ;procedure, passed by ref N DIBACK,DIOUT,DIMOM,DITEMP S DIOUT=0,DIMOM=DIFILE S DITEMP=DIFILE K DIFILE S (DIFILE,DIFILE("C"))=DITEMP S DIFILE("L")=$$LEVEL(DIFILE) S DIFILE(1)=DIFILE I '$D(DIRULE("L",DIFILE)) S DIRULE("L",DIFILE)=DIFILE("L") F DIBACK=2:1 D I DIOUT Q .S DITEMP=DIMOM .S DIMOM=$G(DIRULE("UP",DITEMP)) PA1 .I DIMOM="" D I DIOUT Q ..S DIMOM=$G(^DD(DITEMP,0,"UP")) ..I DIMOM="" S DIOUT=1 Q ..S DIRULE("UP",DITEMP)=DIMOM ..I '$D(DIRULE("L",DIMOM)) S DIRULE("L",DIMOM)=DIFILE("L")-DIBACK+1 ..Q .S DIFILE(DIBACK)=DIMOM .Q Q ; LEVEL(DIFILE) ; ;IEN--return the file's level (# parents +1) ;function, pass by value N DIMOM I '$G(DIFILE) Q 0 S DIMOM=$G(^DD(DIFILE,0,"UP")) I DIMOM="" Q 1 Q $$LEVEL(DIMOM)+1 ; DIDU2 DIDU2 ;SEA/TOAD-VA FileMan: DD Tools, Header Nodes ;1:17 PM 12 Jan 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; HEADER(DIFILE,DIENS,DIMSGA) ; ;ENTRY POINT--return the value a file's Header Node should have ;extrinsic function, DIENS passed by reference I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU N DIROOT D HINPUT(.DIFILE,.DIENS,.DIMSGA,.DIROOT) I $G(DIERR) D Q "" . D CLOSE N DIHEADER S DIHEADER=$$PIECES12(DIFILE,DIROOT) I $G(DIERR) D Q "" . D CLOSE N DIRECENT S DIRECENT=$O(@DIROOT@(" "),-1) I DIRECENT="" S DIRECENT=0 N DICOUNT,DIRECORD S DIRECORD=0 F DICOUNT=0:1 S DIRECORD=$O(@DIROOT@(DIRECORD)) Q:'DIRECORD I DICOUNT>10000 S DICOUNT=$P($G(@DIROOT@(0)),U,4) Q Q DIHEADER_U_DIRECENT_U_DICOUNT ; HINPUT(DIFILE,DIENS,DIMSGA,DIROOT) ; ;evaluate input variables for HEADER call I $G(DIMSGA)'="" D . K @DIMSGA@("DIERR"),@DIMSGA@("DIHELP"),@DIMSGA@("DIMSG") S DIFILE=$G(DIFILE) I DIFILE="" D ERR(202,"","","","FILE") Q I $G(^DD(DIFILE,.01,0))="" D Q . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) Q . I '$D(^DD(DIFILE,.01)) D ERR(406,DIFILE) Q . E D ERR(502,DIFILE,"",.01) S DIENS=$G(DIENS) I DIENS="" S DIENS="," I '$$IEN^DIDU1(DIENS) D Q . I '$$IEN^DIDU1(DIENS_",") D ERR(202,"","","","IENS") Q . E D ERR(304,"",DIENS) S DIROOT=$G(DIFILE("ROOT")) I DIROOT="" D . S DIROOT=$$ROOT^DILFD(DIFILE,DIENS,1,1) Q:DIROOT'=""!$G(DIERR) . I '$D(^DD(DIFILE)) D ERR(401,DIFILE) Q . E D ERR(402,DIFILE,DIENS) Q ; PIECES12(DIFILE,DIROOT) ; ;return pieces 1 & 2 of the Header node N DIPIECE1,DIPIECE2 N DINAME S DINAME=$O(^DD(DIFILE,0,"NM","")) I DINAME="" D Q "" . D ERR(408,DIFILE) N DIPARENT S DIPARENT=$G(^DD(DIFILE,0,"UP")) ; P1 I DIPARENT'="" D ;subfile . S DIPIECE1="" . I $P(^DD(DIFILE,.01,0),U,2)["W" D Q . . D ERR(407,DIFILE) . N DIFIELD S DIFIELD=$O(^DD(DIPARENT,"B",DINAME,"")) . I DIFIELD="" D Q . . D ERR(501,DIFILE,"","",DINAME) . N DINODE S DINODE=$G(^DD(DIPARENT,DIFIELD,0)) I DINODE="" D Q . . D ERR(502,DIFILE,"",DIFIELD) . S DIPIECE2=$P(DINODE,U,2) I DIPIECE2="" D Q . . D ERR(502,DIFILE,"",DIFIELD) ; P2 E D ;root file . S DIPIECE1=DINAME . S DIPIECE2=DIFILE_$$CODES(DIFILE,DIROOT) I $G(DIERR) Q I $G(DIERR) Q "" Q DIPIECE1_U_DIPIECE2 ; CODES(DIFILE,DIROOT) ; ;collect the file characteristics codes N DIFIELD S DIFIELD=$P($G(^DD(DIFILE,.01,0)),U,2) I DIFIELD="" D Q "" . I '$D(^DD(DIFILE,.01)) D ERR(501,DIFILE,"","",.01) Q . E D ERR(510,DIFILE,"",DIFIELD) N DICODES S DICODES="" N DITYPE F DITYPE="D","S","P","V" I DIFIELD[DITYPE S DICODES=DITYPE Q I $D(^DD(DIFILE,0,"ID")) S DICODES=DICODES_"I" I $D(^DD(DIFILE,0,"SCR"))#2 S DICODES=DICODES_"s" N DINODE S DINODE=$G(@DIROOT@(0)) I $P(DINODE,U,2)["A" S DICODES=DICODES_"A" I $P(DINODE,U,2)["O" S DICODES=DICODES_"O" Q DICODES ; CLOSE D CALLOUT^DIEFU($G(DIMSGA)):$G(DIMSGA)'="" Q ; ERR(DIERN,DIFILE,DIIENS,DIFIELD,DI1,DI2,DI3) ; ;log an error N DIPE N DI F DI="FILE","IENS","FIELD",1:1:3 S DIPE(DI)=$G(@("DI"_DI)) D BLD^DIALOG(DIERN,.DIPE,.DIPE) Q DIDX DIDX ;SFISC/XAK-BRIEF DD ;25SEP2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S D1=D0,DINM=1,DDRG=1,DDL1=14,DDL2=32 G B ; L S DJ(Z)=0 A I DIDX D G:D1>0 A:^DD(F(Z),"B",DJ(Z),D1) . S DJ(Z)=$O(^DD(F(Z),"B",DJ(Z))) S:DJ(Z)="" D1="" Q:DJ(Z)="" S D1=$O(^(DJ(Z),0)) . Q E S (D1,DJ(Z))=$O(^DD(F(Z),DJ(Z))) I D1'>0 W ! S Z=Z-1 Q B I $D(DIGR),D1-.01!'DID X DIGR E G END S N=^DD(F(Z),D1,0) D HD:$Y+9>IOSL Q:M=U W !!?Z+Z-2,$P(N,U,1),?30,S,F(Z),",",D1,S,S S X=$P(N,U,2) I X W ?M,$J(+X,8) I $D(^DD(+X,.01,0)),$P(^(0),U,2)["W" W " WORD-PROCESSING" S X="" W ?M,S,S F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","VARIABLE POINTER","K","p","m" I X[$E(W) S:W="K" W="MUMPS" S:W="p" W="POINTER" S:W="m" W="MULTIPLE" D W1 I X["V" D VP0 I 'X D .N Y,NM S:X["P" Y=U_$P(N,U,3),NM=+$P(X,"P",2) I X["C" S NM=+$P(X,"p",2) I NM S Y=$G(^DIC(NM,0,"GL")) .Q:'$D(Y) I Y[U,$D(@(Y_"0)")) S W="TO "_$P(^(0),U)_" FILE (#"_NM_")" .E S W="***** TO A FILE THAT IS UNDEFINED *******" .D W1 T ; S W=0 H ; W ! I $D(^DD(F(Z),D1,.1))#2 W ?(Z*2),^(.1)," ",?M I X["S" S N=$P(N,U,3) F I=1:1 S Y=$P(N,";",I) Q:Y="" S W="'"_$P(Y,":")_"' FOR "_$P(Y,":",2)_";" W ?M," "_W,! I $D(^DD(F(Z),D1,3))#2 S W=^(3) W ?M D W1 RD ; I X S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X,W=" Multiple" D W1,L END S X="" G:M'=U A:Z>1 Q ; W1 W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5IOSL HD Q ; HD S DC=DC+1 D ^DIDH Q VP ;Variable Pointer W ?50,W S D1=DJ(Z) VP0 I '$D(^DD(F(Z),D1,"V",0)) S W="" Q S DID1=0,DIMU=0,DID2=0 I '$D(DDRG) D RT S W="FILE ORDER PREFIX LAYGO MESSAGE" W !?(Z+Z+12),W G Q:M=U VP1 S DID2=$O(^DD(F(Z),D1,"V",DID2)) S:DID2="" DID2=-1 G:DID2'>0 VP2 S DIDV=^(DID2,0) I '$D(^DIC(+DIDV,0)) S DIDV(+DIDV)="" S DIVP=$P(DIDV,U),DDLF=(Z+Z+15) I $L(DIVP)>4 W !?(DDLF-$L(DIVP))+1,DIVP E W !?DDLF,DIVP W ?(DDLF+5),$P(DIDV,U,3),?(DDLF+10),$P(DIDV,U,4),?(DDLF+23),$P(DIDV,U,6) S DDL3=DDL2,DDL2=DDLF+27,W=$P(DIDV,U,2) D W1^DIDH1 S DDL2=DDL3 S:$P(DIDV,U,5)["y" DIMU=1 D:$Y+4>IOSL HD G ND^DID1:M=U,VP1 VP2 I DIMU S DIDVI=0 F S DIDVI=$O(^DD(F(Z),D1,"V",DIDVI)) Q:DIDVI'>0 I $D(^(DIDVI,1)) S %=^(0) D VP3 Q:M=U S DIDV=0 F S DIDV=$O(DIDV(DIDV)) Q:DIDV'>0 S W="!! FILE "_DIDV_" DOES NOT EXIST !!" D W^DID1 Q:M=U Q W ! K DID2,DIMU,DID1,DIDV,DIDVI S W="" Q VP3 ; W !?(Z+Z+12),"SCREEN"_$S('$D(DINM):" ON FILE "_$P(%,U)_":",1:" EXPLANATION ON FILE "_$P(%,U)_":") S W=" "_$S('$D(DINM):^(1),1:$S($D(^(2)):^(2),1:"")) D W^DID1:'$D(DINM),W^DIDH:$D(DINM) Q RT F W="Required","Add New Entry without Asking","Multiply asked","audited" I X[$E(W,1) S W=" ("_W_")" W:($L(W)+$X)'0 K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D . N % . F %=1:1 Q:'$G(DA(%)) S DIEDA(%)=DA(%) . S DIEDA=DA . Q I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE") N DIEFXREF,DIIENS,DIE1,DIE1N K DIEFIRE,DIEBADK,DIESP S DIIENS=$$IENS^DIKCU(DP,.DA) S DL=1,DIE1=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17 S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S") MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR S DI=$P(DH,":",1) I 'DI G K:DI=0,PB J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH="" G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,DZ=^(0),DIFLD(DQ)=DI S $P(DZ,U)=$$LABEL^DIALOGZ(DP,DI) ;PROMPT FIELD NAME SPC F %=1:1 S DIESP=$P(Y,$C(126),%) Q:DIESP="" D .I DIESP="d"!(DIESP="R") S $P(DZ,U,2)=$P(DZ,U,2)_DIESP Q .I DIESP="T"!(DIESP="t") S:$G(^DD(DP,DI,.1))]"" $P(DZ,U)=^(.1) Q .S $P(DZ,U)=DIESP,DQ(DQ,"CAPTION")=DIESP S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ G Y ; K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM S I DQ'<50,'$D(DE(DQ+1)) G H S DQ=DQ+1,DQ(DQ)=$$LABEL^DIALOGZ(DP,DI)_U_$P(^DD(DP,DI,0),U,2,99),DIFLD(DQ)=DI ;FIELD NAME Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1) ;Determine whether field has a xref defined in the Index file S DIEXREF=0 F S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1 S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2) I S:DE="" DE=-1 I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1) S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG) I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y) E S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y EQ G MR:DI=DM,NX:DM S DM=DB K DB G D ; INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))" Q Q ; ; MORE ;from ^DIE1 D INI G MR:DI=DM,NX:DI'[U,MR:'$D(^DD(DP,+DI)) S %=$P(DI,U,2),DI=+DI S:%]"" DQ(DQ+1,"CAPTION")=% G S ; ; JMP ;from ^DIE0 D INI G J ; PB I DH="" G D:$D(DR(DIE1,DP))<9 S:'$D(DOV) DOV=0,DR(DIE1,DP)=DR S DOV=$O(DR(DIE1,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DIE1,DP,DOV),DK=0 G MR G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) D DIE1N G O^DIE0 E S DK=DK-1,(DI,DM)=1 D G DQ^DIED ; H S DI=DI_U G D ;Multiple field M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9 I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U) ;HMMM E S D=$O(^(0)) S:D="" D=-1 DE I D>0 S Y=Y_U_D I DP(0)-Y!($P(DP(0),U,2)-DK),$D(^(+D,0)) S DE(DQ)=$P(^(0),U) ;Default value if this isn't same multiple we were down in before DC S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0) MUL I $P(Y,U,2)'["W" S DQ(DQ)=$P($$EZBLD^DIALOG(8042,$G(DQ(DQ,"CAPTION"),$$LABEL^DIALOGZ(+$P(%,U,2),.01))),": ")_U_1_$P(Y,U,2,99) D DIE1N G D ;MULTIPLE-FIELD LABEL I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H D .Q:DH'[$C(126) .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R") .I DIEA="T"!(DIEA="t") S:$D(^DD(+$P(%,U,2),.01,.1)) DQ(DQ,"CAPTION")=^(.1) Q .S DQ(DQ,"CAPTION")=DIEA DIWE S Y=$G(DQ(DQ,"CAPTION"),$$LABEL^DIALOGZ(DP,DI))_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE ;WORD-PROCESSING FIELD LABEL ; D1 Q:D'>0 S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1 ; DIE1N N M,I S DIE1N="" F I=DK,DK+1 S M=$P(DR,";",I) I M?1"^"1.NP S DIE1N=$P(M,U,2) S:I>DK DK=DK+1 Q ;WPB-0804-30857 Q ; ; B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ ; TEM K:$D(DIETMP)#2 @DIETMP,DIETMP S Y=0 F S Y=$O(^DIE("B",$P($E(DR,2,99),"]"),Y)) G Q:Y="",Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU") S:$D(^("W")) DIE("W")=^("W") S DIE("^")=DR K DR S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR S DR=$G(^DIE(Y,"DR"),DR(1,DP)) D DIE K DR S DR=DIE(U) Q ; ;Silent call concerning editing and filing of data. ; FILE(DIEFFLAG,DIEFAR,DIEFOUT) ; G FILEX^DIEF ; WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ; G WPX^DIEFW ; HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ; G GETX^DIEH ; VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ; G VALX^DIEV ; KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ; G KEYVALX^DIEVK ; VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ; G VALSX^DIEVS ; CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ; G CHKX^DIEV ; UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD ; ENTRY POINT--update database ; procedure, all passed by value G ADDX^DICA ; DIE0 DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;23DEC2005 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. G Q^DIE1:$D(DTOUT) G:X'?1"^".E T^DIED:$P($P(DQ(DQ),U,4),";E",2),X I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,$$EZBLD^DIALOG(3095) G X ;** I $D(DIE("NO^")),X?1"^"1E.E,DIE("NO^")'["BACK" W !?3,$$EZBLD^DIALOG(3096) G X ;** I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE0 S X=$P(X,U,2),DIC(0)="E" OUT I X=""!(DP<0) S DIK=X,DC=$S($D(DQ(DQ))#2:$P(DQ(DQ),U,4),1:DQ) G OUT^DIE1 I DR]"" G A:X?1"@".N S DIC("S")="D S^DIE0" S:'$D(DR(DIE1,DP)) DR(DIE1,DP)=DR S DDBK=0,DIC="^DD("_DP_"," D ^DIC I Y>0 D S E W:DDBK !?3,$$EZBLD^DIALOG(3097) K DTOUT,DIC,DDBK,DDFND,DDONE,A0,A1,A2 I Y<0 S DG=DK,DH=":"_DM G X S DI=$S(DH[":":+Y,1:DH),DK=DG D ^DIE1:$D(DG)>9 K DG,DB,DE,DQ,DIFLD S DQ=0 G JMP^DIE X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G B^DIED:'$D(DB(DQ)),B^DIE1 ; BR ;From ^DIED S Y=U,X=$G(X) X DQ(0,DQ) D:$D(DIEFIRE)#2 FIREREC^DIE1 G A^DIED:$D(Y)[0,A^DIED:Y=U S D=$S(+Y=Y:9999,1:DQ),X="" I 0[Y S DQ=0 G OUT ;MAKE SURE 'X' EXISTS, AFTER W-P D S D=D+1 I '$D(DQ(D)) G D:$D(DQ(0,D)) S DQ=9999,X=Y,DIC(0)="FO" G OUT G D:$P(DQ(D),Y,1)]"" S DQ=D G RE^DIED ; O ;From ^DIE K DQ S (DI,DV,DM)=0 I X]"",$D(@(U_$P(DC,U,3)_X_",0)"))#2 D S^DIE1,DIEC S DQ=0 G MORE^DIE ; DIEC S DIE=U_$P(DC,U,3),DIEC(DL)=DA F %=1:1 Q:'$D(DA(%)) S DIEC(DL,%)=DA(%) K DA,DB,DE,DG F %=0:1:DIEL-1 S DA="D"_%,DIEC(DL,0,%)=@DA K @DA S:$D(DIETMP)#2 DIEC(DL,"IENS")=DIIENS,DIIENS=X_"," S DIEL=0,(D0,DA)=X Q ; DIEZ ; I X="" G @("A"_U_DNM) S D=0,DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ,DIEL=DIEL+1 D DIEC G @DGO ; A I $D(DR(DIE1,DP))>9 D OA ;Branching to "@N" E F DG=1:1 S DH=$P(DR(DIE1,DP),";",DG) G X:DH="" I DH=X S:$D(DOV) DOV=0 S DR=DR(DIE1,DP) Q S DK=DG,DI=X D ^DIE1 G JMP^DIE OA S %=0 F S %=$O(DR(DIE1,DP,%)) Q:%="" F DG=1:1 S DH=$P(DR(DIE1,DP,%),";",DG) Q:DH="" I DH=X S DR=DR(DIE1,DP,%),DOV=%,%=9999 Q S %=-1 Q ; E ;UNEDITABLE & DINUM fields I X="@" Q:DV'["I" G NO Q:X[U!(X?."?")!DV!$D(DITC) NO W:'$D(DB(DQ)) $C(7)," NO EDITING!!" K X Q Q ; ; ; S ;SCREEN fields; out= $T N DDR S (%,DDFND)=0,DDR=DR(DIE1,DP),DDBK=0,Y=+Y I $D(DIE("NO^")),DIE("NO^")["BACK" S DDBK=1 D S1 I DDFND Q I 'DDONE,$D(DR(DL,DP))>9 F %=-1:0 S %=$O(DR(DIE1,DP,%)) Q:%="" S DDR=DR(DIE1,DP,%) D S1 Q:DDONE!DDFND Q S1 ;selectable? S DDONE=0 F DG=1:1 D S2 Q:DDFND!DDONE!(DH="") I DDFND S DOV=%,DR=$G(DR(DIE1,DP,%),$G(DR(DIE1,DP))) Q S2 ;parse for ;-piece S DH=$P(DDR,";",DG) Q:(DH["///"&(DIC(0)'["F"))!'DH ;list I 'DDBK,+DH=Y S DDFND=1 Q I DDBK,+DH=DIFLD,+DH'=Y S DDONE=1 Q I DDBK,+DH=Y S DDFND=1 Q Q:$P(DH,"//")'[":" ;range S A0=+$P(DH,":",1),A1=+$P(DH,":",2) I 'DDBK,Y'A1 S DDFND=1 Q F A2=A0-.000001:0 S A2=$O(^DD(DP,A2)) Q:A2>A1!'A2 S:A2=DIFLD&(A2'=Y)&DDBK DDONE=1 Q:DDONE I A2=Y,(A2'>DIFLD) S DDFND=1 Q Q DIE1 DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;28MAY2008 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))" Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";")=DU I DU'<0 S ^(DU)=DV,DU=-2 G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU) DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y PC S $P(DV,"^",DW)=DG(DQ) G Y ; IX S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2) S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1) D:$D(DIEFXREF) FIREFLD E1 K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q ; B ; I '$D(DB(DQ)) S X="?BAD" G ^DIEQ S DC=DQ,DIK="",DL=1 OUT ; D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY ; E ; I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1 Q K Y QY I $D(DTOUT),$D(DIEDA) D . N % K DA . F %=1:1 Q:'$D(DIEDA(%)) S DA(%)=DIEDA(%) . S DA=DIEDA . Q K:$D(DTOUT) DG,DQ I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS,DIE1,DIESP K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q ; M ; S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$P($P(DQ(DQ),U)," ",2,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2) E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1 K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX") DIC S D="B",DLAYGO=DP\1,X=DD D K DIC("PTRIX") .N DIETMP,DICR D X^DIC I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1 S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1 ; DOWN D S,DIE1,DDA S DIE=DIC Q ; S ;CALLED BY O+1^DIE0 S DIOV(DL)=$G(DOV,0) K DOV S DIE1N(DL)=$G(DIE1N),DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U_$G(DQ(DQ,"CAPTION"))),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR S DM(DL)=DM,DK=0,DIE1(DL)=DIE1,DL=DL+1,DIE1=$S($G(DIE1N):DIE1N,1:DL),DIEL=DIEL+1,DM=9999999,DR="" I $D(DR(DIE1,DP)) S DM=0,DR=DR(DIE1,DP) Q ; DDA N T,X S T=$T F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X) K DA(1) S:$D(DA)#2 DA(1)=DA S DIC=DIE_DA_","""_$P(DC,U,3)_"""," S:$D(DIETMP)#2 DIIENS=","_DIIENS I T Q ; UDA N T,X S T=$T S DA=$G(DA(1)) ;K DA(1) F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X) S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999) I T Q N ; D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA D1 S @("D"_DIEL)=DA G G MORE^DIE ; UP ; Q:$D(DTOUT) S DP(0)=DP_U_DK(DL-1) I $D(DIEC(DL)) D DIEC G U U1 D UDA S DIEL=DIEL-1 U S DQ=0,DL=DL-1,DIE1N=DIE1N(DL),DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL),DIE1=DIE1(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL) G G ; DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%)) S DA(%)=DIEC(DL,%) F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL)) S @("D"_DIEL)=DIEC(DL,0,DIEL) S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS") S DIEL=DIEL-1 K DIEC(DL) Q ; FIREFLD ;Fire field-level xrefs stored in DIEFXREF D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A")) K DIEFXREF Q ; FIREREC ;Fire record-level xrefs accumulated in ^TMP Q:$D(DIETMP)[0 Q:$D(@DIETMP@("R"))<2 N DP,DIIENS,DIE,DA,DIKEY,Y ; S DP=0 F S DP=$O(@DIETMP@("R",DP)) Q:'DP D . S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D .. D DA^DILF(DIIENS,.DA) .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A")) ; ;If any keys are invalid, restore values D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP) ; K DIEFIRE,@DIETMP@("R"),@DIETMP@("V") Q ; RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values N DA K DIEBADK S:$D(DIEFIRE)#2 X="BADKEY" ; ;Set "write" and "restore" flags N DIEWR,DIEREST I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1 E S DIEWR=0 I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0 E S DIEREST=1 I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q ; N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA N DINEW,DIOLD,DIRFIL,X ; ;Loop through all keys that are not unique and build FDA K DIEFDA S DIRFIL=0 F S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL D . S DIEKK=0 F S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK D .. Q:$D(^DD("KEY",DIEKK,0))[0 .. K DIFLD .. S DIFLDI=0 F S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI D ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2) ... Q:'DIFLD!'DIFIL ... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL) .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS="" D ... S DIFIL=0 F S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL D .... S DIFLD=0 F S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD D ..... Q:$D(^DD(DIFIL,DIFLD,0))[0 ..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999) ..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/")) S DIOLD=^("F") ..... K DA D DA^DILF(DIIENSA,.DA) ..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X="" X X S DINEW=X ..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD ..... I DIEWR!($G(DIEFIRE)["L") D ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW ; I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST) ; I $G(DIEFIRE)'["L" K DIEBADK Q DIE17 DIE17 ;SFISC/GFT-COMPILED TMPLT UTIL ;03:47 PM 13 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. I $D(DTOUT) S X="" G OUT G:$A(X)-94 X:'$P(DW,";E",2),@("T^"_DNM) I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " S D="" G X I $D(DIE("NO^")),X?1"^"1.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " S D="" G X I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE17 S X=$P(X,U,2),DIC(0)="E" G OUT Z ; S DL=1,X=0 OUT ; I 0[X S DM=DW D FILE G ABORT:DL=1,R S DIC="^DD("_DP_"," G OJ:'$D(^DIE(DIEZ,"AB")) S DIEZAB=$S(DL=1:U,1:DNM(DL,0)_U_DNM(DL)) I X?1"@".N,$D(^("AB",DIEZAB,X)) S DNM=^(X) G JMP S DDBK=0 I $D(DIE("NO^")),DIE("NO^")["BACK" D DR S DDBK=1,DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)) D S^DIE0" E S DIC("S")="I $D(^DIE(DIEZ,""AB"",DIEZAB,Y)),DIC(0)[""F""!'$D(^(Y,""///""))" S DIC="^DD("_DP_"," D ^DIC S DIC=DIE I Y<0 S D="" W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED " I DDBK K DR S DR(1,DP)=^DIE(DIEZ,"ROU"),DR=DI K A0,A1,DDBK,DIC,DTOUT G X:Y<0 S DNM=^DIE(DIEZ,"AB",DIEZAB,+Y) JMP K DIEZAB D FILE S Y=DNM,DNM=$P(Y,U,2),DQ=+Y,D=0 D @("DE^"_DNM) G @Y ; OJ I X?1"@".N,$D(^DIE("AF",X,DIEZ)) S DNM=^(DIEZ) E S DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ)),DIC(0)[""F""!'$D(^(DIEZ,""///""))" D ^DIC K DIC S DIC=DIE G X:Y<0 S DNM=^DIE("AF",DP,+Y,DIEZ) G JMP F ; S DC=$S($D(X)#2:X,1:0) D FILE S X=DC Q FILE ; K DQ Q:$D(DG)<9 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))" Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU I DU'<0 S ^(DU)=DV,DU=-2 G E1:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU) DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y PC S $P(DV,U,DW)=DG(DQ) G Y ; IX D:$D(DE(DQ))#2 @DE(DQ) K K DE(DQ) E1 S DQ=$O(DE(" ")) I DQ'="" G IX:$D(DG(DQ)),K K DG,DE,DIFLD S DQ=0 Q 1 ; D FILE R D UP G @("R"_DQ_U_DNM) ; UP S DNM=DNM(DL),DQ=DNM(DL,0) K DTOUT,DNM(DL) I $D(DIEC(DL)) D DIEC^DIE1 G U S DIEL=DIEL-1,%=2,DA=DA(1) K DA(1) DA I $D(DA(%)) S DA(%-1)=DA(%) K DA(%) S %=%+1 G DA S DIIENS=$P(DIIENS,",",2,999) U S DL=DL-1 Q ; X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G Z:$D(DB(DQ)) B G @(DQ_U_DNM) N ; D DOWN S DA=$P(DC,U,4),$P(DIIENS,",")=DA,D=0 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA D1 S @("D"_DIEL)=DA G @(DGO) M ; S DD=X D DOWN S DO(2)=$P(DC,"^",2),DO=DOW_"^"_DO(2)_"^"_$P(DC,"^",4,5),DIC(0)="LM"_$S($D(DB(DNM(DL,0))):"X",1:"QE") I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2) E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1 K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX") K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC K DIC("PTRIX") I Y>0 S DA=+Y,$P(DIIENS,",")=DA,X=$P(Y,U,2),D=$P(Y,U,3) G D1 D UP G @(DQ_U_DNM) ; DOWN S DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ D FILE F %=DL+1:-1:1 I $D(DA(%)) S DA(%+1)=DA(%) S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_""",",DIEL=DIEL+1,DIIENS=","_DIIENS Q ABORT D E S Y(DM)="" Q 0 ; D FILE E D FIREREC K:$D(DIEZTMP)#2 @DIEZTMP K DIP,Y,DE,DOW,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB,DIEL,DGO,DICRREC Q DR ; N F,DA I $E(DR)="[" S %X="^DIE(DIEZ,""DR"",",%Y="DR(" D %XY^%RCR S DR=DR(DL,DP) Q S F=0 D DICS^DIA F DDW=1:1 S DDW1=$P(DR,";",DDW) Q:DDW1="" I $D(^DD(DI,+DDW1,0)),+$P(^(0),U,2)!(DDW1[":") S X=+DDW1,D(F)=+$P(DDW1,":",2) S:'D(F) D(F)=X D RANGE^DIA1 K DDW,DDW1 Q ; FIREREC ;Fire the record level xrefs Q:'$D(DIEZRXR)&$S($D(DIEZTMP)#2:'$D(@DIEZTMP@("R")),1:1) N DA,DIE,DIEZXR,DIIENS,DIKEY,DP ; S DP=0 F S DP=$O(DIEZRXR(DP)) Q:'DP D . S DIIENS=" " F S DIIENS=$O(DIEZRXR(DP,DIIENS)) Q:DIIENS="" D .. S DIE=DIEZRXR(DP,DIIENS) .. D DA^DILF(DIIENS,.DA) .. S DIEZXR=0 F S DIEZXR=$O(DIEZRXR(DP,DIEZXR)) Q:DIEZXR'=+DIEZXR D ... I $D(DIEZAR(DP,DIEZXR))#2 N DIEXEC S DIEXEC="K" D @DIEZAR(DP,DIEZXR) ; ;Fire record level indexes for triggered fields not in the template S DP=0 F S DP=$O(@DIEZTMP@("R",DP)) Q:'DP D . S DIIENS=" " F S DIIENS=$O(@DIEZTMP@("R",DP,DIIENS)) Q:DIIENS="" D .. D DA^DILF(DIIENS,.DA) .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIEZTMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A")) ; ;If any keys are invalid, restore values D:$D(DIKEY)>9 RESTORE^DIE1(.DIKEY,DIEZTMP) ; K DIEFIRE,DIEZRXR,@DIEZTMP@("V") Q ; ;=========== ; $$UNIQUE ;=========== ;Called from compiled routine. ;Look at actual (untruncated) values in the matching indexes. ;Return 1 if unique. ;In: ; DIUIR = Root of matching uniqueness index ; DISETX = Entry point to set X array ; DIMAXL(order#) = max length of subscript with order # ; UNIQUE(X,DA,DIUIR,DISETX,DIMAXL) ; N DIDASV,DIIENS,DIIENSC,DINDX,DINS,DIUNIQ,DIXSV,I,O ; M DIDASV=DA,DIXSV=X S DIIENSC=$$IENS(.DA) ; S DIUNIQ=1,DINS=$QL(DIUIR),DINDX=DIUIR F S DINDX=$Q(@DINDX) Q:$NA(@DINDX,DINS)'=DIUIR D Q:'DIUNIQ . ;Set DA array, quit if this is index for current record . S DIIENS=$E(DINDX,$L(DIUIR)+1,$L(DINDX)-1),L=$L(DIIENS,",") . S DA=$P(DIIENS,",",L) F I=1:1:L-1 S DA(I)=$P(DIIENS,",",L-I) . S DIIENS=$$IENS(.DA) Q:DIIENS=DIIENSC . I '$D(DIMAXL) S DIUNIQ=0 Q . ; . ;Set the X array for the indexed record and compare . D @(DISETX_"(""ONFILE"")") . S O=0 F S O=$O(DIMAXL(O)) Q:'O Q:X(O)'=DIXSV(O) . S:'O DIUNIQ=0 ; K DA,X M DA=DIDASV,X=DIXSV Q DIUNIQ ; UNIQFERR ;The field is part of a key and is not unique I '$D(ZTQUEUED),'$D(DDS) D . W $C(7)_"??" . W:'$D(DB(DQ)) !," ",$$EZBLD^DIALOG(3094) K DIEFXREF S ^("N")=@DIEZTMP@("V",DP,DIIENS,DIFLD,"O") G:$D(DB(DQ)) Z S X="?BAD" G @("QS^"_DNM) ; IENS(DA) ;Return IENS from DA array N I,IENS S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_"," Q IENS ; TRIG ;Save info for record level indexes on a triggered field. ;Called by DICR (via @DICRREC) N DIE,DIE17RXR,OLD,XR S OLD=DIU ; ;Get record level indexes on triggered field D LOADFLD^DIKC1(DIH,DIG,"KS","",$NA(@DIEZTMP@("V")),"","DIE17RXR","",.RLIST,"f") Q:RLIST="" ; S DIE=$$OREF^DILF($NA(@$$FROOTDA^DIKCU(DIH))) I $D(^DIE("AF",DIH,DIG,DIEZ)) D . N N,PC,RL,XR . S RL=RLIST . F D Q:RL="" .. F PC=1:1:$L(RL,U) S XR=$P(RL,U,PC) S:XR DIEZRXR(DIH,XR)="" .. S N=$G(N)+1,RL=$G(RLIST(N)) . S DIEZRXR(DIH,DICRIENS)=DIE E M @DIEZTMP@("R")=DIE17RXR S @DIEZTMP@("R",DIH,DICRIENS)=DIE ; ;Save the old value of the field S @DIEZTMP@("V",DIH,DICRIENS,DIG,"O")=OLD S:$D(^("F"))[0 ^("F")=OLD Q DIE2 DIE2 ;SFISC/GFT,XAK-DELETE AN ENTRY ;12:37 PM 20 Feb 2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D F,DL Q:$D(DTOUT) G B^DIED:Y=2,A^DIED:Y,UP^DIE1:DL>1,Q^DIE1 ; F S D=$P(DQ(DQ),U,4) S:DP+1 D=DIFLD Q ; Z S DIEZFLAG=1 D DL K DIEZFLAG S DU="" I Y=2 G @(DQ_U_DNM) I Y D:$G(DE(DW,"INDEX")) SAVEVALS^@DNM G @("A^"_DNM) G R^DIE9:DL>1,E^DIE9 DL ; S %=DP,X=D,Y=$P(DQ(DQ),U,4)="0;1" G X:$D(DE(DQ))[0,X:DV["R"&'Y,X:$D(^DD("KEY","F",DP,D))&'Y,S:DP<0,DD:DUZ(0)="@" I DV S %=+$P(DC,U,2),X=.01 G DD:DP<2 I $D(DIDEL),DIDEL\1=(DP\1) G DD I Y,$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) G DD:$D(^DD(DP,0,"UP"))!DV,DAR:'$S($D(^VA(200,DUZ,"FOF",DP)):1,1:$D(^DIC(3,DUZ,"FOF",DP))),DAR:'$P(^(DP,0),U,3),DD I Y,$D(^DIC(%,0,"DEL")) S X=^("DEL") E G DD:'$D(^DD(%,X,8.5)) S X=^(8.5) G DD:X="" F %=1:1:$L(X) G DD:DUZ(0)[$E(X,%) DAR D ;**CCO/NI "DELETE ACCESS REQUIRED" thru next 5 lines .N IN,OUT .S IN(1)=$$LABEL^DIALOGZ(DP,DIFLD),IN(2)=$$FILENAME^DIALOGZ(DP) .D BLD^DIALOG(712,.IN,,"OUT"),EN^DDIOL(.OUT) X I $D(DB(DQ)) D N G A W:$D(^DD("KEY","F",DP,D))!(DV["R")&'$D(DIER) " ",$$EZBLD^DIALOG(8041) G R ;This is a required response. Enter '^' to exit ; ; DD G MD:DV S DH=0,DU=0 F S DH=$O(^DD(DP,D,"DEL",DH)) Q:DH="" I $D(^(DH,0)) X ^(0) Q:$D(DTOUT) G X:$T ;IF SWITCH ON MEANS NO DELETION ALLOWED CC ;CONSISTENCY CHECK WOULD GO HERE S DH=-1,X=DQ(DQ) I Y,$E(@(DIE_"0)"))'=U S X=^(0) D D G R:X I Y D FIREREC(DP) S X=DE(DQ) D DEL:$D(DIU(0)) K DE,DG,DQ,DB S DIK=DIE D ^DIK S Y=0 K:DL<2 DA Q S S X="",DG($P(DQ(DQ),U,4))="" D:'$G(DIEZFLAG) LOADXR^DIED A S Y=1 Q ; D I $D(DB(DQ)) S X=0 Q W $C(7),!?3,"SURE YOU WANT TO DELETE" I Y W " THE ENTIRE " W:DV'["D"&(DV'["P")&(DV'["V") "'"_DE(DQ)_"' " W $P(X,U,1) S %=0,X=0 D YN^DICN Q:%=1 S X=1 W:$X>55 !?9 N I $D(DE(DQ))#2,'$D(DDS) W:'$D(ZTQUEUED) $C(7)," " Q ; MD G X:DV["R"&($P(DC,U,5)=1) S DH=0,DU=0 F S DH=$O(^DD(+$P(DC,U,2),.01,"DEL",DH)) Q:DH="" I $D(^(DH,0)) D DDA X ^(0) D UDA G X:$T S DH=-1,Y=DC>1,X=$E(DQ(DQ),8,99) D D I 'X D DDA D FIREREC(+$P(DC,U,2)) S DIK=DIC D ^DIK,UDA K DE(DQ) S X=$P(@(DIK_"0)"),U,3,4),DC=$P(DC,U,1,3)_U_X,DIC=DIE S:$D(^(+X,0)) DE(DQ)=$P(^(0),U,1) R S Y=2 Q ; DDA N T,X S T=$T F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X) S:$D(DA)#2 DA(1)=DA S DIC=DIE_DA_","""_$P(DC,U,3)_""",",DA=$P(DC,U,4) S:$D(DIETMP)#2 DIIENS=DA_","_DIIENS I T Q ; UDA N T,X S T=$T S DA=$G(DA(1)) ;K DA(1) F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X) S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999) I T Q QS ; G ^DIEQ QQ ; G QQ^DIEQ Q DEL I '$S($D(^VA(200,"AFOF",DA)):1,1:$D(^DIC(3,"AFOF",DA))) Q S DA(1)="",DIFOF=DA F P=0:0 S DA(1)=$S($D(^VA(200,"AFOF")):$O(^VA(200,"AFOF",DA,DA(1))),1:$O(^DIC(3,"AFOF",DA,DA(1)))) Q:'DA(1) I $S($D(^VA(200,DA(1),"FOF",DA)):1,1:$D(^DIC(3,DA(1),"FOF",DA))) S DIK=$S($D(^VA(200)):"^VA(200,",1:"^DIC(3,")_DA(1)_",""FOF""," D ^DIK K DA S DA=DIFOF K DIFOF Q V ; G ^DIE3 ; FIREREC(DIFILE) ;Fire record-level xrefs accumulated in ^TMP for file ;or subfile DIFILE and all its subfiles G:$G(DIEZFLAG) FIRERECZ Q:$D(DIETMP)[0 Q:$D(@DIETMP@("R"))<2 ; ;If we're at top level, fire all accumulated record-level xrefs N X,Y I '$G(^DD(DIFILE,0,"UP")) D FIREREC^DIE1 Q ; ;Save the DA array and DIIENS N DASV,DIIENSSV M DASV=DA S DIIENSSV=DIIENS ; ;Get list of subfiles under DIFILE N DA,DIE,DIFLIST,DIIENS,DIPAT,DP D SUBFILES^DIKCU(DIFILE,.DIFLIST) S DIFLIST(DIFILE)="" S DIPAT=".E1"""_DIIENSSV_"""" ; ;Fire record-level cross references DIFILE and its subfiles S DP=0 F S DP=$O(DIFLIST(DP)) Q:'DP D . Q:'$D(@DIETMP@("R",DP)) . S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D .. Q:DIIENS'?@DIPAT .. S DIE=@DIETMP@("R",DP,DIIENS) .. D DA^DILF(DIIENS,.DA) .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F") .. K @DIETMP@("R",DP,DIIENS),@DIETMP@("V",DP,DIIENS) . K:'$D(@DIETMP@("V",DP)) @DIETMP@("R",DP) Q ; FIRERECZ ;Come here from FIREREC above, for compiled templates Q:'$D(DIEZRXR) ; ;If we're at top level, fire all accumulated record-level xrefs N X,Y I '$G(^DD(DIFILE,0,"UP")) D FIREREC^DIE17 Q ; ;Save the DA array and DIIENS N DASV,DIIENSSV M DASV=DA S DIIENSSV=DIIENS ; ;Get list of subfiles under DIFILE N DA,DIE,DIEZXR,DIFLIST,DIIENS,DIPAT,DP D SUBFILES^DIKCU(DIFILE,.DIFLIST) S DIFLIST(DIFILE)="" S DIPAT=".E1"""_DIIENSSV_"""" ; ;Fire record-level cross references DIFILE and its subfiles S DP=0 F S DP=$O(DIFLIST(DP)) Q:'DP D . Q:'$D(DIEZRXR(DP)) . S DIIENS=" " F S DIIENS=$O(DIEZRXR(DP,DIIENS)) Q:DIIENS="" D .. Q:DIIENS'?@DIPAT .. S DIE=DIEZRXR(DP,DIIENS) .. D DA^DILF(DIIENS,.DA) .. S DIEZXR=0 F S DIEZXR=$O(DIEZRXR(DP,DIEZXR)) Q:DIEZXR'=+DIEZXR D ... D:$D(DIEZAR(DP,DIEZXR))#2 @DIEZAR(DP,DIEZXR) .. K DIEZRXR(DP,DIIENS),@DIETMP@("V",DP,DIIENS) . K:'$D(@DIETMP@("V",DP)) DIEZRXR(DP) Q DIE3 DIE3 ;SFISC/XAK-PROCESS SINGLE-VALUED VARIABLE PNTR ;03:06 PM 14 Feb 2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. V ; S DIEX=X ;I $D(DNM) S DIDS=D G ALL:X'["." S DIVP=$P(X,"."),X=$P(X,".",2,999),Y=-1,A9=1 I X="" G Q I DIVP]"",$D(^DD(DP,DIFLD,"V","P",DIVP)) D FND G Q I DIVP="" G ALL S X="" F %=0:0 S X=$O(^DD(DP,DIFLD,"V","M",X)) Q:X="" I $P(X,DIVP)="" S DIVP=X,X=$P(DIEX,".",2,999) D FND G Q:Y>0 S X=$P(DIEX,".") F DIVP=0:0 S DIVP=$O(^DD(DP,DIFLD,"V",DIVP)) Q:+DIVP'>0 I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S %=$P(^(0),U) I $P(%,$P(DIEX,"."))="" S X=$P(DIEX,".",2,999) D DIC G Q:Y>0 S X=$P(DIEX,".") I A9 S X=DIEX,A9=0 G ALL G Q ; ALL F DIVP1=0:0 S DIVP1=$O(^DD(DP,DIFLD,"V","O",DIVP1)) Q:+DIVP1'>0 S DIVP=DIVP1 D FND Q:Y>0 S X=DIEX G Q ; FND S DIVP=+$O(^(DIVP,0)) I $D(^DD(DP,DIFLD,"V",DIVP,0)) S DIVPDIC=^(0) D DIC I Y>0 S A9=0 Q ; DIC I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 Q I $D(DIC("V")) S Y=DIVP,Y(0)=DIVPDIC X DIC("V") I '$T K Y S Y=-1 Q N DIVPSEL S DIVPSEL(0)=0 I $D(DIVP1),'$D(DB(DQ)),'$G(DIQUIET) D H1 W:'$D(DDS) ! S DIC=^DIC(+DIVPDIC,0,"GL"),DIC(0)="MD"_$E("E",'$D(DB(DQ))&'$D(DIR("V")))_$E("L",$P(DIVPDIC,U,6)="y")_$E("Z",$D(DDS)) I $P(DIVPDIC,U,5)="y",$D(^DD(DP,DIFLD,"V",DIVP,1)),^(1)]"" X ^(1) I $D(DIR)=10,'$D(DDS) S DIC(0)=$P(DIC(0),"L")_$P(DIC(0),"L",2) D PTRIX S X=+Y_";"_$E(DIC,2,99) K:Y<0 X S %=1 I Y>0,'DIVPSEL(0),'$D(DB(DQ)),'$P(Y,U,3),'$$CHKO,'$G(DIQUIET) D S1 ; 22*123 D Q .N DICV .I $D(DIC("V")) S DICV=DIC("V") .K DIC S DIC=DIE S:$D(DICV) DIC("V")=DICV .Q ; S1 S A1="Q",DST=%_U_" ...OK" D S S:%'=1 Y=-1 Q ; H S DDH=$S($D(DDH):DDH+1,1:1),DDH(DDH,A1)=DST K DST Q ; H1 ;also called by DICM3 W:'$D(DDS) ! EGP S A1="T",DST=$$EZBLD^DIALOG(8070,$$FILENAME^DIALOGZ(+DIVPDIC)) ;** 'SEARCHING FOR A ...' S I $D(DDS) D H S DDD=1 D ^DDSU K DDD G QS I A1["T" W !,DST G QS I A1["Q" S %=+$P(DST,U,1) W !,$P(DST,U,2) D YN^DICN G QS I A1["X" X DST QS K A1,DST Q ; Q K A1,DIVP1,DIVP,DIVPDIC,A9 I $D(DNM) G:Y>0 @("V^"_DNM) S X=DIEX K DIEX G X^DIE17:'$D(DB(DQ)),B^DIE17 K DIEX Q:$D(DIR) G V^DIED:Y>0,X^DIED:'$D(DB(DQ)),B^DIE1 ; PTRIX ;Check for DIC("PTRIX"); do appropriate ^DIC call K DIC("PTRIX"),D M DIC("PTRIX")=DIE("PTRIX") ; S D=$G(DIE("PTRIX",DP,DIFLD,+DIVPDIC)) I $P(DIVPDIC,U,6)="y",(U_D_U)'["^B^" S D=D_"^B" ; I $G(D)]"",$P(D,U,2)="" S DIC(0)=$TR(DIC(0),"M") E S:DIC(0)'["M" DIC(0)="M"_DIC(0) ; I $P($G(D),U)="" D . K D D ^DIC E I $P(D,U,2)]"" D . D MIX^DIC1 E D IX^DIC K DIC("PTRIX") Q ; CHKO() ; New with 22*123. Check for 'O' (Ask 'OK') ; Backwards compatibility check I $P(^DIC(+DIVPDIC,0),U,2)["O" Q 1 ; If $P#2 of the File Header ["O" then Quit True Q $P(@(^DIC(+DIVPDIC,0,"GL")_"0)"),U,2)["O" ;#8070 Searching for a |filename| DIE9 DIE9 ;SFISC/GFT-JUMPING, FILING, MULTIPLES ;8:03 AM 13 Aug 1997 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. G:$A(X)-94 X:'$P(DW,";E",2),@("T^"_DNM) I $D(DIE("NO^")),DIE("NO^")="OUTOK"'&(X=U) W $C(7),!?3,"Sorry, ""^"" is not allowed!" G B S X=$P(X,U,2),DIC(0)="E" OUT I 0[X S DM=DW D FILE G ABORT:DL=1,R I X?1"@".N,$D(^DIE("AF",X,DIEZ)) S DNM=^(DIEZ) E S DIC="^DD("_DP_",",DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ))" D ^DIC K DIC S DIC=DIE G X:Y<0 S DNM=^DIE("AF",DP,+Y,DIEZ) D FILE S Y=DNM,DNM=$P(Y,U,2),DQ=+Y,D=0 D @("DE^"_DNM) G @Y ; F ; S DC=$S($D(X)#2:X,1:0) D FILE S X=DC Q FILE ; K DQ Q:$D(DG)<9 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))" Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU I DU'<0 S ^(DU)=DV,DU=-2 G E1:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU) DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y PC S $P(DV,U,DW)=DG(DQ) G Y ; IX I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2) S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1) K K DE(DQ) E1 S DQ=$O(DE(" ")) I DQ'="" G IX:$D(DG(DQ)),K K DG,DE,DIFLD S DQ=0 Q ; AST S E=DQ(DQ),Y=$F(E," D ^DIC"),%=8 I 'Y S Y=$F(E," D IX^DIC"),%=10 G V^DIED:'Y S %DD=Y+1 X $P($E(E,1,Y-%),U,5,99) G V^DIED:'$D(DIC("S")) S DICSS=DIC("S") D ^DIC S X=+Y I $P(Y,U,3) S Y=+Y X:$D(@(DIC_Y_",0)")) DICSS I '$T S D=DA,DA=Y,DIK=DIC D ^DIK K DICSS S DA=D,DV=$P(E,U,2),DU=$P(E,U,3) G X^DIED K DICSS X:Y>0 $E(E,%DD,999) K %DD G X^DIED:'$D(X),X^DIED:X<0,Z^DIED 1 ; D FILE R D UP G @("R"_DQ_U_DNM) ; UP S DNM=DNM(DL),DQ=DNM(DL,0),%=2 I $D(DIEC(DL)) D DIEC^DIE1 G U S DA=DA(1) K DA(1) DA I $D(DA(%)) S DA(%-1)=DA(%) K DA(%) S %=%+1 G DA S:$D(DIEZTMP)#2 DIIENS=$P(DIIENS,",",2,999) U K DTOUT,DNM(DL) S DL=DL-1 Q ; X W:'$D(ZTQUEUED) $C(7),"??" B G @(DQ_U_DNM) ; N D DOWN S DA=$P(DC,U,4),D=0,^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA D1 S @("D"_(DL-1))=DA G @(DGO) ; M S DD=X D DOWN S DO(2)=$P(DC,"^",2),DO=DOW_"^"_DO(2)_"^"_$P(DC,"^",4,5),DIC(0)=$P("QE",U,'$D(DB(DNM(DL,0))))_"LM" I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2) E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1 K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC I Y'>0 D UP G @(DQ_U_DNM) S DA=+Y,X=$P(Y,U,2),D=$P(Y,U,3) G D1 ; DOWN S DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ D FILE DDA F %=DL+1:-1:1 I $D(DA(%)) S DA(%+1)=DA(%) S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_"""," Q ; ABORT D E S Y(DM)="" Q ; 0 ; D FILE E K DIP,Y,DE,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB DIED DIED ;SFISC/GFT,XAK-MAJOR INPUT PROCESSOR ;3FEB2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. O D W W Y W:$X>48 !?9 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 I Y]"" W "// " I 'DV,DV["I",$D(DE(DQ))#2 K X S X("FIELD")=DIFLD,X("FILE")=DP,X=" ("_$$EZBLD^DIALOG(3090,$$LABEL^DIALOGZ(DP,DIFLD))_")" W:$L(X)+$X>78 !?9 W X K X S X="" Q ;** TR Q:$P(DQ(DQ),U,2)["K"&(DUZ(0)'="@") R X:DTIME E S (DTOUT,X)=U W $C(7) Q W I $P(DQ(DQ),U,2)["K"&(DUZ(0)'="@") Q I $D(DIE("W")) X DIE("W") Q W !?DL+DL-2,$P(DQ(DQ),U,1)_": " Q ; DQ ; S:$D(DTIME)[0 DTIME=300 S DQ=1 G B A K DQ(DQ) S DQ=DQ+1 B S DIFLD=$S($D(DIFLD(DQ)):DIFLD(DQ),1:-1) I '$D(DQ(DQ)) G E^DIE1:'$D(DQ(0,DQ)),BR^DIE0 RE ; S DIP=$P(DQ(DQ),U,1),DV=$P(DQ(DQ),U,2),DU=$P(DQ(DQ),U,3) G:DV["K"&(DUZ(0)'="@") A G PR:$D(DE(DQ)) D W,TR I $D(DTOUT) K DQ,DG G QY^DIE1 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:$P(DC,U,2)-DP(0),A RD G ^DIE0:X[U,^DIE2:X="@" I X?."?" G A:$D(DB(DQ)),^DIEQ ;MAC-1201-61253 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DIP)) S X=^(DIP) I DV'["D",DV'["S" W " "_X T G M^DIE1:DV,^DIE3:DV["V",P:DV'["S" I X?.ANP D SET I 'DDER G V K DDER G X P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G AST:DV["*" D NOSCR S X=+Y,DIC=DIE G X:X<0 G V:DV'["N" I $L($P(X,"."))>24 K X G Z I $P(DQ(DQ),U,5,99)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X V S DIER=1 X $P(DQ(DQ),U,5,99) K DIER,YS UNIQ I $P(DQ(DQ),U,2)["U",$D(X),DIFLD=.01 K % M %=@(DIE_"""B"",X)") K %(DA) K:$O(%(0)) X Z K DIC("S"),DLAYGO I $D(X),X?.ANP,X'=U D LOADXR G:'$$KEYCHK UNIQFERR S DG($P(DQ(DQ),U,4))=X S:DV["d" ^DISV(DUZ,"DIE",DIP)=X G A X W:'$D(ZTQUEUED) $C(7) W:'$D(DDS)&'$D(ZTQUEUED) "??" G B^DIE1 ; PR I $D(DE(DQ,0)) S Y=DE(DQ,0) G F:Y?1"/".E I $D(DE(DQ))=10 D Y:$E(Y)=U,O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N S DG=DV,Y=DE(DQ),X=DU I DG["O",$D(^DD(DP,DIFLD,2)) X ^(2) G S R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G S:'$D(^(Y,0)) S Y=$P(^(0),U,1),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G S:'$D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") I %]"" S Y=$S($G(DUZ("LANG"))'>1:%,'DIFLD:%,1:$$SET^DIQ(DP,DIFLD,Y)) S D O I $D(DTOUT) K DQ,DG G QY^DIE1 I X="" S X=DE(DQ) X:$D(DICATTZ) $P(DQ(DQ),U,5,99) G A:'DV,A:DC<2 G N^DIE1 G RD:DQ(DQ)'["DINUM" D E^DIE0 G RD:$D(X),PR ; F S DB(DQ)=1,X=$E(Y,2,999),DH=$F(DQ(DQ),"%DT=""E") I DH S DQ(DQ)=$E(DQ(DQ),1,DH-2)_$E(DQ(DQ),DH,999) I X?1"/".E S X=$E(X,2,999),DH="" X:$E(X,1)=U $E(X,2,999) G:X="" A:'DV,A:'$P(DC,U,4),N^DIE1 I $D(DE(DQ))#2,DV["I"!(DQ(DQ)["DINUM") D E^DIE0 G X:'$D(X),RD:DH]"",RD:X="@",M^DIE1:DV,Z ; Y X $E(Y,2,999) S Y=X I DV["D",Y?7N.NP X ^DD("DD") Q Q ; SET ;FROM COMPILED TEMPLATES,TOO N DIR,DILANG I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 I $G(DUZ("LANG"))>1,$D(^DD(DP,+$G(DIFLD),0)) S DILANG=$$SETIN^DIALOGZ D .I DILANG'=DU S DU=DILANG Q .K DILANG S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 S:$D(DIC("S")) DIR("S")=DIC("S") D ^DIR Q:DDER I $D(DILANG) S %=$F(";"_DILANG,";"_Y) I % S Y=$P($P($P(^DD(DP,DIFLD,0),U,3),";",Y),":") ;Return the 'REAL' internal value S %=Y(0),X=Y I $D(^DD(DP,DIFLD,12.1)) X ^(12.1) I $D(DIC("S")) X DIC("S") E S DDER=1 Q W:'$D(DB(DQ)) " "_% Q ; ; AST ;G V:DV["'",AST^DIE9 I DV["'" D . D SCRNL(.DICONT) E D SCRL(.DICONT) I DICONT="V" K DICONT G V:$D(DNM)[0,@("V^"_DNM) I DICONT="X" K DICONT G X:$D(DNM)[0,@("X^"_DNM) I DICONT="Z" K DICONT G Z:$D(DNM)[0,@("Z^"_DNM) Q ; RW G RW^DIR2 ; LOADXR ;Load all index file xrefs for a field Q:$D(DIETMP)[0 N FLIST,RLIST,OLD ; I $G(DICRREC)]"" N DP,DIFLD,DIIENS S OLD=DIU,DP=DIH,DIFLD=DIG,DIIENS=DICRIENS E S OLD=$G(DE(DQ)) ; ;Get field- and record-level xrefs D LOADFLD^DIKC1(DP,DIFLD,"KS","",$NA(@DIETMP@("V")),"DIEFXREF",$NA(@DIETMP@("R")),.FLIST,.RLIST) I FLIST="",RLIST="" Q S:RLIST]"" @DIETMP@("R",DP,DIIENS)=DIE ; ;Save the old value of the field S @DIETMP@("V",DP,DIIENS,DIFLD,"O")=OLD S:$D(^("F"))[0 ^("F")=OLD I $G(DICRREC)="",$G(DE(DQ,0))?1"//".E S @DIETMP@("V",DP,DIIENS,DIFLD,"4/")="" E K @DIETMP@("V",DP,DIIENS,DIFLD,"4/") Q ; KEYCHK() ;If this is a key field, return 0 if not unique. N DIEKCHK Q:$D(DIETMP)[0 1 Q:'$D(DIEFXREF) 1 Q:$G(DE(DQ,0))?1"//".E 1 S @DIETMP@("V",DP,DIIENS,DIFLD,"N")=X S DIEKCHK=$$KEYCHK^DIKK2(DP,.DA,DIFLD,"DIEFXREF",DIIENS,"","N") K @DIETMP@("V",DP,DIIENS,DIFLD,"N") Q DIEKCHK ; UNIQFERR ;The field is part of a key and is not unique I '$D(ZTQUEUED),'$D(DDS) D . W $C(7)_"??" . W:'$D(DB(DQ)) !," ",$$EZBLD^DIALOG(3094) K DIEFXREF S ^("N")=@DIETMP@("V",DP,DIIENS,DIFLD,"O") G B^DIE1 ; NKEY ;No value was assigned to this key field I '$D(ZTQUEUED),'$D(DDS) W $C(7)_"?? ",$$EZBLD^DIALOG(3092.2) G B^DIE1 ; NOSCR ;No screen N DIXRL D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL) I DV'["'",$G(DIXRL)]"",(U_DIXRL_U)'["^B^" S DIXRL=DIXRL_"^B" D DIC($G(DIXRL)) Q ; SCRNL(DICONT) ;Screen, No LAYGO allowed N DIFRST,DILAST,DIXRL K DICONT ; D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL) G:$G(DIXRL)="" EXIT ; D:$D(DNM)#2 @("D^"_DNM) D PARSE($P(DQ(DQ),U,5,999),.DIFRST,.DILAST) G:'$D(DIFRST) EXIT ; X DIFRST D DIC(DIXRL) S X=+Y X:Y>0 DILAST S DICONT=$S('$D(X):"X",X<0:"X",1:"Z") Q ; SCRL(DICONT) ;Screen, LAYGO allowed N DICALL,DICSS,DIFRST,DILAST,DIXRL K DICONT ; D GETXRL(DP,DIFLD,+$P(DV,"P",2),.DIXRL) D:$D(DNM) @("D^"_DNM) D PARSE($P(DQ(DQ),U,5,999),.DIFRST,.DILAST) G:'$D(DIFRST) EXIT ; K D X DIFRST I '$D(DIC("S")),$G(DIXRL)="" S DICONT="V" Q S DICSS=$G(DIC("S")) ; I $G(DIXRL)="" S DIXRL=$G(D) E S:(U_DIXRL_U)'["^B^" DIXRL=DIXRL_"^B" D DIC($G(DIXRL)) S X=+Y ; I $P(Y,U,3) S Y=+Y X:$D(@(DIC_Y_",0)")) DICSS E D S DICONT="X" Q . N DV,DU,DA . S DA=Y,DIK=DIC D ^DIK ; X:Y>0 DILAST S DICONT=$S('$D(X):"X",X<0:"X",1:"Z") Q ; EXIT ;Cleanup and set flag to continue by executing the input transform K DIC("PTRIX") S DICONT="V" Q ; DIC(D) ;Make the appropriate ^DIC call based on D I $G(D)]"",$P(D,U,2)="" S DIC(0)=$TR(DIC(0),"M") E S:DIC(0)'["M" DIC(0)="M"_DIC(0) ; I $P($G(D),U)="" D . D ^DIC E I $P(D,U,2)]"" D . D MIX^DIC1 E D IX^DIC K DIC("PTRIX") Q ; PARSE(IT,FRST,LAST) ;Parse input transform N CALL,I F CALL=" D ^DIC"," D IX^DIC"," D MIX^DIC1","" Q:IT[CALL I CALL="" K FRST,LAST Q S FRST=$P(IT,CALL),LAST=$P(IT,CALL_" ",2,999) I FRST?.E1" " D S FRST=$E(FRST,1,I) . F I=$L(FRST)-1:-1:0 Q:$E(FRST,I)'=" " Q ; GETXRL(FIL,FLD,PFIL,LIST) ;Get list of indexes from DIE("PTRIX") K DIC("PTRIX"),LIST Q:'$D(DIE("PTRIX")) M DIC("PTRIX")=DIE("PTRIX") ; S LIST=$G(DIE("PTRIX",FIL,FLD,PFIL)) K:LIST="" LIST Q DIEF DIEF ;SFISC/DPC-FILER DRIVER ;16FEB2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FILE(DIEFFLAG,DIEFAR,DIEFOUT,DIEFADAR) ; FILEX ; N DIEFF,DIEFCNOD,DIEFNODE,DIEFSPOT,DIEFDAS,DIEFIEN,DIEFRFLD,DIEFFLD,DIEFFVAL,DIEFOVAL,DIEFNVAL,DIEFTSRC,DIEFLOCK,DIEFECNT N DIDATA,DIEFFLST,DIEFFREF,DIEFFXR,DIEFLEV,DIEFRLST,DIEFTMP,DIEFTREF S DIEFFLAG=$G(DIEFFLAG) I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU I '$$VERFLG^DIEFU(DIEFFLAG,"ISKEOTU") G OUT I DIEFFLAG["T",DIEFFLAG'["E" D BLD^DIALOG(301,DIEFFLAG,DIEFFLAG) G OUT I '$$VROOT^DIEFU(DIEFAR) G OUT I '($D(@DIEFAR)\10) D BLD^DIALOG(305,DIEFAR,DIEFAR) G OUT I DIEFFLAG["K" N DIEFNOLK,DIEFLCKS D LOCK^DIEF1 I DIEFNOLK G OUT ;batch conversion to internal and key validation if requested. I DIEFFLAG["T" S DIEFECNT=$G(DIERR) D G:DIEFECNT'=$G(DIERR) OUT . S DIEFAR("INT")="^TMP($J,""DIEF"")" . D VALS^DIEVS("R"_$E("U",DIEFFLAG["U"),DIEFAR,DIEFAR("INT")) . S DIEFAR("EXT")=DIEFAR,DIEFAR=DIEFAR("INT") S DIEFTMP=$$GETTMP^DIKC1("DIEF") D DRIVER OUT I $D(DIEFLOCK) D UNLOCK^DIEF1 I DIEFFLAG'["S",'$G(DIERR) K @$G(DIEFAR("EXT"),DIEFAR) I $D(DIEFAR("INT")) K @DIEFAR("INT") I $G(DIEFOUT)]"" D CALLOUT^DIEFU(DIEFOUT) I $D(DIEFTMP) K @DIEFTMP Q DRIVER ; S DIEFF="" F S DIEFF=$O(@DIEFAR@(DIEFF)) Q:DIEFF="" D . I DIEFFLAG'["K",'$$VFILE^DIEFU(DIEFF,"D") Q . S DIEFFREF=$$FROOTDA^DIKCU(DIEFF,"D",.DIEFLEV,.DIEFTREF) Q:DIEFFREF="" . S DIEFDAS="" . F S DIEFDAS=$O(@DIEFAR@(DIEFF,DIEFDAS)) Q:DIEFDAS="" D . . N D,I,DA,S,DIOPER . . S DIEFIEN=DIEFDAS . . I ($E(DIEFIEN)="?"!($E(DIEFIEN)="+")),$G(DIEFADAR)]"" D . . . I $E(DIEFIEN)="+" S DIOPER="A" . . . E I $E(DIEFIEN,1,2)="?+",@DIEFADAR@($TR($P(DIEFIEN,","),"?+"),0)="+" S DIOPER="A" . . . S DIEFIEN=$$ADDCONV^DIEF1(DIEFIEN,DIEFADAR) . . S S=" " F S S=$O(@DIEFTMP@("DEL",DIEFF,S)) Q:S="" I ","_DIEFIEN?@(".E1"","_S_"""") S DIEFDAS=$C(127) Q . . Q:DIEFDAS=$C(127) . . I DIEFFLAG'["K" Q:'$$GOODIEN(DIEFF,DIEFIEN,DIEFLEV,"","D") . . F I=0:1:DIEFLEV S D="D"_(DIEFLEV-I) N @D S (DA(I),@D)=$P(DIEFIEN,",",I+1) . . S DA=DA(0) K DA(0) . . S DIDATA=$NA(@DIEFFREF@(DA)) . . Q:'$$VENTRY(DIEFF,DIEFIEN,"D"_$E(9,DIEFFLAG["E"),DIDATA,DIEFTREF) . . N DOREPL S DIEFRFLD="",DOREPL=0 . . F S DIEFRFLD=$O(@DIEFAR@(DIEFF,DIEFDAS,DIEFRFLD)) Q:DIEFRFLD="" D . . . N DIEFNG . . . S DIEFFLD=$$CHKFLD^DIEFU(DIEFF,DIEFRFLD) I 'DIEFFLD Q . . . I DIEFFLD=.001 D BLD^DIALOG(520,".001",".001") Q . . . S DIEFNVAL=@DIEFAR@(DIEFF,DIEFDAS,DIEFRFLD) . . . I DIEFFLAG["E",DIEFFLAG'["T" D VAL Q:$D(DIEFNG) . . . I DIEFFLD=.01,"@"[DIEFNVAL D PT01DEL Q . . . S DIEFSPOT=$P(^DD(DIEFF,DIEFFLD,0),U,4) . . . S DIEFNODE=$NA(@DIDATA@($P(DIEFSPOT,";"))) . . . S DIEFSPOT=$P(DIEFSPOT,";",2) . . . I DIEFNODE'=$G(DIEFCNOD) D:DOREPL REPLACE S DIEFCNOD=DIEFNODE D RETRIEVE . . . I DIEFNVAL="@" S DIEFNVAL="" . . . D LOADFLD^DIKC1(DIEFF,DIEFFLD,"KS","",$NA(@DIEFTMP@("V")),"DIEFFXR",$NA(@DIEFTMP@("R")),.DIEFFLST,.DIEFRLST) . . . I DIEFFLAG'["T",DIEFFLAG'["U",'$$SKEYCHK^DIEF1(DIEFF,DIEFFLD,DIEFNVAL,.DA,DIEFIEN,.DIEFFXR) K DIEFFXR Q . . . D PUTDATA^DIEF1 Q:$D(DIEFNG) . . . I DIEFNVAL'=$G(DIEFOVAL) D XRFAUD,FIREFLD . . D REPLACE:DOREPL K DIEFCNOD . . D FIREREC Q PT01DEL ; N DIEFERR I DIEFNVAL="" F S DIEFERR=$O(^DD(DIEFF,.01,"DEL",$G(DIEFERR))) Q:DIEFERR="" I $D(^(DIEFERR,0)) X ^(0) I D G Q . N INT,EXT . S INT(1)=$$FLDNM^DIEFU(DIEFF,DIEFFLD),INT(2)=$$FILENM^DIEFU(DIEFF),EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD . D BLD^DIALOG(712,.INT,.EXT) ;"CANNOT BE DELETED" S DIEFECNT=$G(DIERR) N %,DIC,DIK S DIK=$$OREF^DILF($NA(@DIEFFREF)) D ^DIK I DIEFECNT'=$G(DIERR) D HKERR^DILIBF(DIEFF,DIEFIEN,DIEFFLD,"cross reference") N SB D SUBFILES^DIKCU(DIEFF,.SB) S SB(DIEFF)="" S SB=0 F S SB=$O(SB(SB)) Q:'SB S @DIEFTMP@("DEL",SB,DIEFIEN)="" S DIEFRFLD=$C(127),DOREPL=0 K @DIEFTMP@("R"),@DIEFTMP@("V") Q Q ; VAL ; N DIEFTYPE,DIEFINT D DTYP^DIOU(DIEFF,DIEFFLD,.DIEFTYPE) Q:DIEFTYPE=5 D VAL^DIEV(DIEFF,DIEFIEN,DIEFFLD,"U",DIEFNVAL,.DIEFINT) I DIEFINT'=U S DIEFNVAL=DIEFINT Q S DIEFNG=1 Q REPLACE ; S @DIEFCNOD=DIEFFVAL,DOREPL=0 Q RETRIEVE ; S DIEFFVAL=$G(@DIEFCNOD) Q ; XRFAUD ; I $D(^DD(DIEFF,"IX",DIEFFLD)) D REPLACE:$G(DOREPL),IX,RETRIEVE:$D(DOREPL) I $D(^DD(DIEFF,"AUDIT",DIEFFLD)) D AUDIT Q IX ; N X,DIEFSORK I DIEFOVAL'="" S DIEFSORK=2 D FIRE I "@"'[DIEFNVAL S DIEFSORK=1 D FIRE Q FIRE ; N DIEFI,DICRREC S:$D(DIEFTMP) DICRREC="TRIG^DIEF" S DIEFI=0 F S DIEFI=$O(^DD(DIEFF,DIEFFLD,1,DIEFI)) Q:DIEFI="" D . N I,Y,DIG,DIH,DIU,DIV,XMB,XMY . S X=$S(DIEFSORK=1:DIEFNVAL,1:DIEFOVAL) . N DIEFECNT S DIEFECNT=$G(DIERR) . X ^(DIEFI,DIEFSORK) ;Naked indicator set in For loop, FIRE+2 . I DIEFECNT'=$G(DIERR) D HKERR^DILIBF(DIEFF,DIEFIEN,DIEFFLD,"cross reference") Q AUDIT ; N X,DP,DG,DIIX N DIANUM,C,Y S DP=DIEFF,DG=1 I DIEFOVAL]"" S X=DIEFOVAL,DIIX="2^"_DIEFFLD D AUDIT^DIET I "@"'[DIEFNVAL,(DIEFOVAL]""!(^DD(DIEFF,DIEFFLD,"AUDIT")'="e")) S X=DIEFNVAL,DIIX="3^"_DIEFFLD_$S(DIEFFLD=.01&(DIEFOVAL=""):"^A",1:"") D AUDIT^DIET Q ; FIREFLD ;Fire field-level xrefs Q:'$D(DIEFTMP) I $G(DIEFFLST)]""!($G(DIEFRLST)]"") D . S:'$D(@DIEFTMP@("V",DIEFF,DIEFIEN,DIEFFLD,"O")) ^("O")=DIEFOVAL ; I $G(DIEFFLST)]"" D . D:$G(DOREPL) REPLACE . D FIRE^DIKC(DIEFF,.DA,"KS","DIEFFXR","O","",$E("C",$G(DIOPER)="A")) . D:$D(DOREPL) RETRIEVE K DIEFFXR,DIEFFLST Q ; FIREREC ;Fire record-level xrefs N DIKEY D FIRE^DIKC(DIEFF,.DA,"KS",$NA(@DIEFTMP@("R")),"O^"_$S(DIEFFLAG'["T"&(DIEFFLAG'["U"):"^K^N",1:""),.DIKEY,$E("C",$G(DIOPER)="A")) D:$D(DIKEY)>9 RESTORE^DIEF1(.DIKEY,DIEFTMP) K @DIEFTMP@("R"),@DIEFTMP@("V") Q ; GOODIEN(DIEFF,DIEFIEN,DIEFLEV,DA,DIEFFLG) ; N ERR,P K DA I DIEFIEN[",,"!($E(DIEFIEN)=",") D Q 0 . D:$G(DIEFFLG)["D" ERR^DIKCU2(307,"",DIEFIEN) I $E(DIEFIEN,$L(DIEFIEN))'="," D Q 0 . D:$G(DIEFFLG)["D" ERR^DIKCU2(304,"",DIEFIEN) I $L(DIEFIEN,",")-2'=DIEFLEV D Q 0 . D:$G(DIEFFLG)["D" ERR^DIKCU2(205,"",DIEFIEN,"",DIEFF) S ERR=0 F P=1:1:$L(DIEFIEN,",")-1 D Q:ERR . S DA(P-1)=$P(DIEFIEN,",",P) . I DA(P-1)'=+$P(DA(P-1),"E")!(DA(P-1)'>0) D .. K DA S ERR=1 D:$G(DIEFFLG)["D" ERR^DIKCU2(308,"",DIEFIEN) Q:ERR 0 S DA=DA(0) K DA(0) Q 1 ; VENTRY(DIEFF,DIEFIEN,DIEFFLG,DIDATA,DIEFTREF) ; S DIEFFLG=$G(DIEFFLG) ; ;Get root of (sub)record and top level file I $G(DIDATA)=""!(DIEFFLG[9&($G(DIEFTREF)="")) D Q:$G(DIDATA)="" 0 . N DA,DIEFD,DIEFLEV . S DIEFD=$E("D",DIEFFLG["D") . S DIDATA=$$FROOTDA^DIKCU(DIEFF,DIEFD,.DIEFLEV,.DIEFTREF) Q:DIDATA="" . I '$$GOODIEN(DIEFF,DIEFIEN,DIEFLEV,.DA,DIEFD) S DIDATA="" Q . S DIDATA=$NA(@DIDATA@(DA)) ; ;Check null .01 I $P($G(@DIDATA@(0)),U)="" D Q 0 . D:DIEFFLG["D" ERR^DIKCU2(601,DIEFF,DIEFIEN) ; ;Check -9 node I DIEFFLG[9,$D(@DIEFTREF@($P(DIEFIEN,",",$L(DIEFIEN,",")-1),-9)) D Q 0 . D:DIEFFLG["D" ERR^DIKCU2(602,DIEFF,DIEFIEN) ; Q 1 ; TRIG ;Called from trigger logic (from DICR via @DICRREC) Q:'$D(DIEFTMP) N DIEFRLST D LOADFLD^DIKC1(DIH,DIG,"KS","",$NA(@DIEFTMP@("V")),"",$NA(@DIEFTMP@("R")),"",.DIEFRLST) I $G(DIEFRLST)]"",'$D(@DIEFTMP@("V",DIH,DICRIENS,DIG,"O")) S ^("O")=DIU Q DIEF1 DIEF1 ;SFISC/DPC-FILER UTILITIES ;22MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. LOAD(DIEFF,DIEFDAS,DIEFFLD,DIEFFLG,DIEFVAL,DIEFAR,DIEFOUT) ; LOADX ; N DIEFIEN I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU I $G(DIEFDAS)']"" D BLD^DIALOG(202,"IENS","IENS") G OUT I $E(DIEFDAS,$L(DIEFDAS))="," S DIEFIEN=DIEFDAS E S DIEFIEN=$$IEN^DIEFU(.DIEFDAS) I '$$VROOT^DIEFU(DIEFAR) G OUT I '$$VFILE^DIEFU(DIEFF,"D") G OUT S DIEFFLD=$$CHKFLD^DIEFU(DIEFF,DIEFFLD) G:'DIEFFLD OUT I $G(DIEFFLG)["R",'$$VENTRY^DIEFU(DIEFF,DIEFIEN,"D") G OUT S @DIEFAR@(DIEFF,DIEFIEN,DIEFFLD)=DIEFVAL OUT I $G(DIEFOUT)]"" D CALLOUT^DIEFU(DIEFOUT) Q ; FLDNUM(DIEFF,DIEFFDNM) ; FLDNUMX ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU I '$$VFILE^DIEFU(DIEFF,"D") Q 0 N DIEFFNUM I $D(^DD(DIEFF,"B",DIEFFDNM)) D Q DIEFFNUM . S DIEFFNUM=$O(^DD(DIEFF,"B",DIEFFDNM,"")) . I $O(^DD(DIEFF,"B",DIEFFDNM,DIEFFNUM)) N P S P(1)=DIEFFDNM,P("FILE")=DIEFF D BLD^DIALOG(505,.P,.P) S DIEFFNUM=0 N P S P("FILE")=DIEFF,P(1)=DIEFFDNM D BLD^DIALOG(501,.P,.P) Q 0 ; ADDCONV(DIEFIEN,DIEFADAR) ; N I,DIEFNIEN,P F I=1:1:$L(DIEFIEN,",")-1 D . S P=$P(DIEFIEN,",",I) . I P,$E(P)'="+" Q . S DIEFNIEN=@DIEFADAR@($TR(P,"+?")) . S $P(DIEFIEN,",",I)=DIEFNIEN Q DIEFIEN ; PUTDATA ;CODE TO ACTUALLY PUT THE DATA INTO THE NODE BEING EDITED. ALSO SAVES ORIGINAL VALUES. CALLED FROM DIEF. I +DIEFSPOT D . I DIEFNVAL[U D Q . . S DIEFNG=1 . . N INT,EXT . . S INT(1)=$$FLDNM^DIEFU(DIEFF,DIEFFLD),INT(2)=$$FILENM^DIEFU(DIEFF),EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD . . D BLD^DIALOG(714,.INT,.EXT) . S DIEFOVAL=$P(DIEFFVAL,"^",DIEFSPOT) . S $P(DIEFFVAL,"^",DIEFSPOT)=DIEFNVAL,DOREPL=1 E I $E(DIEFSPOT)="E" D . N FR,TO,OLEN,NLEN . S FR=$P($P(DIEFSPOT,"E",2),",",1),TO=$P(DIEFSPOT,",",2) . S NLEN=$L(DIEFNVAL) . I NLEN-1>(TO-FR) D Q . . S DIEFNG=1 . . N INT,EXT . . S INT(1)=$$FLDNM^DIEFU(DIEFF,DIEFFLD),INT(2)=$$FILENM^DIEFU(DIEFF),EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD . . D BLD^DIALOG(716,.INT,.EXT) . S DIEFOVAL=$E(DIEFFVAL,FR,TO),OLEN=$L(DIEFOVAL) . I $E(DIEFFVAL,TO+1,999)="" S $E(DIEFFVAL,FR,TO)=DIEFNVAL . E S $E(DIEFFVAL,FR,TO)=DIEFNVAL_$J("",$S(OLEN>NLEN:OLEN-NLEN,1:0)) . S DOREPL=1 E I DIEFSPOT=0 D . I $P($G(^DD(+$P(^DD(DIEFF,DIEFFLD,0),U,2),.01,0)),U,2)["W" D . . I '$$VROOT^DIEFU(DIEFNVAL) Q . . D PUTWP^DIEFW(DIEFFLAG,DIEFNVAL,DIEFNODE) . E D . . N INT,EXT . . S (INT(1),EXT(1))="MULTIPLE",EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD . . D BLD^DIALOG(520,.INT,.EXT) . . S DIEFNG=1 E I DIEFSPOT=" " D . N INT,EXT . S (INT(1),EXT(1))="COMPUTED",EXT("FILE")=DIEFF,EXT("FIELD")=DIEFFLD . D BLD^DIALOG(520,.INT,.EXT) . S DIEFNG=1 Q ; LOCK ; S (DIEFNOLK,DIEFLCKS)=0,DIEFF="" F S DIEFF=$O(@DIEFAR@(DIEFF)) Q:DIEFF="" D Q:DIEFNOLK . I '$$VFILE^DIEFU(DIEFF,"D") S DIEFNOLK=1 Q . S DIEFFREF=$$FROOTDA^DIKCU(DIEFF,"D",.DIEFLEV) Q:DIEFFREF="" . S DIEFDAS="" . F S DIEFDAS=$O(@DIEFAR@(DIEFF,DIEFDAS)) Q:DIEFDAS="" D Q:DIEFNOLK . . N DA . . I '$$GOODIEN^DIEF(DIEFF,DIEFDAS,DIEFLEV,.DA,"D") S DIEFNOLK=1 Q . . S DIEFLCKS=DIEFLCKS+1 . . S DIEFLOCK(DIEFLCKS)=$NA(@DIEFFREF@(DA)) . . D LOCK^DILF(DIEFLOCK(DIEFLCKS)) E D ;**147 . . . S DIEFNOLK=1 . . . N E S E("FILE")=DIEFF,E("IENS")=DIEFDAS D BLD^DIALOG(110,"",.E) Q UNLOCK ; N I F I=1:1:DIEFLCKS L -@DIEFLOCK(I) Q ; RESTORE(DIKEY,DIEFTMP) ;Restore key fields to pre-edited values ;DIKEY(rFile#,key#,iens) = "" : if key is not unique ; = n : if key fields not assigned a value ;DIKEY(rFile#,key#,iens,file,field) = levdiff : set if field not ; assigned a value N DIEFDA,DIEKK,DIRFIL,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA,DIOLD,DILEVD K DIEFDA ; ;Loop through root files and keys in DIKEY S DIRFIL=0 F S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL D . S DIEKK=0 F S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK D .. Q:$D(^DD("KEY",DIEKK,0))[0 .. ; .. ;Get fields in key .. K DIFLD .. S DIFLDI=0 F S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI D ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2) ... Q:'DIFLD!'DIFIL ... S DIFLD(DIFIL,DIFLD)="" .. ; .. ;Loop through records in DIKEY .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS="" D ... ; ... ;Generate error if key is not unique ... D:DIKEY(DIRFIL,DIEKK,DIIENS)="" ERR740^DIEVK1(DIRFIL,DIEKK,DIIENS) ... ; ... ;Loop through files/fields in key ... S DIFIL=0 F S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL D .... S DIFLD=0 F S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD D ..... Q:$D(^DD(DIFIL,DIFLD,0))[0 ..... ; ..... ;Generate error if key field not assigned a value ..... I $D(DIKEY(DIRFIL,DIEKK,DIIENS,DIFIL,DIFLD))#2 D ...... S (DILEVD,DIFLD(DIFIL,DIFLD))=+DIKEY(DIRFIL,DIEKK,DIIENS,DIFIL,DIFLD) ...... D ERR744^DIEVK1(DIFIL,DIFLD,DIEKK,$P(DIIENS,",",DILEVD+1,999)) ..... ; ..... ;Set the FDA to restore the field to original value ..... S DILEVD=DIFLD(DIFIL,DIFLD) ..... S:DILEVD="" (DILEVD,DIFLD(DIFIL,DIFLD))=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL) ..... S DIIENSA=$P(DIIENS,",",DILEVD+1,999) ..... Q:$D(@DIEFTMP@("V",DIFIL,DIIENSA,DIFLD,"O"))[0 S DIOLD=^("O") ..... S DIEFDA(DIFIL,DIIENS,DIFLD)=DIOLD ; D:$D(DIEFDA) FILE^DIEF("U","DIEFDA") Q ; SKEYCHK(DIEFF,DIEFFLD,DIEFNVAL,DA,DIEFIEN,DIEFFXR) ;Check simple key N DIEFKEY,DIEFK,DIEFKCHK Q:'$D(^DD("KEY","F",DIEFF,DIEFFLD)) 1 I DIEFNVAL="" D NKEY(DIEFF,DIEFFLD,DIEFIEN) Q 0 Q:'$D(DIEFFXR) 1 S @DIEFTMP@("V",DIEFF,DIEFIEN,DIEFFLD,"N")=DIEFNVAL S DIEFKCHK=$$KEYCHK^DIKK2(DIEFF,.DA,DIEFFLD,"DIEFFXR",DIEFIEN,"DIEFKEY","N") K @DIEFTMP@("V",DIEFF,DIEFIEN,DIEFFLD,"N") Q:DIEFKCHK 1 S DIEFK=0 F S DIEFK=$O(DIEFKEY(DIEFF,DIEFIEN,"K",DIEFK)) Q:'DIEFK D ERR740^DIEVK1(DIEFF,DIEFK,DIEFIEN) Q 0 ; NKEY(DIEFF,DIEFFLD,DIEFIEN) ;Generate error message #742 N DIEFK S DIEFK=0 F S DIEFK=$O(^DD("KEY","F",DIEFF,DIEFFLD,DIEFK)) Q:'DIEFK D . S DIEFK(DIEFK)="" S DIEFK=0 F S DIEFK=$O(DIEFK(DIEFK)) Q:'DIEFK D ERR742^DIEVK1(DIEFF,DIEFFLD,DIEFK,DIEFIEN) Q DIEFU DIEFU ;SF/DPC-FILER UTILITIES ;06:42 PM 9 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. INIZE ; N %,X,%H,DIE,DICS,DIC,%DT,DIK,%Y,%X,%D,%M,%I D DTNOLF^DICRW D CLEAN Q CLEAN ; K DIRUT,DIROUT,DUOUT,DTOUT K ^TMP("DIERR",$J),^TMP("DIMSG",$J),^TMP("DIHELP",$J) K DIERR,DIHELP,DIMSG Q ; CALLOUT(DIOUTAR) ; I '$$VROOT(DIOUTAR) Q I $D(DIERR) D . S @DIOUTAR@("DIERR")=DIERR . M @DIOUTAR@("DIERR")=^TMP("DIERR",$J) . K ^TMP("DIERR",$J) . Q I $D(DIHELP) D . S @DIOUTAR@("DIHELP")=DIHELP . M @DIOUTAR@("DIHELP")=^TMP("DIHELP",$J) . K ^TMP("DIHELP",$J) . Q I $D(DIMSG) D . S @DIOUTAR@("DIMSG")=DIMSG . M @DIOUTAR@("DIMSG")=^TMP("DIMSG",$J) . K ^TMP("DIMSG",$J) . Q Q ; IEN(DIEFDA) ; IENX ; I '$D(DIEFDA) Q 0 N I,DIEFIEN S (I,DIEFIEN)="",DIEFDA(0)=$G(DIEFDA) F S I=$O(DIEFDA(I)) Q:I="" S DIEFIEN=DIEFIEN_DIEFDA(I)_"," K DIEFDA(0) Q DIEFIEN ; DA(DAIEN,DATARG) ; DAX ; K DATARG N I F I=1:1:$L(DAIEN,",")-1 S DATARG(I-1)=$P(DAIEN,",",I) I $D(DATARG(0)) S DATARG=DATARG(0) K DATARG(0) Q ; VROOT(DIEFAR) ; I DIEFAR'["(" Q 1 I $E(DIEFAR,$L(DIEFAR))=")",$F(DIEFAR,")")>($F(DIEFAR,"(")+1) Q 1 D BLD^DIALOG(202,"array root") Q 0 ; VFILE(F,FLAG) ; VFILEX ; I $P($G(^DD(F,.01,0)),U,2)]"",$P(^(0),U,2)'["W" Q 1 I $G(FLAG)["D" N P S P("FILE")=F D BLD^DIALOG(401,.P,.P) Q 0 ; VENTRY(DIEFF,DIEFIEN,DIEFFLG) ; N DIEFROOT,DIEFDA S DIEFFLG=$G(DIEFFLG),DIEFDA=$P(DIEFIEN,",") S DIEFROOT=$$ROOT^DIQGU(DIEFF,DIEFIEN,1,$S(DIEFFLG["D":1,1:0)) Q:DIEFROOT="" 0 I $P($G(@DIEFROOT@(DIEFDA,0)),"^",1)="" D Q 0 . I DIEFFLG["D" N DIEFP S DIEFP("FILE")=DIEFF,DIEFP("IENS")=DIEFIEN D BLD^DIALOG(601,"",.DIEFP) I DIEFFLG["9" Q:'$$VMINUS9(DIEFF,DIEFIEN,DIEFFLG) 0 Q 1 ; VMINUS9(DIEFF,DIEFIEN,DIEFFLG) ; N DIEFTOP,DIEFROOT S DIEFFLG=$G(DIEFFLG) S DIEFTOP=$P(DIEFIEN,",",$L(DIEFIEN,",")-1),DIEFROOT=$$ROOT^DIQGU($$FNO^DILIBF(DIEFF),.DIEFTOP,1,$S(DIEFFLG["D":1,1:0)) Q:DIEFROOT="" 0 I $D(@DIEFROOT@(DIEFTOP,-9)) D Q 0 . I DIEFFLG["D" N DIEFP S DIEFP("FILE")=DIEFF,DIEFP("IENS")=DIEFIEN D BLD^DIALOG(602,"",.DIEFP) Q 1 ; CHKFLD(DIEFF,DIEFFLD) ; I DIEFFLD'=+DIEFFLD S DIEFFLD=$$FLDNUM^DIEF1(DIEFF,DIEFFLD) Q:'DIEFFLD 0 I '$$VFIELD(DIEFF,DIEFFLD,"D") Q 0 Q DIEFFLD ; VFIELD(F,FLD,FLAG) ; VFIELDX ; I $D(^DD(F,FLD)) Q 1 I $G(FLAG)["D" N P S (P(1),P("FIELD"))=FLD,P("FILE")=F D BLD^DIALOG(501,.P,.P) Q 0 ; DT(DIEFDT,DIEFX,DIEFY,DIEFDT0,DIOUTAR) ; DTX ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE N %DT,X,Y S DIEFDT=$G(DIEFDT) I $G(DIEFX)="" D BLD^DIALOG(202,"date being converted") G DTOUT I '$$VERFLG^DIEFU(DIEFDT,"FMNPRSTXEeI") G DTOUT I DIEFX?."?" D DT^DIEH1(DIEFDT) S DIEFY=-1 G DTOUT S %DT=DIEFDT,X=DIEFX S:$G(DIEFDT0)]"" %DT(0)=DIEFDT0 D ^%DT S DIEFY=Y I DIEFY=-1 D:DIEFDT'["e" G DTOUT . N DIEFP . S DIEFP(1)=DIEFX,DIEFP(2)="date/time" . D BLD^DIALOG(330,.DIEFP,.DIEFP) I DIEFDT["E" D DD^%DT S DIEFY(0)=Y DTOUT I $G(DIOUTAR)]"" D CALLOUT^DIEFU(DIOUTAR) Q ; VERFLG(FLG,GDFLGS) ; N EI S EI=$TR(FLG,GDFLGS,"") I EI="" Q 1 D BLD^DIALOG(301,EI,EI) Q 0 ; XA(DIEFF,DIEFIEN,DIEFFLD,DIEFNVAL,DIEFOVAL) ; N DA,DIEFCNOD,DOREPL S DIEFNVAL=$G(DIEFNVAL),DIEFOVAL=$G(DIEFOVAL) Q:DIEFNVAL=DIEFOVAL D DA(DIEFIEN,.DA) D XRFAUD^DIEF Q ; FILENM(F) ; N NM S NM=$$FILENAME^DIALOGZ($$FNO^DILIBF(F)) ;**CCO/NI GET FILE NAME ;I NM="" Q NM ; FLDNM(F,FLD) ; N NM,UP S NM=$$LABEL^DIALOGZ(F,FLD) ;**CCO/NI GET FIELD LABEL F S UP=$G(^DD(F,0,"UP")) Q:'UP D . S NM=NM_" in "_$P($G(^DD(F,0)),U,1) . S F=UP . Q ;I NM="" Q NM DIEFW DIEFW ;SFISC/DPC-FILER WP ;22MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ;(FILE,IENS,FIELD,FLAGS,wp_root,msg_root) WPX ; S DIEFWPFL=$G(DIEFWPFL) I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU I DIEFIEN']"" D BLD^DIALOG(202,"IENS","IENS") G OUT I '$$VERFLG^DIEFU(DIEFWPFL,"AZK") G OUT I "@"'[DIEFTSRC I '$$VROOT^DIEFU(DIEFTSRC) G OUT I '$$VFILE^DIEFU(DIEFF,"D") G OUT I '$$VFIELD^DIEFU(DIEFF,DIEFFLD,"D") G OUT I $P($G(^DD(+$P(^DD(DIEFF,DIEFFLD,0),U,2),.01,0)),U,2)'["W" N EI S EI("FILE")=DIEFF,EI("FIELD")=DIEFFLD D BLD^DIALOG(726,.EI,.EI) G OUT I '$$VENTRY^DIEFU(DIEFF,DIEFIEN,"D") G OUT N DIEFNODE,DIEFSPOT S DIEFSPOT=" " D GLRF^DIOU(DIEFF,DIEFFLD,.DIEFNODE,.DIEFSPOT) N DEPTH,I,D S DEPTH=$L(DIEFIEN,",")-1 F I=DEPTH:-1:1 S D="D"_(DEPTH-I) N @D S @D=$P(DIEFIEN,",",I) K DEPTH,D,I N DIEFLOCK I DIEFWPFL["K" D G:'$D(DIEFLOCK) OUT . S DIEFLOCK=DIEFNODE . D LOCK^DILF(DIEFLOCK) E D ;**147 . . K DIEFLOCK . . N EXT S EXT("FILE")=DIEFF,EXT("IENS")=DIEFIEN D BLD^DIALOG(110,"",.EXT) D PUTWP(DIEFWPFL,DIEFTSRC,DIEFNODE) I $D(DIEFLOCK) L -@DIEFLOCK OUT I $G(DIEFOUT)]"" D CALLOUT^DIEFU(DIEFOUT) Q ; PUTWP(DIEFWPFL,DIEFTSRC,DIEFNODE) ; N BEGIN D WP^DIET(DIEFF,DIEFFLD,DIEFIEN,DIEFNODE) I "@"[DIEFTSRC K @DIEFNODE Q I '($D(@DIEFTSRC)\10) D BLD^DIALOG(305,DIEFTSRC,DIEFTSRC) Q I $G(DIEFWPFL)'["A" S BEGIN=1 K @DIEFNODE E S BEGIN=$$NUMLNS(DIEFNODE)+1 K:BEGIN=1 @DIEFNODE I $D(@DIEFTSRC@($O(@DIEFTSRC@(0)),0))#2 S DIEFWPFL=$G(DIEFWPFL)_"Z" N LINECNT,INLINE S INLINE=0 F LINECNT=BEGIN:1 S INLINE=$O(@DIEFTSRC@(INLINE)) Q:INLINE'=+$P(INLINE,"E") D . I $G(DIEFWPFL)'["Z" S @DIEFNODE@(LINECNT,0)=$G(@DIEFTSRC@(INLINE)) . E S @DIEFNODE@(LINECNT,0)=$G(@DIEFTSRC@(INLINE,0)) S LINECNT=LINECNT-1 S @DIEFNODE@(0)=U_U_LINECNT_U_LINECNT_U_DT Q ; NUMLNS(DIWPROOT) ; N DIWPLN S DIWPLN=$P($G(@DIWPROOT@(0)),U,3) Q:DIWPLN DIWPLN S DIWPLN=$O(@DIWPROOT@(""),-1) Q +DIWPLN DIEH DIEH ;SFISC/STAFF-HELP ;13APR2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. GET(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ; GETX ; N DIEHZ,DIEHD,DIEHEXIT,DIEHPF,DIEHUFLG S DIEHUFLG=$G(DIEHFLG) I '$G(DIQUIET) N DIQUIET S DIQUIET=1 I '$G(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU I $G(DIEHIEN)]"" N DA,C,D,I D DA^DIEFU(DIEHIEN,.DA) S C=$L(DIEHIEN,",")-1 F I=1:1:C S D="D"_(C-I) N @D S @D=$P(DIEHIEN,",",I) S DIEHZ=$$ZERO(DIEHF,DIEHFLD) I DIEHZ=0 G GETOUT S DIEHD=$P(DIEHZ,U,2) D BLDFLGS G:$G(DIEHEXIT) GETOUT I DIEHD["P" S DIEHPF=+$P(DIEHD,"P",2) S DIHELP=+$O(^TMP("DIHELP",$J,""),-1) I DIEHUFLG["F",DIEHFLD=.01 D PXREFS(DIEHF,DIEHFLD) I DIEHUFLG["H" D HPROMPT(DIEHF,DIEHFLD) I DIEHUFLG["X" D XHLP(DIEHF,DIEHFLD) I DIEHUFLG["D" D DESCR(DIEHF,DIEHFLD) I DIEHUFLG["P" D SCRNDES(DIEHF,DIEHFLD) I DIEHUFLG["C" D SCRNDES(DIEHF,DIEHFLD) I DIEHUFLG["T" N DIEHDT S DIEHDT=$P($P($P(DIEHZ,U,5,99),"%DT=""",2),"""",1) D DT^DIEH1(DIEHDT) I DIEHUFLG["S" D SCRNCD(DIEHF,DIEHFLD,DIEHZ) I DIEHUFLG["U" D UNSCRNCD(DIEHZ) I DIEHUFLG["V" D VPMSG(DIEHF,DIEHFLD) I DIEHUFLG["B",DIEHUFLG'["b" D BLD^DIALOG(9115) I DIEHUFLG["M" D BLD^DIALOG(9116) I DIEHUFLG["G",DIEHFLG'["g",$G(DIEHPF) D FOLLOW(DIEHPF,DIEHFLG) I '$G(DIHELP) K DIHELP GETOUT I $D(DIEHOUT) D CALLOUT^DIEFU(DIEHOUT) Q ; BLDFLGS ; N A1,A2,C1,C2,DIEHGFLG S C1="HX",C2="XD",(A1,A2)="" I DIEHD S DIEHF=+DIEHD,DIEHFLD=.01,DIEHD=$P(^DD(DIEHF,.01,0),U,2) I DIEHD["W" S (A1,A2)="HD" E I DIEHD["D" S (A1,A2)="T" E I DIEHD["S" S A1="CS",A2="S",DIEHGFLG="U" E I DIEHD["P" S A1="PG",A2="G",DIEHGFLG="F" E I DIEHD="V" S A1="VB",A2="VMB" I DIEHFLD=.01,'$D(^DD(DIEHF,0,"UP")) S A1=A1_"F",A2=A2_"F" I DIEHUFLG'["r",'$$VERFLG^DIEFU(DIEHUFLG,"bgA?"_C1_C2_A1_A2_$G(DIEHGFLG)) S DIEHEXIT=1 I DIEHUFLG["??" S DIEHUFLG=DIEHUFLG_C2_A2 E I DIEHUFLG["?" S DIEHUFLG=DIEHUFLG_C1_A1 E I DIEHUFLG["A" S DIEHUFLG=$TR(C1_C2_A1_A2,"S","U") Q ; ZERO(F,D) ; I '$$VFILE^DIEFU(F,"D") Q 0 I '$$VFIELD^DIEFU(F,D,"D") Q 0 Q ^DD(F,D,0) ; BN ;Insert blank node. S:DIHELP DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)="" Q ; HPROMPT(F,D) ; N T S T=$$HELP^DIALOGZ(F,D) I $L(T) D . D BN . S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=T Q ; XHLP(DIEHF,DIEHFLD) ; ;DA() and D0,D1,etc. passed thru symbol table. N DIEHXH S DIEHXH=$G(^DD(DIEHF,DIEHFLD,4)) I $L(DIEHXH) D . D BN . N DIEHECNT S DIEHECNT=$G(DIERR) . N DDIOLFLG S DDIOLFLG="H" X DIEHXH . I DIEHECNT'=$G(DIERR) D HKERR^DILIBF(DIEHF,"",DIEHFLD,"Xecutable Help") Q ; DESCR(F,D) ; N L S L=$P($G(^DD(F,D,21,0)),U,3) I L D . D BN . N I F I=1:1:L S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=^DD(F,D,21,I,0) . Q Q ; PXREFS(DIEHF,DIEHFLD) ; N DIF,DIFD,DIEHROOT,DIEHIXID,DIEHIXP,DIEHIXNM,DIFULL S DIEHIXP=$$FILENM^DIEFU(DIEHF)_" " D GETIXNM(DIEHF,.DIEHIXNM) S DIF="" F S DIF=$O(DIEHIXNM(DIF)) Q:DIF="" D Q:$D(DIFULL) . S DIFD="" . F S DIFD=$O(DIEHIXNM(DIF,DIFD)) Q:DIFD="" D Q:$D(DIFULL) . . I $L(DIEHIXP)+$L(DIEHIXNM(DIF,DIFD))>240 D Q . . . S DIEHIXP=DIEHIXP_", etc " . . . S DIFULL=1 . . S DIEHIXP=DIEHIXP_DIEHIXNM(DIF,DIFD)_", or " S DIEHIXP=$E(DIEHIXP,1,$L(DIEHIXP)-5) D BLD^DIALOG(9105,DIEHIXP) Q ; GETIXNM(DIEHF,DIEHIXNM) ; S DIEHROOT=$$ROOT^DIQGU(DIEHF,"",1) S DIEHIXID="Az" F S DIEHIXID=$O(@DIEHROOT@(DIEHIXID)) Q:DIEHIXID="" D . N DIEHIXF,DIEHIXFD . S DIEHIXF=$O(^DD(DIEHF,0,"IX",DIEHIXID,"")) Q:DIEHIXF="" . S DIEHIXFD=$O(^DD(DIEHF,0,"IX",DIEHIXID,DIEHIXF,"")) Q:DIEHIXFD="" . S DIEHIXNM(DIEHIXF,DIEHIXFD)=$$FLDNM^DIEFU(DIEHIXF,DIEHIXFD) Q ; SCRNDES(F,D) ; N T S T=$G(^DD(F,D,12)) I $L(T) D . D BN . S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=T . Q Q ; SCRNCD(F,D,DIEHZ) ; N S,DIC,Y,A,T,I I $P(DIEHZ,U,2)'["*" D UNSCRNCD(DIEHZ) Q S S=$G(^DD(F,D,12.1)) I S="" D UNSCRNCD(DIEHZ) Q D CODES I $D(Y) D . N DIEHECNT S DIEHECNT=$G(DIERR) . D SETSCR^DIR(F,D) . D BLD^DIALOG(9101) . F I=1:1:T D . . S Y=$P(Y(I),";",1) . . X DIC("S") I D CODESOUT . I DIEHECNT'=$G(DIERR) D HKERR^DILIBF(F,"",D,"set of codes screen") Q UNSCRNCD(DIEHZ) ; N Y,A,T,I D CODES I $D(Y) D . D BLD^DIALOG(9101) . F I=1:1:T D CODESOUT . Q Q ; CODES ; S A=$P(DIEHZ,U,3) I $G(DUZ("LANG"))>1,A=$P(^DD(DIEHF,DIEHFLD,0),U,3) S A=$$SETIN^DIALOGZ_";" ;NAKED I A]"" D . S T=$L(A,";")-1 . F I=1:1:T S Y(I)=$P(A,";",I) . Q Q ; CODESOUT ; S DIHELP=DIHELP+1,^TMP("DIHELP",$J,DIHELP)=$P(Y(I),":",1)_" "_$P(Y(I),":",2) Q ; VPMSG(F,D) ; N I,N,P,L D BLD^DIALOG(9103) S I=0 F S I=$O(^DD(F,D,"V",I)) Q:I="B" S N=^(I,0) D . S P(1)=$P(N,U,4),P(2)=$P(N,U,2),L=$S(I=1:"",1:"S") . D BLD^DIALOG(9117,.P,.P,"",L) . Q Q ; FOLLOW(DIEHPF,DIEHUFLG) ; D GET(DIEHPF,"",.01,DIEHUFLG_"r") Q DIEH1 DIEH1 ;SFISC/DPC-DBS HELP CON'T ;05:41 PM 8 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;; DT(DIEHDT,DIWRITE) ; **CCO/NI OPTIONAL 'DIWRITE' PARAMETER ADDED SO WE CAN CALL THIS FROM DIEQ AS WELL AS DIEFU AND DIEH FOR FOREIGN-LANGUAGE DATE-HELP N P,Q I DIEHDT'["N" S P(1)=$$EZBLD^DIALOG($S(DIEHDT["M":9110.8,1:9110.1)) ;22*85 **CCO/NI 'OR 0157' 'OR 120157' D . I DIEHDT["P" S P(2)=$$EZBLD^DIALOG(9110.2) Q ;**CCO/NI 'PAST' . I DIEHDT["F" S P(2)=$$EZBLD^DIALOG(9110.3) Q ;**CCO/NI 'FUTURE' . S P(2)=$$EZBLD^DIALOG(9110.4) ;**CCO/NI 'ASSUMES CURRENT YEAR' . S P(3)=$$EZBLD^DIALOG(9110.5) ;**CCO/NI '20 YEARS future, 80 past' . Q M I DIEHDT["M" D BLD^DIALOG(9110.7,.P,.P) G W ;22*85 I DIEHDT'["X" D . N X S X=$$EZBLD^DIALOG(9110.6) ;**CCO/NI 'MAY OMIT PRECISE DATE' . I $G(P(3))]"" S P(4)=X Q . S P(3)=X Q D BLD^DIALOG(9110,.P,.P) I DIEHDT["T"!(DIEHDT["R") D . I DIEHDT["S" S Q(1)=$$EZBLD^DIALOG(9112) ;**CCO/NI 'SECONDS ALLOWED' . I DIEHDT["R" S Q(2)=$$EZBLD^DIALOG(9113) ;**CCO/NI 'TIME REQUIRED' . D BLD^DIALOG(9111,.Q,.Q) . Q W I $G(DIWRITE) D MSG^DIALOG("WH") ;**CCO/NI NEW DIWRITE PARAMETER WRITES IT OUT Q ; DIEKMSG DIEKMSG ;SFISC/MKO-PRINT MESSAGE ABOUT BAD KEYS ;12:47 PM 18 Feb 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. MSG(DIEBADK,DIEREST) ;Print message Q:$D(DIEBADK)<2 ; N ANS,FIL,FINFO,FLD,KEY,LEV,MSG,NEW,OLD,REC,RFIL,TXT,DIERR K ^TMP("DIEMSG",$J) ; D PROMPT(DIEREST,.ANS) Q:'ANS ; W ! I DIEREST D . D L("The following field(s) have been restored to their pre-edited values:") E D L("The following field values are not valid:") D L("") ; ;Loop through root files S RFIL=0 F S RFIL=$O(DIEBADK(RFIL)) Q:'RFIL D . D FILENAME^DIKCU1(RFIL,.TXT,.FINFO) Q:'$D(FINFO) . D FILELN(.TXT,FINFO) . ; . ;Loop through keys . S KEY=0 F S KEY=$O(DIEBADK(RFIL,KEY)) Q:'KEY D .. D L(" Key: "_$P(^DD("KEY",KEY,0),U,2)) .. ; .. ;Loop through files .. S FIL=0 F S FIL=$O(DIEBADK(RFIL,KEY,FIL)) Q:'FIL D ... ; ... ;Loop through records ... S REC=0 F S REC=$O(DIEBADK(RFIL,KEY,FIL,REC)) Q:'REC D .... D RECNAME^DIKCU1("",REC,.TXT,.FINFO) .... D RECLN(.TXT,FINFO) .... ; .... ;Loop through fields .... S FLD=0 F S FLD=$O(DIEBADK(RFIL,KEY,FIL,REC,FLD)) Q:'FLD D ..... S OLD=$G(DIEBADK(RFIL,KEY,FIL,REC,FLD,"O")) ..... S NEW=$G(DIEBADK(RFIL,KEY,FIL,REC,FLD,"N")) ..... S OLD=$S(OLD]"":$$EXTERNAL^DILFD(FIL,FLD,"",OLD,"MSG"),1:"") ..... S NEW=$S(NEW]"":$$EXTERNAL^DILFD(FIL,FLD,"",NEW,"MSG"),1:"") ..... I $G(DIERR) K DIERR,MSG Q ..... D L("") ..... D L($J("",14)_"Field: "_$P(^DD(FIL,FLD,0),U)_" (#"_FLD_")") ..... D L($J("",6)_"Invalid value: "),L(NEW,1,21) ..... D:$G(DIEREST) L($J("",8)_"Restored to: "),L(OLD,1,21) .... D L("") ; I $D(^TMP("DIEMSG",$J)) D PRINT K ^TMP("DIEMSG",$J) Q ; FILELN(TXT,LEV) ; N I,MAR S MAR=$S($G(IOM)<40:80,1:IOM)-1 ; S TXT=$S(LEV:"Subfile",1:"File")_": "_TXT D WRAP^DIKCU2(.TXT,MAR-9,MAR) D L(TXT) F I=1:1 Q:'$D(TXT(I)) D L($J("",9)_TXT(I)) Q ; RECLN(TXT,LEV) ; N I,MAR S MAR=$S($G(IOM)<40:80,1:IOM)-1 ; S TXT=" Record: "_TXT D WRAP^DIKCU2(.TXT,MAR-12,MAR) D L(TXT) F I=1:1 Q:'$D(TXT(I)) D L($J("",12)_TXT(I)) Q ; L(X,A,LM) ;Add X to the DIEMSG array N LC S LC=$O(^TMP("DIEMSG",$J,""),-1) ; I '$G(LM) D Q . I '$G(A) S ^TMP("DIEMSG",$J,LC+1)=X . E S ^(LC)=^TMP("DIEMSG",$J,LC)_X ; N I,M,T S M=$S($G(IOM)<40:80,1:IOM)-1 S:M'>LM LM=0 F I=1:1 D Q:X="" . S T=$E(X,1,M-LM),X=$E(X,M-LM+1,999) . I I=1,$G(A) S ^(LC)=^TMP("DIEMSG",$J,LC)_T . E S LC=LC+1,^TMP("DIEMSG",$J,LC)=$J("",LM)_T Q ; PRINT ;Print lines stored in ^TMP("DIEMSG",$J) N I,LC,SL S SL=$S($G(IOSL)<4:24,1:IOSL) S (I,LC)=0 F S I=$O(^TMP("DIEMSG",$J,I)) Q:'I D . S LC=LC+1 . W ^TMP("DIEMSG",$J,I),! . I LC'<(SL-2) D .. N DIR,DUOUT,DTOUT,DIRUT,DIROUT,X,Y .. S DIR(0)="E" D ^DIR W !! .. S LC=0 Q ; PROMPT(DIEREST,ANS) ;Ask user whether to print report N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT W !!,$C(7)_"***** NOTE *****" W !!,"Some of the previous edits are not valid because they create one or more" W !,"duplicate keys." I $G(DIEREST) D . W " Some fields have been restored to their pre-edited" . W !,"values." W ! ; S DIR(0)="Y",DIR("B")="YES" S DIR("A")="Do you want to see a list of those fields" D ^DIR W ! S ANS=Y=1 Q DIENV DIENV ;IRMFO-SF/FM STAFF-ENVIRONMENT CHECK ROUTINE ;10/29/98 07:15 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q ; Check XPDENV 0 = Loading; 1 = Installing I 'XPDENV Q ; Loading Distribution - No Check ; INSCHK ; Do Checks During Install Only S XPDNOQUE=1 ;prevents QUEUEING of a FM patch install ; TMCHK ; Check to see if TaskMan is still running S X=$$TM^%ZTLOAD I X D . D MES^XPDUTL("* Install Stopped Because TaskMan Has NOT Been Stopped!") . D MES^XPDUTL(" Transport Global Was NOT Unloaded!") . S XPDQUIT=2 ; LINH ; Check to see if Logons are Inhibited D GETENV^%ZOSV ; $P(Y,"^",2) = Installing Volume S X=+$G(^%ZIS(14.5,"LOGON",$P(Y,"^",2))) I X D Q ; Bail Out of Install . D MES^XPDUTL("* Install Stopped Because Logon Were NOT Inhibited.") . D MES^XPDUTL(" Transport Global Was NOT Unloaded!") . S XPDQUIT=2 Q DIENVSTP DIENVSTP ;IRMFO-SF/FM STAFF-ENVIRONMENT CHECK ROUTINE ;11/6/98 12:53 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; Check XPDENV 0 = Loading; 1 = Installing I 'XPDENV Q ; Loading Distribution - No Check ; INSCHK ; Do Checks During Install Only S XPDNOQUE=1 ;prevents QUEUEING of a FM patch install ; TMCHK ; Check to see if TaskMan is still running S X=$$TM^%ZTLOAD I X,'$D(^%ZTSCH("WAIT")) D . W $C(7) . D MES^XPDUTL("* Install Stopped Because TaskMan Has NOT Been Stopped!") . D MES^XPDUTL(" Transport Global Was NOT Unloaded!") . S XPDQUIT=2 ; LINH ; Check to see if Logons are Inhibited D GETENV^%ZOSV ; $P(Y,"^",2) = Installing Volume S X=+$G(^%ZIS(14.5,"LOGON",$P(Y,"^",2))) I 'X D Q ; Bail Out of Install . W $C(7) . D BMES^XPDUTL("* Install Stopped Because Logon Were NOT Inhibited.") . D MES^XPDUTL(" Transport Global Was NOT Unloaded!") . S XPDQUIT=2 Q DIENVWRN DIENVWRN ;IRMFO-SF/FM STAFF-ENVIRONMENT CHECK ROUTINE ;10:10 AM 28 Apr 2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; Check XPDENV 0 = Loading; 1 = Installing I 'XPDENV D Q ; Loading Distribution - No Check . ; Make sure exported routines are registered in ROUTINE(#9.8) file . ; Edit FOR loop . N ROU,ZDATE,%,%H,%I,X . D NOW^%DTC . S ZDATE=% . F ROU="DDS10","DIA2","DICA3","DICN0","DIEF1","DIEFW","DIET","DILF" D .. N IEN S IEN=$O(^DIC(9.8,"B",ROU,0)) .. I 'IEN D ... N FDA,DIERR,ZERR,IEN ... S IEN="+1," ... S FDA(9.8,IEN,.01)=ROU ... S FDA(9.8,IEN,1)="R" ... S FDA(9.8,IEN,7.4)=ZDATE ... D UPDATE^DIE("","FDA","IEN") ... Q .. Q . D CLEAN^DILF . Q ; INSCHK ; Do Checks During Install Only W $C(7) D MES^XPDUTL("** Although Queuing is allowed - it is HIGHLY recommended that ALL Users and") D MES^XPDUTL("VISTA Background jobs be STOPPED before installation of this patch. Failure") D MES^XPDUTL("to do so may result in 'source routine edited' error(s). Edits will be") D MES^XPDUTL("lost and record(s) may be left in an inconsistent state, for example,") D MES^XPDUTL("not all Cross-Referencing completed; which in turn may cause FUTURE") D MES^XPDUTL("VistA/FileMan Hard Errors or corrupted Data. **") ; TMCHK ; Check to see if TaskMan is still running S X=$$TM^%ZTLOAD I X,'$D(^%ZTSCH("WAIT")) D . W $C(7) . D BMES^XPDUTL("* Warning TaskMan Has NOT Been Stopped or Placed in a WAIT State!") ; LINH ; Check to see if Logons are Inhibited D GETENV^%ZOSV ; $P(Y,"^",2) = Installing Volume S X=+$G(^%ZIS(14.5,"LOGON",$P(Y,"^",2))) I 'X D . W $C(7) . D BMES^XPDUTL("* Warning Logons are NOT Inhibited!") Q DIEQ DIEQ ;SFISC/XAK,YJK-HELP DURING INPUT ;24AUG2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. BN S D=$P(DQ(DQ),U,4) S:DP+1 D=DIFLD S DZ=X D EN1 G B^DIED QQ ; I DV,DV["*",$D(^DD(+DV,.01,0)) S DQ(DQ)=$P(DQ(DQ),U,1,4)_U_$P(^(0),U,5,99) EN1 N DDH,DST,A1 S DDH=0 G M:DV I DP<0 D HP G P HELP I X="?"!(X["BAD") S X=$$HELP^DIALOGZ(DP,D),A1="T" D N:X]"" I '$G(DISORT),$D(^DD(DP,D,12)) S X=^(12) D N ;***CCO/NI HELP MESSAGE D H G:'$D(DZ) Q ; P I DV["P" K DO S DIC=U_DU,D="B",DIC(0)="M"_$E("L",DV'["'") G AST:DV["*"&('$G(DISORT)) D DQ^DICQ D % VP I DV["V" S DU=DP S:DV DU=+DO(2),D=.01 D V G Q D I DV["D" S %(0)=0 D DT^DIEH1($P($P($P(DQ(DQ),U,5,9),"%DT=""",2),""""),1) ;**CCO/NI REPLACES CALL TO HELP^%DTC S I DV["S" D:'$G(DISORT) SETSCR^DIR(DP,D) S A1="T",DST=$$EZBLD^DIALOG(8068)_" " D DS D K DIC("S") .N A,A1,A2 .S A=$P(DQ(DQ),U,3) .I $G(DUZ("LANG"))>1,A=$P(^DD(DP,D,0),U,3) S A=$$SETIN^DIALOGZ_";" ;NAKED .F DG=1:1 S Y=$P(A,";",DG) Q:Y="" S D=$P(Y,":",2),Y=$P(Y,":") I 1 X:$D(DIC("S")) DIC("S") I S A2="",$P(A2," ",15-($L(Y)+7))=" ",DST=" "_Y_A2_" "_D D DS Q K DST,A1 S:$D(DIE) DIC=DIE S D=0 I $D(DDH)>10 D LIST^DDSU D:DV UDA Q ; ; ; N F Q:X="" F %=$L(X," "):-1:1 I $L($P(X," ",1,%))<75 S DST=$P(X," ",1,%) D DS D:X'="" N1 Q S X=DZ Q ; N1 S X=$P(X," ",%+1,$L(X," ")) Q ; DS S:'$D(A1) A1="T" S DDH=$G(DDH)+1,DDH(DDH,A1)=$S(A1="X":"",1:" ")_DST K A1,DST Q ; HP I $D(DQ(DQ,3)) S A1="T",DST=DQ(DQ,3) D DS I $D(DQ(DQ,4)) S A1="X",DST=DQ(DQ,4) D DS Q ; % S %=$G(DIC("V")) K DIC S:%]"" DIC("V")=% Q ; AST S:$D(X)[0 X="?" X $P(DQ(DQ),U,5,99) K DIC G Q D ^DIC K DIC,DICS,DICW G Q ; M K DO S DZ=X,DIC=DIE_DA_","_$S(+$P(DC,U,3)=$P(DC,U,3):$P(DC,U,3),1:$C(34)_$P(DC,U,3)_$C(34))_",",D="B",DIC(0)="LM",DZ(1)=0 I '$D(@(DIC_"0)")) S DO=U_$P(DC,U,2) D DO2^DIC1 D:'$D(DO) DO^DIC1 D DDA,DQ^DICQ D % G Q:'$D(DZ)!(DV["S") S X=DZ G P ; H I '$G(DISORT),$D(^DD(DP,D,4)) S A1="X",DST=^(4) D DS,LIST^DDSU Q:'$D(DZ)!$D(DDSQ) I $G(X)?1"??".E,X'["BAD" D . N DIDG,DG,DDD,DD,DIY,DIZ,DUOUT . S DIDG=$P($G(^DD(DP,D,21,0)),U,3) . K DDSQ . I '$D(DDS) S DDD=5,DD="",DIY=99,DIZ=21 I $G(DIPGM)'="DICQ1" N DIPGM S DIPGM="DIEQ" D Z^DDSU . F DG=1:1 Q:'$D(^DD(DP,D,21,DG,0)) Q:+DIDG&(DG>DIDG) D Q:$D(DDSQ) . . I '($G(DDH)#15) D LIST^DDSU I $G(DTOUT)!($G(DUOUT)) S DDSQ=1 . . Q:$D(DDSQ) . . S DST=^DD(DP,D,21,DG,0) D DS Q . I '$D(DDSQ) Q:$D(DDH)'>10 D LIST^DDSU . I $D(DDSQ) K DDSQ,DDH . Q Q ; BK S DDH=$G(DDH)+1,DDH(DDH,"T")=" " Q ; V S DDH=+$G(DDH),A1="T",DST=$$EZBLD^DIALOG(8071) D DS EGP F Y=0:0 S Y=$O(^DD(DU,D,"V",Y)) Q:Y'>0 I $D(^(Y,0)) S Y(0)=^(0) X:$D(DIC("V")) DIC("V") I I $D(^DIC(+Y(0),0)) S Y(1)=$P(Y(0),U,4),Y(2)=$$FILENAME^DIALOGZ(+Y(0)),DST=$$EZBLD^DIALOG(8072,.Y) K Y(1),Y(2) D DS ;**CCO/NI V-P FILE NAMES D BK S DST=$$EZBLD^DIALOG(8073) D DS S DU="" D BK I DZ'?1"??".E K X,DZ Q D T^DIEQ1 K X,DZ Q ; DDA N T,% S T=$T F %=+$O(DA(" "),-1):-1:1 K DA(%+1) S:$D(DA(%))#2 DA(%+1)=DA(%) K DA(1) S:$D(DA)#2 DA(1)=DA I T Q ; UDA N T,% S T=$T S DA=$G(DA(1)) ;K DA(1) F %=2:1:+$O(DA(" "),-1) I $D(DA(%))#2 S DA(%-1)=DA(%) K DA(%) I T Q ; ;#8071 Enter one of the following ;#8072 |Prefix|.EntryName to select a |filename| ;#8073 To see the entries in any particular file type DIEQ1 DIEQ1 ;SFISC/XAK,YJK-HELP WRITE ;5/27/94 7:29 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. T S A1="T" F DG=2:1 S X=$T(T+DG) Q:X="" S DST=$E(X,4,99) D DS^DIEQ K A1,DST Q ;;If you simply enter a name then the system will search each of ;;the above files for the name you have entered. If a match is ;;found the system will ask you if it is the entry that you desire. ;; ;;However, if you know the file the entry should be in, then you can ;;speed processing by using the following syntax to select an entry: ;; . ;; or ;; . ;; or ;; . ;; ;;Also, you do NOT need to enter the entire file name or message ;;to direct the look up. Using the first few characters will suffice. DIET DIET ;SFISC/XAK-DISPLAY INPUT TEMPLATE ALSO DOES AUDITING! ;15OCT2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DICMX I '$D(^DIE(D0,0)) G EXIT S DICMX="W X,!" EN ; N DI,DIET,DIETS,D S DIET=D0 D GET^DIETED("DIETS") F D=0:0 S D=$O(DIETS(D)) Q:'D S X=DIETS(D) X DICMX Q:'$D(D) EXIT S X="" Q ; ; ; AUD N DP,DG,DPS,DIEX,DIIX,DIANUM ; From ^DICN0 DI*22*49 S DIIX="3^.01^A",DP=+DO(2) D AUDIT:DP>0 Q AUDIT ; N C,DIEDA,DIEF,%T,%F,%D,%,Y I $D(^DD(DP,+$P(DIIX,U,2),"AX")) X ^("AX") Q:'$T K % S DIEX=X D @+DIIX K DIIX,DPS,DIEX Q 3 ;'X' is NEW value I $D(DG),$D(DIANUM($P(DIIX,U,2))) S Y=X,(DIEX(1),C)=$P(^DD(DP,+$P(DIIX,U,2),0),U,2) D Y^DIQ S @DIANUM($P(DIIX,U,2))=Y K DIANUM($P(DIIX,U,2)) G I 2 ;'X' is OLD value S:$D(DP(1)) DPS=DP(1) S DIEDA="",DIEF="",%=1,DP(1)=DP,%F=+DP,X=DA F C=1:1 Q:'$D(^DD(DP(1),0,"UP")) S %F=^("UP"),%=$O(^DD(%F,"SB",DP(1),0)) G Q:'$D(DA(C)) S DIEDA=DA(C)_","_DIEDA,DIEF=%_","_DIEF,DP(1)=%F D ADD I $D(DG),+DIIX=2 S DIANUM($P(DIIX,U,2))="^DIA("_%F_","_+Y_",3)" S (DIEX(1),C)=$P(^DD(DP,+$P(DIIX,U,2),0),U,2),Y=DIEX D .N %F,%D,DA,DIEX,DP,DPS .D Y^DIQ S ^DIA(%F,"B",DIEDA_DA,%D)="",X=DIEX S:$D(DPS) DP(1)=DPS S ^DIA(%F,%D,0)=DIEDA_DA_U_%T_U_DIEF_+$P(DIIX,U,2)_U_DUZ_U_$P(DIIX,U,3),^(+DIIX)=Y I I (DIEX(1)["D")!(DIEX(1)["P")!(DIEX(1)["V")!(DIEX(1)["S") S ^(DIIX+.1)=X_U_DIEX(1) Q Q ; ; ; ; ; WP(%F,FLD,IENS,DIEFNODE) ;AUDIT WP FIELD FLD IN (SUB)FILE %F N Y,%D,%T,X S Y=+$P($G(^DD(%F,FLD,0)),U,2) Q:'Y Q:$P($G(^DD(+Y,.01,0)),U,2)'["a" Q:$G(^("AUDIT"))="e"&'$O(@DIEFNODE@(0)) S X="" F Q:'IENS S Y=%F,X=+IENS_","_X,IENS=$P(IENS,",",2,99) Q:'$G(^DD(Y,0,"UP")) S %F=^("UP"),%=$O(^DD(%F,"SB",Y,0)) I % S FLD=%_","_FLD S X=$E(X,1,$L(X)-1) D ADD S ^DIA(%F,Y,0)=X_U_%T_U_FLD_U_DUZ,^DIA(%F,"B",X,Y)="" M ^DIA(%F,Y,2.14)=@DIEFNODE Q ; ; ; ACCESSED(%F,REF) ;WILL FLAG ENTRY 'REF' IN FILE '%F' AS BEING ACCESSED BY CURRENT USER, CURRENT TIME, CURRENT OPTION N Y,X,%T,%D,%,%I,%H Q:'$G(DUZ) I '$G(DT) D NOW^%DTC S DT=X,U="^" Q:'%F!'REF S %F=+%F,(REF,X)=+REF Q:'$D(^DIC(%F)) D ADD ;COMES BACK WITH %T AND Y--THE AUDIT REF S ^DIA(%F,Y,0)=REF_U_%T_U_.01_U_DUZ_U_U_"i" S ^DIA(%F,"B",REF,Y)="" Q ; ; ; ADD S Y=$O(^DIA(%F,"A"),-1) I 'Y S ^DIA(%F,0)=$P(^DIC(%F,0),U)_" AUDIT^1.1I" F Y=Y+1:1 I '$D(^(Y)) D LOCK^DILF("^DIA(%F,Y)") I Q:'$D(^(Y)) L -^DIA(%F,Y) ;**PATCH 147 S ^(Y,0)=X L -^DIA(%F,Y) S %T=$G(XQY),%D=$S($D(XQORNOD)#2:XQORNOD,$D(HLORNOD)#2:HLORNOD,1:"") I %T!%D S ^DIA(%F,Y,4.1)=%T_U_%D S $P(^(0),U,3,4)=Y_U_($P(^DIA(%F,0),U,4)+1) TIME S %D=Y,%T=$$HTFM^DILIBF($H) S ^DIA(%F,"C",%T,Y)="",^DIA(%F,"D",DUZ,Y)="" Q DIETED DIETED ;SFISC/GFT SCREEN-EDIT AN INPUT TEMPLATE ;15NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. N DIC,DIET,DRK,DIETED,I,J,DDSCHG S DIC=.402,DIC(0)="AEQ" D ^DIC Q:Y<1 S DIET=+Y D E D PUT K K ^UTILITY("DIETEDIAB",$J),^UTILITY("DIETED",$J) Q ; EDIT(DIET) ; Edit Template using Screen Editor N DRK,DIETED,I,J E N DUOUT,DTOUT,DP,DI,D0,DIETROW,DIETEDER,DIETH,DR,F,L,DB D:'$D(DISYS) OS^DII X ^DD("OS",DISYS,"EON") I '$D(^DIE(DIET,0)) W !,"NO TEMPLATE SELECTED",! Q S DIETED="Input Template """_$P(^(0),U)_"""" W "..." D GET("^TMP(""DIETED"",$J)") S DIETH="Editing "_DIETED,DIETROW=1,DRK=$P(^DIE(DIET,0),U,4) DDW D EDIT^DDW("^TMP(""DIETED"",$J)","M",DIETH,"(File "_DRK_")",DIETROW) I $D(DUOUT)!$D(DTOUT) K DR G KL D K K I,J D PROCESS("^TMP(""DIETED"",$J)") X ^DD("OS",DISYS,"EON") S DIETROW=$O(DIETEDER(0)) I DIETROW S DIETH="ERROR! Re-editing "_DIETED K DIETEDER G DDW S DDSCHG=1 KL K ^TMP("DIETED",$J) I '$D(DR) W $C(7),$$EZBLD^DIALOG(8077) Q M ^UTILITY("DIETED",$J)=DR Q ; GET(DIETA,DIT) ;put displayable template into @DIETA N DIAO,DIETREL,DIETAD,DB,DIAT,I,J,L,DIAR,DIAB K @DIETA I '$D(DIT) S DIT=$NA(^DIE(DIET)) S (DR,DIAT)="",(DIETAD,L,DIAO,DB,DIAR)=0,F=-1 S J(0)=$P(@DIT@(0),U,4) M DI=^("DIAB") S DI=J(0) D DOWN 1 S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" S DB=DB+1 G 1 S %=+Y I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2),%="" I %_"T~"=Y!(%_"t~"=Y),$P($G(^DD(DI,%,0)),U,2) S Y=% ;HWH-1103-40934 -- ignore TITLE of MULTIPLE S DIETREL="",DIAB=$G(DI(DB,DIAR-1,DI,DIAO)) E S:Y?1"^".E DIETREL=Y S:DIAB]"" Y=DIAB I Y?1"]".E S Y=$E(Y,2,999) I DIAB="",%,$D(^DD(DI,%,0)) S Y=$P(^(0),U)_$P(Y,%,2,999) S DB=DB+1,DIETAD=DIETAD+1,@DIETA@(DIETAD)=$J("",F*3)_Y I DIETREL]"" D G 1 ;Put it in! .S L=L\100+1*100,(J(L),DI)=$P(DIETREL,U,2) D DOWN ;Relational jump I % S %=+$P($G(^DD(DI,%,0)),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'["W" S L=L+1,(J(L),DI)=% D DOWN ;Down to a multiple I Y="ALL" G UP G 1 ; DOWN S F=F+1,DIAR(F)=DIAR,DIAR=DIAR+1,%=$P(DIAT,";",DB) S:%?1"^"1.NP DB=DB+1,DIAR=$P(%,U,2) S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0 DIAT S DIAT=$G(@DIT@("DR",DIAR,DI),"ALL") Q ; NDB I DIAO'<0 S DIAO=DIAO+1 I $D(@DIT@("DR",DIAR,DI,DIAO)) S DIAT=^(DIAO),DB=1 G 1 S DIAO=-1 UP Q:'F K I(L),J(L) S L=$O(J(L),-1) S DIAR=DIAR(F),DB=DB(F),DIAO=DIAO(F),DI=J(L),DIAT=$S(DIAO<0:"",DIAO:@DIT@("DR",DIAR,J(L),DIAO),1:$G(@DIT@("DR",DIAR,DI))),F=F-1 G 1 ; ; ; ; PROCESS(DIETA) ;puts nodes into ^UTILITY("DIETED") N DIAB,LINE,DXS,L,DIAP,DIETSL,DQI,DIETSAVE,DIETAB,ERR,DIAR K DR S F=0,(DI,J(0))=DRK,I(0)=^DIC(J(0),0,"GL"),DIAP="",(L,DIETAB)=0,DXS=1,DIAR=1 F LINE=1:1 Q:'$D(@DIETA@(LINE)) K ERR S X=^(LINE) D .I X?1"^".E S LINE=999999999 K DR Q .D LINE(X) .I $D(ERR) W "LINE ",LINE S DIETEDER(LINE)=ERR,LINE=-LINE Q ;stop if we find one error I LINE<0 W " ERROR!" Q ; LINE(X) ;Process one LINE from the screen N D,DIC,DICMX,DV,DATE,Y,DICOMPX,DICOMP,DRR F D=$L(X):-1:1 Q:$A(X,D)>32 S X=$E(X,1,D-1) F D=0:1 Q:$A(X)-32 S X=$E(X,2,999) ;strip off 'D' leading spaces Q:X="" OUT I DX D G X:Y="",DR .N D,DA,DG S D(F)=J D RANGE^DIA1 S Y=DA SEMIC I X[";" S Y=X,X=$P(X,";") D G X:'$D(Y) S DIAB=Y .F %=2:1:$L(Y,";") S D=$P(Y,";",%),D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),D="T":D,1:""),DV=D_$C(126)_DV I $A(D)>45&($A(D)<58)!(D[":")!(D="") K Y Q DIC S DIC(0)="OZ",DIC="^DD(DI," D ^DIC I Y>0 S Y=+Y_DV D DR S %=+$P(Y(0),U,2) D:% Q .I $P($G(^DD(+%,.01,0)),U,2)["W" Q .S L=L+1,(DI,J(L))=+%,I(L)=""""_$P($P(Y(0),U,4),";")_"""" D D S (Y,DIETSAVE)=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) DR:X=DIETSAVE I DIETSAVE["//^",'$D(X) G X F DIETSL="///+","//+","///","//" I DIETSAVE[DIETSL S DP=$P(DIETSAVE,DIETSL,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF I DIETSAVE?.E1":" S:'$D(DIAB) DIAB=DIETSAVE K X S X=DIETSAVE,DICOMP=L_"WE",DQI="Y(",DA="DR(99,"_DXS_",",DICMX=1 D ^DICOMPW G L:$D(X) ;as in E^DIA3 X S ERR=1 Q ; L I $D(X)>1 M DR(99,DXS)=X S DXS=DXS+1 S %=-1,L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")" K X D DR S DI=+DP D D Q ; D N % S F=F+1,DIAR(F)=DIAR F %=F+1:.01 Q:'$D(DR(%,DI)) S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIAR=% S DIAP(F)=DIAP,DIAP=0,DIETAB(F)=DIETAB Q ; DEF S X=DIETSAVE D S X=$P(DIETSAVE,DIETSL),DV=DV_DIETSL_DP G X:DV[";",DIC ;as in DEF^DIA3 .S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X .S DICMX="S DWLC=DWLC+1,"_I(J)_X,DA="DR(99,"_DXS_",",X=DP,DQI="X(",DICOMP=L_"T" .D EN^DICOMP,DICS^DIA XEC .I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") ;as in XEC^DIA3 .S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") .S Y=-1 I $D(X) S Y="Q",DXS=DXS+1,DP=U_X D ..D S:'$D(DIAB) DIAB=DIETSAVE ;assume "YOU MEAN as a VARIABLE" ...N DIAB D DR .I DP="@",DIETSL="//" S DA=U_U .Q ; DR ;takes 'Y' and puts it into 'DR' array N %,B S (DRR,B)=$NA(DR(DIAR,DI)),%=$O(@DRR@(""),-1) I % S DRR=$NA(@DRR@(%)) I '$D(@DRR) S @DRR="",DIAP=0 I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR="" S @DRR=@DRR_Y_";" S DIAP=DIAP+1 DIAB I $D(DIAB) S ^UTILITY("DIETEDIAB",$J,DIAP#1000,DIAR-1,DI,DIAP\1000)=DIAB K DIAB Q ; PUT ;save template I '$D(^UTILITY("DIETED",$J)) Q N DIC S DIC("B")=DIET SAVEAS S DIC=.402,DIC("A")="Save revised "_DIETED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK" D ^DIC Q:Y<0 I $O(^DIE(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS L +^DIE(+Y) S ^DIE("F"_J(0),$P(Y,U,2),+Y)=1 S $P(^DIE(+Y,0),U,4)=J(0) L -^DIE(+Y) D SAVEFLDS(+Y) Q ; SAVEFLDS(Y) ; N X,DP,DMAX Q:'$D(^UTILITY("DIETED",$J))!'$G(Y) NOW D NOW^%DTC S $P(^DIE(Y,0),U,2)=+$J(%,0,4) S $P(^DIE(Y,0),U,5)=$G(DUZ) K ^DIE(Y,"DR") M ^DIE(+Y,"DR")=^UTILITY("DIETED",$J) K ^DIE(Y,"DIAB") M ^DIE(+Y,"DIAB")=^UTILITY("DIETEDIAB",$J) S X=$S('$D(^DIE(+Y,"ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),DP=+$P(^(0),U,4),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ D K Q DIEV DIEV ;SFISC/DPC-DATA VALIDATOR ;22SEP2009 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 11 ;Per VHA Directive 2004-038, this routine should not be modified. VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ; VALX ; N DIEV0,DIEVP2,DA,D,I,C,G K DIEVANS I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIEVFLG=$G(DIEVFLG) I '$$VERFLG^DIEFU(DIEVFLG,"HFERYUK") G OUT D FLDVAL G:$G(DIEVAL)=U OUT IENS S G=$G(DIEVIEN) I G]"" S:G'?.E1"," G=G_"," S C=$L(G,",")-1 F I=1:1:C S D="D"_(C-I) N @D S @D=$P(G,",",I) I @D="" D BLD^DIALOG(308,$G(DIEVIEN)) G OUT S DIEVIEN=G D DA^DIEFU(G,.DA) D AUXVAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,.DIEVANS,.DIEV0,.DIEVP2) I $G(DIEVANS)=U!("@"[DIEVAL) G OUT MINVAL ; D INT(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,.DIEVANS,$G(DIEV0),$G(DIEVP2)) I DIEVANS=U D ERR G OUT I DIEVFLG'["U",$G(DIEVIEN)'?."," D KEY(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVANS,.DIEVANS) OUT S DIEVANS=$G(DIEVANS,U) I DIEVFLG["F",DIEVANS'=U D FDA I $G(DIOUTAR)]"" D CALLOUT^DIEFU(DIOUTAR) Q ; FLDVAL ; N DIEVOUT S DIEVOUT=0 I '$$VFILE^DIEFU(DIEVF,"D") S DIEVAL=U Q I '$$VFIELD^DIEFU(DIEVF,DIEVFLD,"D") S DIEVAL=U Q S DIEV0=^DD(DIEVF,DIEVFLD,0),DIEVP2=$P(DIEV0,U,2) D DTYPE I DIEVOUT=1 S DIEVAL=U Q ; AUXVAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEV0,DIEVP2) ; N DIEVOUT S DIEVOUT=0 I '$D(DIOVRD),$P($G(^DD($$FNO^DILIBF(DIEVF),0,"DI")),U,2)="Y",DIEVFLG'["Y" D G AUXERR . N INT,EXT S INT(1)=$$FILENM^DIEFU(DIEVF),EXT("FILE")=DIEVF . D BLD^DIALOG(405,.INT,.EXT) I $P(DIEV0,U,5,99)["DINUM","@"'[DIEVAL D G AUXERR . N EXT,INT S EXT("FILE")=DIEVF,EXT("FIELD")=DIEVFLD,(INT(1),EXT(1))="DINUMed" . D BLD^DIALOG(520,.INT,.EXT) I $E(DIEVAL)="?"!(DIEVP2["V"&(DIEVAL[".?")) N P S P(1)=DIEVF,P(2)=DIEVFLD D BLD^DIALOG(1610,"",.P) G AUXERR I DIEVFLG["R" G:'$$VENTRY^DIEFU(DIEVF,DIEVIEN,"D9") AUXERR I DIEVP2["I",$$DATA(DIEVF,DIEVFLD) N P S P("FIELD")=DIEVFLD,P("FILE")=DIEVF D BLD^DIALOG(710,.P,.P) G AUXERR I "@"[DIEVAL D DELETE G:DIEVOUT AUXERR Q I DIEVFLG["I" D . S DIEVANS=DIEVAL . I DIEVFLG["E" S DIEVANS(0)=$$EXTERNAL^DILFD(DIEVF,DIEVFLD,"",DIEVAL) Q AUXERR S DIEVANS=U Q ; DTYPE ; I DIEVP2 D S DIEVOUT=1 Q . N T,INT,EXT D DTYP^DIOU(DIEVF,DIEVFLD,.T) . I T=5 S INT(1)="word-processing",EXT("FIELD")=DIEVFLD,EXT("FILE")=DIEVF D BLD^DIALOG(520,.INT,.EXT) Q . S INT(1)="multi-valued",EXT("FIELD")=DIEVFLD,EXT("FILE")=DIEVF D BLD^DIALOG(520,.INT,.EXT) I DIEVP2["C" N INT,EXT S INT(1)="computed",EXT("FIELD")=DIEVFLD,EXT("FILE")=DIEVF D BLD^DIALOG(520,.INT,.EXT) S DIEVOUT=1 Q Q ; DELETE ; I $D(^DD(DIEVF,DIEVFLD,"DEL")) D . N DIEVECNT S DIEVECNT=$G(DIERR) . N I S I="" F S I=$O(^DD(DIEVF,DIEVFLD,"DEL",I)) Q:I="" X $G(^(I,0)) I S DIEVOUT=1 . I DIEVECNT'=$G(DIERR) S DIEVOUT=1 D HKERR^DILIBF(DIEVF,$G(DIEVIEN),DIEVFLD,"DEL node") I DIEVP2["R" D . I DIEVFLD'=.01 S DIEVOUT=1 Q . I '$D(^DD(DIEVF,0,"UP")) Q . I $P($G(@$$ROOT^DILFD(DIEVF,DIEVIEN,1)@(0)),U,4)=1 S DIEVOUT=1 I 'DIEVOUT,DIEVFLG'["U",DIEVFLD'=.01 D Q:DIEVOUT . N DIEVKEY . S DIEVKEY=0 . F S DIEVKEY=$O(^DD("KEY","F",DIEVF,DIEVFLD,DIEVKEY)) Q:'DIEVKEY D . . Q:$D(^DD("KEY",DIEVKEY,0))[0 . . D ERR742^DIEVK1(DIEVF,DIEVFLD,DIEVKEY,DIEVIEN) . . S DIEVOUT=1 I 'DIEVOUT S DIEVANS="" S:DIEVFLG["E" DIEVANS(0)="" E D . N INT,EXT . S INT(1)=$$FLDNM^DIEFU(DIEVF,DIEVFLD),INT(2)=$$FILENM^DIEFU(DIEVF) . S EXT("FILE")=DIEVF,EXT("FIELD")=DIEVFLD . D BLD^DIALOG(712,.INT,.EXT) Q ; DATA(DIEVF,DIEVFLD) ; N DIEVNODE,DIEVSPOT,N S DIEVSPOT=" ",N=0 D GLRF^DIOU(DIEVF,DIEVFLD,.DIEVNODE,.DIEVSPOT) I +DIEVSPOT D . I $P($G(@DIEVNODE),U,DIEVSPOT)'="" S N=1 E I $E(DIEVSPOT)="E" D . N F,T . S F=$P($P(DIEVSPOT,"E",2),",",1),T=$P(DIEVSPOT,",",2) . I $TR($E($G(@DIEVNODE),F,T)," ")'="" S N=1 Q N ; INT(%B1,%B2,DIEVFLG,X,DIEVANS,%B3,%B) ; N %A,%E,%C,DIR,DIC,Y,DIE,%J,%T,%BA,DP,DIFLD,DDH,%BU,%I,%K,DQ,DIFILE,C,DIEVECNT,DIRDINUM I $G(%B3)="" S %B3=^DD(%B1,%B2,0),%B=$P(%B3,U,2) I %B["V" D VP^DIEV1(%B1,%B2,DIEVFLG,X,%B3,.DIEVANS) Q I %B["N" D Q:$G(DIEVANS)=U . I $L($P(X,"."))>24 S DIEVANS=U Q I %B["S" S X=$$UP^DILIBF(X) S %A=%B1_","_%B2_",V",%E=0,DIR("V")="",%T=$E(%B1) S DIEVECNT=$G(DIERR) S:DIEVFLG["N" DIRDINUM=1 D 1^DIR1 ;input transform to 52,3 KILLs off "Y" variable! I DIEVECNT'=$G(DIERR) S DIEVANS=U D HKERR^DILIBF(%B1,$G(DIEVIEN),%B2,"screen on a pointer or set of codes or in an input transform") K:$G(DIRDINUM) DINUM Q I %E S DIEVANS=U K:$G(DIRDINUM) DINUM Q S DIEVANS=$S(%B'["P":Y,1:$P(Y,U)) I DIEVFLG["E" D . I %B["S"!(%B["D") S DIEVANS(0)=$P(Y(0),U) . E I %B["P" S DIEVANS(0)=Y(0,0) . E I %B["O" D . . S DIEVECNT=$G(DIERR) . . X $G(^DD(%B1,%B2,2)) . . I DIEVECNT'=$G(DIERR) D HKERR^DILIBF(%B1,$G(DIEVIEN),%B2,"output transform") Q . . S DIEVANS(0)=Y . . Q . E S DIEVANS(0)=Y . Q Q ; KEY(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS) ;checks Key integrity for a value N DIEVKEY,DIEVFDA S DIEVKEY="" S DIEVFDA(DIEVF,DIEVIEN,DIEVFLD)=DIEVAL I '$$KEYVAL^DIEVK($E("K",DIEVFLG["K"),"DIEVFDA") K DIEVANS S DIEVANS=U Q ; FDA ; I $G(DIEVFAR)="" D BLD^DIALOG(202,"FDA") Q D LOAD^DIEF1(DIEVF,DIEVIEN,DIEVFLD,"",DIEVANS,DIEVFAR) Q ; ERR ; N INT,EXT S INT(1)=$$FLDNM^DIEFU(DIEVF,DIEVFLD),INT(2)=$$FILENM^DIEFU(DIEVF),(INT(3),EXT(3))=DIEVAL S EXT("FILE")=DIEVF,EXT("FIELD")=DIEVFLD,EXT("IENS")=$G(DIEVIEN) D BLD^DIALOG(701,.INT,.EXT) I DIEVFLG["H" D GET^DIEH(DIEVF,"",DIEVFLD,"?b") ;DA() and D0,D1,etc. passed thru symbol table Q ; CHKX ; N DIEV0,DIEVP2 K DIEVANS I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIEVFLG=$G(DIEVFLG) I '$$VERFLG^DIEFU(DIEVFLG,"HEN") G OUT D FLDVAL I $G(DIEVAL)=U D OUT Q D MINVAL Q DIEV1 DIEV1 ;SFISC/DPC -- VARIABLE POINTER VALIDATION ;1:39 PM 12 Sep 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. VP(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEV0,DIVPOUT) ; N DIVPY,DIVPHITF,DIVPZ,DIVPVP,DIVPRNUM,DIVPFILE,DIVPSAVV,DIVPAMB,DIVPFLK K DIVPOUT S DIVPAMB=0 I DIEVAL'["."!($P(DIEVAL,".")="") D ALL,DONE Q S DIVPSAVV=DIEVAL,DIVPFLK=$P(DIVPSAVV,"."),DIEVAL=$P(DIVPSAVV,".",2,99) N DIVPVPS D VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS) I $D(DIVPVPS) D . S DIVPVP="" . F S DIVPVP=$O(DIVPVPS(DIVPVP)) Q:DIVPVP="" D FINDVP Q:DIVPAMB I DIVPAMB S DIVPOUT=U Q I $D(DIVPY) D DONE Q S DIEVAL=DIVPSAVV D ALL,DONE Q ; ALL ; N DIVPORD S DIVPORD=0 F S DIVPORD=$O(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD)) Q:'DIVPORD D Q:DIVPAMB . S DIVPVP=$O(^DD(DIEVF,DIEVFLD,"V","O",DIVPORD,"")) . D FINDVP Q ; VPNUMS(DIEVF,DIEVFLD,DIVPFLK,DIVPVPS) ; I $D(^DD(DIEVF,DIEVFLD,"V","P",DIVPFLK)) S DIVPVPS($O(^(DIVPFLK,"")))="" Q N DIVPMES S DIVPMES="" F S DIVPMES=$O(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES)) Q:DIVPMES="" D . I $P(DIVPMES,DIVPFLK)="" S DIVPVPS($O(^DD(DIEVF,DIEVFLD,"V","M",DIVPMES,"")))="" S DIVPFILE=0 F S DIVPFILE=$O(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE)) Q:DIVPFILE="" D . I $P($$GET1^DID(DIVPFILE,"","","NAME","","","A"),DIVPFLK)="" S DIVPVPS($O(^DD(DIEVF,DIEVFLD,"V","B",DIVPFILE,"")))="" Q ; FINDVP ; S DIVPZ=^DD(DIEVF,DIEVFLD,"V",DIVPVP,0) S DIVPFILE=+DIVPZ Q:'DIVPFILE N DIVPECNT S DIVPECNT=$G(DIERR) I $P(DIVPZ,U,5)="y",$G(^DD(DIEVF,DIEVFLD,"V",DIVPVP,1))]"" N DIC X ^DD(DIEVF,DIEVFLD,"V",DIVPVP,1) I DIVPECNT'=$G(DIERR) D HKERR^DILIBF(DIEVF,"",DIEVFLD,"variable pointer screen") Q S DIVPRNUM=$$FIND1^DIC(DIVPFILE,"","BO",DIEVAL,"",$G(DIC("S"))) I $D(^TMP("DIERR",$J,"E",299)) K DIVPY S DIVPAMB=1 I 'DIVPRNUM Q I DIVPRNUM,'$D(DIVPY) S DIVPY=DIVPRNUM,DIVPHITF=DIVPFILE Q I DIVPRNUM,$D(DIVPY) D . K DIVPY . S DIVPAMB=1 . N DIVPP S DIVPP(1)=DIEVAL D BLD^DIALOG(299,.DIVPP,.DIVPP) Q ; DONE ; I '$G(DIVPY) S DIVPOUT=U Q S DIVPOUT=DIVPY_";"_$E($$GET1^DID(DIVPHITF,"","","GLOBAL NAME","","","A"),2,99) D IT I DIVPOUT=U Q I DIEVFLG["E" S DIVPOUT(0)=$$EXTERNAL^DILFD(DIEVF,DIEVFLD,"",DIVPOUT) Q ; IT ; N X S X=DIVPOUT N DIVPECNT S DIVPECNT=$G(DIERR) I $G(DIEV0) X $P(DIEV0,U,5,99) I '$G(DIEV0) X $P(^DD(DIEVF,DIEVFLD,0),U,5,99) I DIVPECNT'=$G(DIERR) S DIVPOUT=U D HKERR^DILIBF(DIEVF,"",DIEVFLD,"input transform") Q S DIVPOUT=$G(X,U) Q ; VPFILES(DIEVF,DIEVFLD,DIVPFLK,DIVPANS) ; N DIVPVPS,DIEVFILE D VPNUMS(DIEVF,DIEVFLD,DIVPFLK,.DIVPVPS) I '$D(DIVPVPS) Q N DIVPVP S DIVPVP="" F S DIVPVP=$O(DIVPVPS(DIVPVP)) Q:DIVPVP="" D . S DIVPANS(+^DD(DIEVF,DIEVFLD,"V",DIVPVP,0))="" Q DIEVK DIEVK ;SFISC/DPC-KEY VALIDATION ;11:50 AM 5 May 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT,DIVKFIEN) ; KEYVALX ; ;Init N DIVKEYOK I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIVKEYOK=1 ; ;Check input variables S DIVKFLAG=$G(DIVKFLAG) I '$$VERFLG^DIEFU(DIVKFLAG,"KQ") S DIVKEYOK=0 G OUT S DIVKFDA=$G(DIVKFDA) I '$$VROOT^DIEFU(DIVKFDA) S DIVKEYOK=0 G OUT ; ;Load key info, and list of records to check K ^TMP("DIKK",$J) I '$$BUILD^DIEVK1(DIVKFDA,DIVKFLAG) S DIVKEYOK=0 G:DIVKFLAG["Q" OUT I $D(^TMP("DIKK",$J,"L")),'$$CHECK(DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D . S DIVKEYOK=0 ; OUT ;Move error messages if necessary and quit I $G(DIERR),$G(DIVKOUT)]"" D CALLOUT^DIEFU(DIVKOUT) K ^TMP("DIKK",$J) Q DIVKEYOK ; CHECK(DIVKFDA,DIVKFLAG,DIVKFIEN) ;Loop thru ^TMP and check key integrity N DIVKCIEN,DIVKFIL,DIVKIENS,DIVKEY,DIVKEYOK,DIVKQUIT ; ;If DIVKFIEN passed in, build list of resolved ?n ien's I $G(DIVKFIEN)]"",$D(@DIVKFIEN) D . S DIVKEY=0 . F S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY D .. S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U) .. S DIVKIENS="" .. F S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D ... Q:DIVKIENS'["?" ... I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q ... S DIVKCIEN=$$FINDCONV^DIEVK1(DIVKIENS,DIVKFIEN) ... Q:DIVKCIEN?.E1(1"+",1"?").E ... S ^TMP("DIKK",$J,"F",DIVKEY,DIVKFIL,DIVKCIEN)="" ; ;Check integrity S DIVKEYOK=1,DIVKEY=0 F S DIVKEY=$O(^TMP("DIKK",$J,"L",DIVKEY)) Q:'DIVKEY D Q:$G(DIVKQUIT) . S DIVKFIL=$P(^TMP("DIKK",$J,"L",DIVKEY),U) . S DIVKIENS="" . F S DIVKIENS=$O(^TMP("DIKK",$J,"L",DIVKEY,DIVKFIL,DIVKIENS)) Q:DIVKIENS="" D Q:$G(DIVKQUIT) .. I '$$CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,$G(DIVKFIEN)) D ... S DIVKEYOK=0 S:DIVKFLAG["Q" DIVKQUIT=1 Q DIVKEYOK ; CHKREC(DIVKEY,DIVKFIL,DIVKIENS,DIVKFDA,DIVKFLAG,DIVKFIEN) ; ;Check integrity of 1 record N ACTIENS,CONV,DA,DEC,DEL,FIL,FLD,ML,NULL,OIENS,S,SS,UIR,VAL,X ; ;Don't need to check primary key for Finding and LAYGO/Finding nodes ;used for lookup I $E(DIVKIENS)="?",$G(DIVKFLAG)["K",$P($G(^TMP("DIKK",$J,"L",DIVKEY)),U,3)="P" Q 1 ; S UIR=$G(^TMP("DIKK",$J,"L",DIVKEY,"UIR")) M SS=^("SS") Q:UIR="" 1 ; ;Set DA array D ACTDA(DIVKIENS,$G(DIVKFIEN),.DA,.CONV) ; ;Set X array and check for nulls ;Set VAL array for values exceeding max length ;Set DEC array to data extraction code K NULL,VAL,X S S=0 F S S=$O(SS(S)) Q:'S D Q:$G(DIVKFLAG)["Q"&$G(NULL)!$G(DEL) . S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2),ML=$P(SS(S),U,3) . S DEC(S)=^TMP("DIKK",$J,DIVKFIL,FIL,FLD) . S X=$$VALUE(FIL,DIVKIENS,.DA,FLD,$G(DIVKFDA),DEC(S),$G(CONV)) . I X="@",FLD=.01 S DEL=1 Q . S X(S)=X . I ML,$L(X)'0 D BLD^DIALOG(1700,"IEN for Edit Template missing or invalid") G EN2E I '$D(^DIE(Y,0)) D BLD^DIALOG(1700,"No Edit Template on file with IEN="_Y) G EN2E I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Edit Template, IEN="_Y) G EN2E I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E S DIEZRLA=$G(DIEZRLA,"DIEZRLAZ"),DIEZRIEN=Y S:DIEZRLA="" DIEZRLA="DIEZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU") S DIEZRLAF="" K @DIEZRLA D EN G:'DIEZS!(DIEZRLAF) EN2E D BLD^DIALOG(1700,"Compiling Edit Template (IEN="_DIEZRIEN_")"_$S(DIEZRLAF=0:", routine name too long",1:"")) EN2E I 'DIEZS D MSG^DIALOG() Q I $G(DIEZZMSG)]"" D CALLOUT^DIEFU(DIEZZMSG) Q ; RECOMP S DIX=1 D DIEZ Q:'$D(DIX) N DIMAX S DIMAX=DMAX F DIX=0:0 S DIX=$O(^DIE(DIX)) Q:DIX'>0 I $D(^(DIX,0)),$D(^("ROU")) S %=$P(^(0),"^",1),X=$E(^("ROU"),2,99) I X]"" S Y=DIX,DMAX=DIMAX D EN ; K K %,DDH,DIC,DIX,DIPZ,DMAX,DNM,DTOUT,DIRUT,DIROUT,DUOUT,X,Y Q ;DIALOG #101 'only those with programmer's access' ; #820 'no way to save routines on the system' ; #8020 'Should the compilation run now?' ; #8024 'Compiling template name Input template of file n' ; #8033 'Input template' UNCAF(DIEZ) ; ; for one compiled input template (DIEZ), delete its "AF" entries N %,X S X="" F S X=$O(^DIE("AF",X)) Q:X="" K:'X ^(X,DIEZ) S %=0 F S %=$O(^DIE("AF",X,%)) Q:%'>0 K:$D(^(%,DIEZ)) ^(DIEZ) Q ; UNC(DIEZ,DIFLAGS) ; ; DBS: silent entry point to uncompile an input template ; DIEZ = IEN of input template to uncompile ; DIFLAGS = flags: ; D = compiled routines are also deleted K ^DIE(DIEZ,"ROU") D UNCAF(DIEZ) I $G(DIFLAGS)["D" D . N DINAME S DINAME=$G(^DIE(DIEZ,"ROUOLD")) Q:DINAME="" . N DIROU,DISUF F DISUF="",1:1 D Q:DIROU="" . . S DIROU=DINAME_DISUF I '$$ROUEXIST^DILIBF(DIROU) S DIROU="" Q . . N X S X=DIROU X $G(^DD("OS",DISYS,"DEL")) Q ; ; DELETROU(DIEZNAME) ;DELETE THE ROUTINES NAMED 'DIEZNAME' CONCATENATED WITH NUMBER Q:DIEZNAME="" Q:$L($T(+2^@DIEZNAME),";")>2 ;TRY TO KEEP FROM BLOWING AWAY A REAL ROUTINE! N DIEZ,DIEZDEL,X,DIEZEXST,C S C=0,DIEZEXST="I $L($T(^@X))",DIEZDEL=$G(^DD("OS",DISYS,"DEL")) Q:DIEZDEL="" F DIEZ=1:1:1000 D Q:C>20 ;STOP IF THERE IS A GAP OF 20 .S X=DIEZNAME_DIEZ X DIEZEXST I X DIEZDEL S C=0 Q .S C=C+1 S X=DIEZNAME X DIEZEXST I X DIEZDEL Q DIEZ0 DIEZ0 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;13SEP2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D L DL S DQ=0,DK=0,DQFF=0 MR S DK=DK+1,DH=$P(DR,";",DK),DI=$P(DH,":",1),(DIEZP,DIEZDUP,DIEZR)="" G:'DI K:DI=0,PB S DPR=$P(DH,"//",2,99),DM=+DI S:DPR]"" DI=$P(DI,"//",1),DH="" G K:DM=DI S Y=$P(DI,DM,2,99) G MR:Y=""!'$D(^DD(DP,DM,0)) F %=1:1 S X=$P(Y,$C(126),%) Q:X="" S:X="d" DIEZDUP=X S:X="R" DIEZR=X S:X'="d"&(X'="R")&(X'="T") DIEZP=X D:X="T" .I $D(^DD(DP,DM,.1)) S DIEZP=^(.1) Q .I +$P(^DD(DP,DM,0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",$D(^(.1)) S DIEZP=^(.1) .Q S (DI,DM)=+DI G S K S DM=$P(DH,":",2),DM=$S(DM:DM,1:+DI) I DI,$D(^DD(DP,+DI)) G S NX ; S DI=$O(^DD(DP,+DI)),DIEZP="" S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM S S Y=^DD(DP,+DI,0),DV=$P(Y,U,2)_$E("#",Y["DINUM")_DIEZR_DIEZDUP ;**CCO/NI FIELD NAME (THRU NEXT 2 LINES) S X=$S(DIEZP=""&'DV:"$$LABEL^DIALOGZ(DP,DIFLD)",1:""""_DIEZP_"""") S DW=$P(Y,U,4) G NX:$A(DW)=32 I T>DMAX D SV G:DIEZQ K^DIEZ2 G S W:'$G(DIEZS) "." S DQ=DQ+1,DI=+DI,DU=$P(Y,U,3),%=" S " K DIEZOT I DV["O",$D(^(2)) D O^DIEZ2 I DQFF S %=" D:$D(DG)>9 F^DIE17,DE S DQ="_DQ_",",DQFF=0 I DV S Y=X,X=DQ_%_"D=0 K DE(1) ;"_DI D L,DRN G MUL^DIEZ2 VARS S ^UTILITY($J,U,$P(DW,";",1),$P(DW,";",2),DQ)="",T=T+35,X=DQ_%_"DW="""_DW_""",DV="""_DV_""",DU="""",DIFLD="_DI_",DLB="_X D L ;**CCO/NI COMPILE 'SET DLB=$$LABEL^DIALOGZ...' RATHER THAN FIELD NAME, SO IT WORKS FOR ANY LANGUAGE I $D(DIEZOT) S X=DIEZOT D L K DIEZOT S DIEZXREF=$O(^DD("IX","F",DP,DI,0)) I $O(^DD(DP,DI,1,0))>0!(DV["a")!DIEZXREF D . S DQFF=1,X=" S DE(DW)=""C"_DQ_U_DNM_DRN_"""" . S:DIEZXREF X=X_",DE(DW,""INDEX"")=1" . ;Determine whether this field is part of a field-level key. . ;Also, build list: DIEZKEY(uniquenessIndex)="" . ;for those indexes that are uniqueness indexes for keys. . N DIEZK,DIEZUI . K DIEZKEY S DIEZK=0 . F S DIEZK=$O(^DD("KEY","F",DP,DI,DIEZK)) Q:'DIEZK D .. S DIEZUI=$P($G(^DD("KEY",DIEZK,0)),U,4) Q:'DIEZUI .. S:$P($G(^DD("IX",DIEZUI,0)),U,6)="F" DIEZKEY(DIEZUI)="" . S:$D(DIEZKEY) X=X_",DE(DW,""KEY"")=""$$K"_DQ_"""" . D L K DIEZXREF X D PR,XREF^DIEZ2:DQFF S %=$P(Y,U,5,99),X=$F(%,"%DT=""") I X,DPR?1"/".E S Y=$F(%,"E",X) I Y S %=$E(%,1,Y-2)_$E(%,Y,999) I DPR?1"//".E S %="" D AF^DIEZ2 S X="X"_DQ_" " I "Q"[% S X=X_"Q" D L G NX S X=X_% D L I DV["F" S X=" I $D(X),X'?.ANP K X" D L S X=" Q" D L S X=" ;" D L G NX ; PB I DH="" S:'$D(DOV(DL)) DOV(DL)=0 S DOV(DL)=$O(^DIE(DIEZ,"DR",DIER,DP,DOV(DL))) S:DOV(DL)="" DOV(DL)=-1 G UP:DOV(DL)<0 S DR=^(DOV(DL)),DK=0 G MR S DQ=DQ+1 I DH?1"@".N S X=DQ_" S DQ="_(DQ+1)_" ;"_DH,^UTILITY($J,"AB",DIEZAB,DH)=DQ_U_DNM_DRN G M S X=DQ_" D:$D(DG)>9 F^DIE17,DE S Y=U,DQ="_DQ_" " I "Q"[DH S X=X_"G A" G M I DH?1"^".E S F=0,X=X_$P(DH,U,5,999),Q=$P(DH,U,1,3) D L,DRN,QFF^DIEZ2,DIERN^DIEZ2 S X=" S DGO=""^"_DNM_%_""",DC="_Q_" G DIEZ^DIE0",DRN(%)=$P(DH,U,2)_U_DIERN_U_$P(DH,U,3)_U_U_DQ_U_DRN D L S X="R"_DQ_" D DE G A" D L S X=" ;" G M S X=X_"D X"_DQ_" D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)=""F"",DW=DQ G OUT^DIE17" D L S X="X"_DQ_" "_DH D L S X=" Q" M D L G MR ; UP S DQ=DQ+1,X=DQ_" G "_(DL>1)_"^DIE17" D L,^DIEZ1 G:DIEZQ K^DIEZ2 S Y=0 LV S Y=$O(DRN(Y)) S:Y="" Y=-1 I Y<0 G ^DIEZ2 S X=DRN(Y) G LV:X=U S DRN=Y,DP=+X,DIER=$P(X,U,2),DL=DIER\1,DIE=U_$P(X,U,3),DIEZL=+$P(X,U,4),DIEZAB=$P(X,U,5)_U_DNM_$P(X,U,6),DR=$S($D(^DIE(DIEZ,"DR",DIER,DP)):^(DP),1:"0:9999999"),DRN(Y)=U D N S:+DR=.01!(DR?1"0:".E) ^(3)=^(3)_"+D G B" G DL ; PR ; D DU^DIEZ2:DU]"" S X=" G RE" I DW="0;1",DL>1,DQ=1 S X=X_":'D S DQ=2 G 2" D PR^DIEZ2:DPR]"" L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 S:X?1N.E T=T+15 Q ; SV D DRN S X=DQ+1_" D:$D(DG)>9 F^DIE17 G ^"_DNM_%,DQ=% D L,^DIEZ1 Q:DIEZQ N G NEWROU^DIEZ ; DRN F %=DRN+1:1 Q:'$D(DRN(%)) DIEZ1 DIEZ1 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;30MAY2007 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D QF^DIEZ2 S L=2,X="DE S DIE="_Q_",DIC=DIE,DP="_DP_",DL="_DL_",DIEL="_DIEZL_",DU="""" K DG,DE,DB Q:$O("_DIE_"DA,""""))=""""",DS=-1 D L S X="" DL S DS=$O(^UTILITY($J,U,DS)) S:DS="" DS=-1 I DS<0 K ^UTILITY($J,U) G CN S DSN=DS S:+DS'=DS DSN=""""_DSN_"""" S DPP=0,X=X_" I $D(^("_DSN_")) S %Z=^("_DSN_")" DP S DPP=$O(^UTILITY($J,U,DS,DPP)) I DPP="" D L S X="" G DL S %=$O(^(DPP,0)) I +DPP=DPP S Y="P(%Z,U,"_DPP_") S:%]"""" DE("_%_")=%" E S Y="E(%Z,"_+$E(DPP,2,9)_","_+$P(DPP,",",2)_") S:%'?."" "" DE("_%_")=%" F %=%:0 S %=$O(^(%)) Q:'% S Y=Y_",DE("_%_")=%" I $L(X)+$L(Y)>240 D L S X=" I " S X=X_" S %=$"_Y G DP ; CN F X=" K %Z Q"," ;","W "_$S($D(^DIE(DIEZ,"W")):"S DQ(DQ)=DLB_U_DV_U_U_DW "_^("W"),1:"W !?DL+DL-2,DLB_"": """) D L F %=1:1 S X=$E($T(TEXT+%),4,999) Q:X="" D L SAVE I $L(DNM_DRN)>8 S DIEZQ=1 W:'$G(DIEZS) $C(7),!,DNM_DRN_$$EZBLD^DIALOG(1503) S:$G(DIEZRLA)]"" DIEZRLAF=0 Q S X=DNM_DRN D:'$D(DISYS) OS^DII X ^DD("OS",DISYS,"ZS") N DIR D BLD^DIALOG(8025,DNM_DRN,"","DIR") W:'$G(DIEZS) !,DIR S:$G(DIEZRLA)]"" @DIEZRLA@(DNM_DRN)="",DIEZRLAF=1 S DRN(+DRN)=U,T=0,DRN=DQ Q ; L S L=L+.001,^UTILITY($J,0,L)=X Q ; ;DIALOG #1503 'routine name is too long...' ; #8025 'routine filed' ; TEXT ;; ;; Q ;;O D W W Y W:$X>45 !?9 ;; I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 ;; W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 K X S X("FIELD")=DIFLD,X("FILE")=DP W " ("_$$EZBLD^DIALOG(710,.X)_")" K X S X="" Q ;** ;;TR Q:DV["K"&(DUZ(0)'="@") R X:DTIME E S (DTOUT,X)=U W $C(7) ;; Q ;;A K DQ(DQ) S DQ=DQ+1 ;;B G @DQ ;;RE G A:DV["K"&(DUZ(0)'["@"),PR:$D(DE(DQ)) D W,TR ;;N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A ;;RD G QS:X?."?" I X["^" D D G ^DIE17 ;; I X="@" D D G Z^DIE2 ;; I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X ;;T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" I X?.ANP D SET^DIED I 'DDER G V ;; K DDER G X ;;P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 ;; G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z ;; I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X ;;V D @("X"_DQ) K YS ;;UNIQ I DV["U",$D(X),DIFLD=.01 K % M %=@(DIE_"""B"",X)") K %(DA) K:$O(%(0)) X ;;Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A ;;X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 ;; S X="?BAD" ;;QS S DZ=X D D,QQ^DIEQ G B ;;D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q ;;Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N ;;PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP ;;R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R ;; I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R ;; X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") I %]"" S Y=$S($G(DUZ("LANG"))'>1:%,'DIFLD:%,1:$$SET^DIQ(DP,DIFLD,Y)) ;;RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 ;;I I DV'["I",DV'["#" G RD ;; D E^DIE0 G RD:$D(X),PR ;; Q ;;SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) ;; I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" ;; E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") ;; Q ;;NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS ;;KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") DIEZ2 DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;15JUN2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K DIEZAR D RECXR^DIEZ4(.DIEZAR) K ^DIE(DIEZ,"AR") M:$D(DIEZAR) ^DIE(DIEZ,"AR")=DIEZAR S %X="^UTILITY($J,""AF"",",%Y="^DIE(""AF""," D %XY^%RCR K ^DIE(DIEZ,"AB") S %X="^UTILITY($J,""AB"",",%Y="^DIE(DIEZ,""AB""," D %XY^%RCR S ^DIE(DIEZ,"ROUOLD")=DNM,^("ROU")=U_DNM K K ^DIBT(.402,1,DIEZ),^UTILITY($J) K @DIEZTMP,DIEZTMP,DIEZAR,DIER,DIERN K DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y K DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB Q ; XREF ; N DIEZR,DIEZX,DIEZLN S X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB" D L S DIEZX=L,DIEZLN=0 ;remember cross-refs will start after 'L' F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,2),X=" S X=DE("_DQ_"),DIC=DIE" D SK ;first build the KILL XREFS I DV["a" S X=" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET" D X ;I X]"" S X="C"_DQ_" ;" D L D OVERFLO S X="C"_DQ_"S S X="""" G:DG(DQ)=X C"_DQ_"F1 K DB" D L S X="" S DIEZX=L,DIEZLN=L F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,1),X=X_" S X=DG(DQ),DIC=DIE" D SK ;then the SET XREFS I DV["a" S X=X_" I $D(DE("_DQ_"))'[0!($G(^DD(DP,DIFLD,""AUDIT""))[""y"") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET" D X D OVERFLO ;Build index code and code to check key D INDEX S X=X_" Q" D L I $D(DIEZKEY) D GETKEY^DIEZ3(DP,DI,.DIEZKEY,DQ) K DIEZKEY Q ; SK D X I "Q"[DW S X=" ;" G X I DW["Q",^DD(DP,DI,1,%,0)["MUMPS" S Q=DW,F=0 D QFF S X=" X "_Q G X S X=" "_DW X D L S DIEZLN=DIEZLN+$L(X),X="" Q ; OVERFLO I DIEZLN+T+1000 S DC=DC_D I $D("_DIE_"DA,"_DW_",+D,0)) S DE("_DQ_")=$P(^(0),U,1)" D L D PR^DIEZ0 S X="R"_DQ_" D DE" D L S X=$S(DPP:" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),1:1) G "_DQ_"+1",1:" G A") D L S X=" ;" D L,AF,DIERN S DRN(DNR)=+DV_U_DIERN_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN G NX^DIEZ0 ; DIERN ; N M S DIERN=DL+1,M=$P(DR,";",DK+1) S:M?1"^"1.NP DK=DK+1,DIERN=$P(M,U,2) Q ; AF ; S ^UTILITY($J,"AF",DP,DI,DIEZ)="" AB I '$D(^UTILITY($J,"AB",DIEZAB,DI)) S ^(DI)=DQ_U_DNM_DRN S:DPR?1"/".E ^(DI,"///")="" Q ; DU S F=0,Q=DU D QFF S X=" S DU="_Q,DU="" L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q ; O ; S F=0,Q=^(2) D QFF S DIEZOT=" S DQ("_DQ_",2)="_Q Q ; PR ; F %=1,2,3 Q:$E(DPR,%)'="/" S X=$E(DPR,%,999),Q=X,F=0 D QFF I $A(X)-94 S X=" S Y="_Q E S X=" "_$E(X,2,999) D L S X=" S Y=X" D L S X=" G Y" I %>1 S DPP=0,X=" S X=Y,DB(DQ)=1"_$S(%=3:",DE(DW,""4/"")=""""",1:"")_" G:X="""" N^DIE17:DV,A I $D(DE(DQ)),DV[""I""!(DV[""#"") D E^DIE0 G A:'$D(X)" D L S X=" G "_$S(%=3:"RD:X=""@"",Z",1:"RD") Q QF ; S F=0,Q=DIE QFF ; S F=$F(Q,"""",F) I F S Q=$E(Q,1,F-1)_$E(Q,F-1,999),F=F+1 G QFF S Q=""""_Q_"""" Q ; INDEX ;Build code field and record level cross references. ;In: ; DP = file # ; DI = field # ; DIEZKEY(xref#) = "" : for each xref that is a Uniqueness Index ; for a simple (single-field key) N DIEZCNT,DIEZFLST,DIEZI,DIEZRLST,DIEZXR,DIEZXREF S DIEZCNT=0 ; ;Get field- and record-level xrefs D LOADFLD^DIKC1(DP,DI,"KS","","@DIEZTMP@(""V"",","DIEZXREF",$NA(@DIEZTMP@("R")),.DIEZFLST,.DIEZRLST) I DIEZFLST="",DIEZRLST="" S X="C"_DQ_"F1" Q ; ;Build code for each field-level xref ;Save DIEZKEY(uniquenessIndex)=index tag # (DIEZCNT) I DIEZFLST]"" S DIEZXR=0 F S DIEZXR=$O(DIEZXREF(DP,DIEZXR)) Q:'DIEZXR D . D GETXR(DIEZXR,.DIEZCNT) . S:$D(DIEZKEY(DIEZXR))#2 DIEZKEY(DIEZXR)=DIEZCNT ; ;Build code to set the DIEZRXR array for each record-level xref S X="C"_DQ_"F"_(DIEZCNT+1) Q:DIEZRLST="" S X=X_" S DIEZRXR("_DP_",DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))" D L S X=" F DIXR="_$TR(DIEZRLST,U,",")_" S DIEZRXR("_DP_",DIXR)=""""" D L S DIEZI=0 F S DIEZI=$O(DIEZRLST(DIEZI)) Q:'DIEZI D . S X=" F DIXR="_$TR(DIEZRLST(DIEZI),U,",")_" S DIEZRXR("_DP_",DIEZIENS)=""""" D L ; S X="" Q ; GETXR(DIEZXR,DIEZCNT) ;Get code for one index DIEZXR N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZSLOG,DIEZO S DIEZCNT=$G(DIEZCNT)+1 ; ;Build code to call subroutine to set X array S X="C"_DQ_"F"_DIEZCNT_$S(DIEZCNT=1:" N X,X1,X2",1:"")_" S DIXR="_DIEZXR_" D C"_DQ_"X"_DIEZCNT_"(U) K X2 M X2=X D C"_DQ_"X"_DIEZCNT_"(""O"") K X1 M X1=X" D L ; ;Build code to check for null subscripts S DIEZNSS="",DIEZO=0 F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D . Q:'$G(DIEZXREF(DP,DIEZXR,DIEZO,"SS")) . I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]""""" . E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]""""" I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D" E S DIEZNSS=" D" ; ;Get kill logic and condition S DIEZKLOG=$G(DIEZXREF(DP,DIEZXR,"K")) I DIEZKLOG'?."^" D . S X=DIEZNSS D L . ;Get kill condition code . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"KC")) . I DIEZCOD'?."^" D .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L .. S X=" . "_DIEZCOD D L .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L . ;Get kill logic . S X=" . "_DIEZKLOG D L ; ;Get set logic and condition S DIEZSLOG=$G(DIEZXREF(DP,DIEZXR,"S")) I DIEZSLOG'?."^" D . S X=" K X M X=X2"_DIEZNSS D L . ;Get set condition code . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"SC")) . I DIEZCOD'?."^" D .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L .. S X=" . "_DIEZCOD D L .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L . ;Get set logic . S X=" . "_DIEZSLOG D L ; S X=" G C"_DQ_"F"_(DIEZCNT+1) D L ; ;Build code to set X array S DIEZF=$O(DIEZXREF(DP,DIEZXR,0)) S X="C"_DQ_"X"_DIEZCNT_"(DION) K X" D L S DIEZO=0 F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D . D BLDDEC(DP,DIEZXR,DIEZO) S X=" S X=$G(X("_DIEZF_"))" D L S X=" Q" D L Q ; BLDDEC(DP,DIEZXR,DIEZO) ;Build data extraction code N CODE,NODE,TRANS ; S CODE=$G(DIEZXREF(DP,DIEZXR,DIEZO)) Q:CODE?."^" S TRANS=$G(DIEZXREF(DP,DIEZXR,DIEZO,"T")) I TRANS'?."^" D . S X=" "_CODE D L . D DOTLINE(" I $D(X)#2 "_TRANS) . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L E I $D(DIEZXREF(DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D . S X=" S X("_DIEZO_")"_$E(CODE,4,999) D L E D . S X=" "_CODE D L . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L Q ; DOTLINE(CODE) ; I CODE[" Q"!(CODE[" Q:") D . S X=" D" D L . S X=" ."_CODE D L E S X=CODE D L Q DIEZ3 DIEZ3 ;SFISC/MKO-COMPILE INPUT TEMPLATE, BUILD CODE TO CHECK KEYS ;2:54 PM 15 Jul 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;In: ; DIEZKEY(uniqxref#) = count ; DQ = item # in DR string ; GETKEY(DIEZFIL,DIEZFLD,DIEZKEY,DQ) ;Build routine to check keys Q:'$D(DIEZKEY) N DIEZUI ; ;Build code to check field-level keys D L("K"_DQ_"() N DIMAXL,DIUIR,DIXR") S DIEZUI=0 F S DIEZUI=$O(DIEZKEY(DIEZUI)) Q:'DIEZUI D . D BLD(DIEZFIL,DIEZFLD,DIEZUI,DQ,DIEZKEY(DIEZUI)) Q ; BLD(DIEZFIL,DIEZFLD,DIEZUI,DQ,DIEZCNT) ;Get code for one index DIEZXR N DIEZMAXL,DIEZSLIS,DIEZUIR D XRINFO^DIKCU2(DIEZUI,.DIEZUIR,"",.DIEZMAXL) ; D L(" S DIXR="_DIEZUI) D L(" S @DIEZTMP@(""V"","_DIEZFIL_",DIIENS,"_DIEZFLD_",""N"")=X") D L(" N X D C"_DQ_"X"_DIEZCNT_"(""N"")") D L(" K @DIEZTMP@(""V"","_DIEZFIL_",DIIENS,"_DIEZFLD_",""N"")") D L(" S DIUIR=$NA("_DIEZUIR_") Q:'$D(@DIUIR) 1") ; I $D(DIEZMAXL) D . N ORD,X . S X="S ",ORD=0 . F S ORD=$O(DIEZMAXL(ORD)) Q:'ORD D .. S X=X_"DIMAXL("_ORD_")="_DIEZMAXL(ORD)_"," . I X?.E1"," D L(" "_$E(X,1,$L(X)-1)) ; D L(" Q $$UNIQUE^DIE17(.X,.DA,DIUIR,""C"_DQ_"X"_DIEZCNT_U_DNM_DRN_""""_$S($D(DIEZMAXL):",.DIMAXL",1:"")_")") Q ; L(X) ;Add CODE to ^UTILITY S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q DIEZ4 DIEZ4 ;SFISC/MKO-COMPILE INPUT TEMPLATE, RECORD-LEVEL INDEXES ;2:15 PM 14 Jul 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;Variables passed in through symbol table: ; DNM = Name of routine ; DRN(routine#) = "" : array of routine numbers ; DMAX = Maximum routine size ; DIEZTMP = Root of global that contains record-level index info ; ;Routine-wide variables ; T = Total byte count of current routine ; L = Last line number in current routine ; DP = file # ; DRN = routine # ; DIEZCNT = Count of xrefs processed in current routine (used as ; a line tag) ; DIEZAR(file#,xref#) = linetag^routine (returned) ; DIEZKEYR(file#,key#,uniqxref#) = Xn^routine ; RECXR(DIEZAR) ;Build routines for record-level indexes Q:'$D(@DIEZTMP@("R")) N DIEZCNT,DIEZXR,DP ; S DRN=$O(DRN(""),-1)+1 D NEWROU ; S DP=0 F S DP=$O(@DIEZTMP@("R",DP)) Q:'DP D Q:$G(DIEZQ) . S DIEZXR=0 . F S DIEZXR=$O(@DIEZTMP@("R",DP,DIEZXR)) Q:'DIEZXR D Q:$G(DIEZQ) .. D GETXR(DIEZXR) Q:$G(DIEZQ) Q:$G(DIEZQ) D SAVE Q ; GETXR(DIEZXR) ;Get code for one index DIEZXR N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZO,DIEZSLOG I T>DMAX D SAVE Q:$G(DIEZQ) D NEWROU ; S DIEZCNT=$G(DIEZCNT)+1 S DIEZAR(DP,DIEZXR)=DIEZCNT_U_DNM_DRN ; ;Build code to call subroutine to set X array D L(DIEZCNT_" N X,X1,X2 S DIXR="_DIEZXR_" D X"_DIEZCNT_"(U) K X2 M X2=X D X"_DIEZCNT_"(""F"") K X1 M X1=X") ; ;Build code to check for null subscripts S DIEZNSS="",DIEZO=0 F S DIEZO=$O(@DIEZTMP@("R",DP,DIEZXR,DIEZO)) Q:'DIEZO D . Q:'$G(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"SS")) . I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]""""" . E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]""""" I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D" E S DIEZNSS=" D" ; ;Store kill logic and condition S DIEZKLOG=$G(@DIEZTMP@("R",DP,DIEZXR,"K")) I DIEZKLOG'?."^" D . D L(DIEZNSS) . ;Build kill condition code . S DIEZCOD=$G(@DIEZTMP@("R",DP,DIEZXR,"KC")) . I DIEZCOD'?."^" D .. D L(" . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1") .. D L(" . "_DIEZCOD) .. D L(" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND") . ;Store kill logic . D L(" . "_DIEZKLOG) ; ;Store set logic and condition S DIEZSLOG=$G(@DIEZTMP@("R",DP,DIEZXR,"S")) I DIEZSLOG'?."^" D . D L(" K X M X=X2"_DIEZNSS) . ;Build set condition code . S DIEZCOD=$G(@DIEZTMP@("R",DP,DIEZXR,"SC")) . I DIEZCOD'?."^" D .. D L(" . N DIEZCOND,DIEXARR M DIEXARR=X S DIEZCOND=1") .. D L(" . "_DIEZCOD) .. D L(" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND") . ;Store set logic . D L(" . "_DIEZSLOG) ; ;Build code to check record level keys D:$D(^DD("KEY","AU",DIEZXR)) BLDKCHK(DIEZXR) D L(" Q") ; ;Build code to set X array S DIEZF=$O(@DIEZTMP@("R",DP,DIEZXR,0)) D L("X"_DIEZCNT_"(DION) K X") ; S DIEZO=0 F S DIEZO=$O(@DIEZTMP@("R",DP,DIEZXR,DIEZO)) Q:'DIEZO D BLDDEC(DIEZXR,DIEZO) D L(" S X=$G(X("_DIEZF_"))") D L(" Q") Q ; BLDDEC(DIEZXR,DIEZO) ;Build data extraction code N CODE,NODE,TRANS ; S CODE=$G(@DIEZTMP@("R",DP,DIEZXR,DIEZO)) Q:CODE?."^" S TRANS=$G(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"T")) I TRANS'?."^" D . D L(" "_CODE) . D DOTLINE(" I $D(X)#2 "_TRANS) . D L(" S:$D(X)#2 X("_DIEZO_")=X") E I $D(@DIEZTMP@("R",DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D . D L(" S X("_DIEZO_")"_$E(CODE,4,999)) E D . D L(" "_CODE) . D L(" S:$D(X)#2 X("_DIEZO_")=X") Q ; BLDKCHK(DIEZUI) ;Build code to check key for xref N DIEZKLST,DIEZMAXL,DIEZUIR,I ; D XRINFO^DIKCU2(DIEZUI,.DIEZUIR,"",.DIEZMAXL) ; ;Get list of keys with this uniqueness index S DIEZKLST="",I=0 S I=0 F S I=$O(^DD("KEY","AU",DIEZUI,I)) Q:'I S DIEZKLST=I_"," Q:DIEZKLST="" S DIEZKLST=$E(DIEZKLST,1,$L(DIEZKLST)-1) ; D L(" . I $G(DIEXEC)[""K"" D") D L(" .. N DIMAXL,DIUIR") D L(" .. S DIUIR=$NA("_DIEZUIR_") Q:'$D(@DIUIR)") ; ;Build code to set DIMAXL(order#)=maxLength I $D(DIEZMAXL) D . N ORD,X . S X="S ",ORD=0 . F S ORD=$O(DIEZMAXL(ORD)) Q:'ORD D .. S X=X_"DIMAXL("_ORD_")="_DIEZMAXL(ORD)_"," . I X?.E1"," D L(" .. "_$E(X,1,$L(X)-1)) ; D L(" .. I '$$UNIQUE^DIE17(.X,.DA,DIUIR,""X"_DIEZCNT_U_DNM_DRN_""""_$S($D(DIEZMAXL):",.DIMAXL",1:"")_") N I F I="_DIEZKLST_" S DIKEY("_DP_",I,DIIENS)=""""") Q ; L(X) ;Add CODE to ^UTILITY S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q ; DOTLINE(X) ; I X[" Q"!(X[" Q:") D . D L(" D"),L(" ."_X) E D L(X) Q ; NEWROU ;Start a new routine K ^UTILITY($J,0) S ^UTILITY($J,0,1)=DNM_DRN_" ; ;"_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),T=$L(^(1)) S ^UTILITY($J,0,2)=" ;;",T=T+$L(^(2)) S L=2,DIEZCNT=0 Q ; SAVE ;Get the next available routine number N DQ F DQ=DRN+1:1 Q:'$D(DRN(DQ)) ; ;Save current routine D SAVE^DIEZ1 Q:$G(DIEZQ) K ^UTILITY($J,0) Q DIFG DIFG ;SFISC/DG(OHPRD)-FILEGRAM INSTALLER ;10/9/95 05:50 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. I $D(DIFGREI) S DIFGLO="^DIAR(1.13,"_DIFGREI_",21," K DIFGLC I '$D(DIFGLO) S DIFGER="1^0" Q I $E(DIFGLO,$L(DIFGLO))=","!($E(DIFGLO,$L(DIFGLO))="(") E S DIFGER="1.25^0" K DIFGLO,DIFGREI Q S DIFGCHKG=$S($E(DIFGLO,$L(DIFGLO))=",":$E(DIFGLO,1,$L(DIFGLO)-1)_")",1:$P(DIFGLO,"(")) I '$D(@(DIFGCHKG)) S DIFGER="1.5^0" K DIFGCHKG,DIFGLO,DIFGREI Q D INIT,START,KILLVAR,EOJ^DIFG5 Q ; INIT S U="^" K ^UTILITY("DIFG",$J),^UTILITY("DIFGFG",$J),^UTILITY("DIFGX",$J),^UTILITY("DIFG@",$J) D DT^DICRW S DIFGEXC="F DIFGL=1:1 Q:$E(DIFGDIX,DIFGL)'="" """ S DIFGLINE="S DIFGY=$O("_DIFGLO_"DIFGY)) Q:DIFGY'>0 S DIFGDIX=^(DIFGY,0) X DIFGEXC S DIFGDIX=$E(DIFGDIX,DIFGL,255)" Q ; START S (DIFG,DIFGER,DIFGMULT,DIFGEND,DIFGO,DIFGCT,DIFGADD,DIFGTYPE,DIFGINCR,DIFGNDC)=0,DIFGY=$S('$D(DIFGLC):.9999,1:DIFGLC-.0001),DIFGNODL=1 D FILEGRAM,KILLVAR D:'DIFGER ^DIFG6 Q ; FILEGRAM X DIFGLINE I $P(DIFGDIX,"^")'="$DAT" S DIFGER=2_U_DIFGY D ERROR G X1 S DIFG("PARAM")=$P(DIFGDIX,U,4) X DIFGLINE A I $P(DIFGDIX,":")="ENVIRONMENT" S @($P($P(DIFGDIX,":",2),"=")_"="_$P(DIFGDIX,"=",2)) X DIFGLINE G A D BASEFILE^DIFG0B G:DIFGER X1 D FILE X1 Q ; FILE F DIFGL=0:0 X DIFGLINE D EVAL I DIFGTYPE="TERM"!DIFGER S DIFGTYPE="" Q Q ; EVAL D GETTYPE I DIFGER G X3 I DIFGTYPE="TERM" G X3 I DIFGTYPE="MV FIELD" D ^DIFG2 G X3 I DIFGTYPE="SV FIELD" D ^DIFG1 G X3 I DIFGTYPE="WP FIELD" D ^DIFG1 G X3 I DIFGTYPE="SWITCH" D SWITCH^DIFG0A G X3 I DIFGTYPE="SKIP" ;computed field, do not process X3 Q ; GETTYPE I DIFGDIX="^"!(DIFGDIX=":")!(DIFGDIX="$END DAT") S DIFGTYPE="TERM" G X4 I $P(DIFGDIX,U)="$DAT"!($P(DIFGDIX,":")="$DAT") S DIFGER=3_U_DIFGY,DIFGEND=1,DIFGTYPE="TERM" D ERROR G X4 I $P(DIFGDIX,U,2)[":" S DIFGSTRT=$F(DIFGDIX,"^"),DIFGFIND=$E(DIFGDIX,DIFGSTRT,245) I $E(DIFGFIND,$F(DIFGFIND,":"))="^" S DIFGTYPE="SWITCH" G X4 D EVALFLD X4 Q ; EVALFLD I DIFG("PARAM")["N" S DIFGNUM=+$P(DIFGDIX,U,2) E S DIFGNUM=$O(^DD(DIC,"B",$P(DIFGDIX,U),"")) I '$D(^DD(DIC,DIFGNUM)) S DIFGER=4_U_DIFGY D ERROR G X5 I $P(^DD(DIC,DIFGNUM,0),U,2)["C" S DIFGTYPE="SKIP" G X5 I +$P(^DD(DIC,DIFGNUM,0),U,2) S DIFGMLND=^DD(DIC,DIFGNUM,0),DIFGFLDN=DIFGNUM,DIFGNUM=+$P(DIFGMLND,U,2) S DIFGTYPE=$S($P(^DD(DIFGNUM,.01,0),U,2)'["W":"MV FIELD",1:"WP FIELD") E S DIFGTYPE="SV FIELD" X5 Q ; ERROR NEW DA,DIC,DIE,X,Y,DO S X=$P(DIFGER,U,2),DIC("DR")=".02////"_$P(DIFGER,U),DIC="^DIAR(1.13,",DIC(0)="FL" D FILE^DICN S DIFGLOG=$S(Y>0:+Y,1:-1) G:DIFGLOG=-1 X6 S B=0 F A=$S($D(DIFGLC):DIFGLC-.0001,1:0):0 S A=$O(@(DIFGLO_"A)")) Q:'A S B=B+1,^DIAR(1.13,+Y,21,B,0)=$S('$D(^UTILITY("DIFGFG",$J,A)):@(DIFGLO_"A,0)"),1:^UTILITY("DIFGFG",$J,A)) S:A=$P(DIFGER,U,2) $P(DIFGER,U,2)=B Q:^(0)["$END DAT" S ^DIAR(1.13,+Y,21,0)="^^"_B_"^"_B_"^"_DT S DIE="^DIAR(1.13,",DA=DIFGLOG,DR=".01///"_$P(DIFGER,U,2) D ^DIE K DIE,DA,DR S DIFGEROR="" X6 K A,B Q ; KILLVAR K DIFGFILE,DIFGSAVE,DA,DIC,DIFGTYPE,DIFGM,DIFGNDC,DIFGNODL,DIFGADD,DIFGMO,DIFGLAGO,DIFGSKIP,DIFGDI,DIFGDICS,DIFGADD,DIFGINCR,DIFGNODL,DIFGTYPE,DIFG("SAVE") K DIFGDA,DIFGDIC,DIFGFIND,DIFGFIRP,DIFGFLDN,DIFGHAT,DIFGNODE,DIFGNUM,DIFGSECP,DIFGSTRT,DIFGSVN,DIFGSVVL,DIFGMGBL Q DIFG0 DIFG0 ;SFISC/DG(OHPRD)-SETS UP DIC("S"), EVALS 1ST LINE OF A (SUB)FILE ; [ 05/25/93 10:17 AM ] ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. NDPC ;DETERMINE NODE,PIECE FOR DATA FOR THIS FIELD S DIFGCT=DIFGCT+1 S:DIFG("PARAM")["N" DIFGNUMF(DIFGCT)=+$P(DIFGDIX,"^",2),DIFGPC(DIFGCT)=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4) I '$D(DIFGPC(DIFGCT)) S DIFGNUMF(DIFGCT)=$O(^DD(DIC,"B",$P($P(DIFGDIX,"^"),":",2),"")),DIFGPC(DIFGCT)=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4) S DIFGHAT=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,2) I DIFGHAT["P",$P(DIFGDIX,"=",2)'?1"@"1N.N.1"E" S DIFGPTER(DIFGCT)="" D DICS D GETVAL Q ; DICS ;SET DIC("S") I $P(DIFGPC(DIFGCT),";",2)'["," S DIFGDOL="$P(^($P(DIFGPC("_DIFGCT_"),"";"")),U,$P(DIFGPC("_DIFGCT_"),"";"",2))=" E S DIFGDOL="$E(^($P(DIFGPC("_DIFGCT_"),"";"")),$P(DIFGPC("_DIFGCT_"),"";"",2))=" I '$D(DIFGDIC(DIC)) S DIFGDICS(DIC)=1 E S DIFGDICS(DIC)=DIFGDICS(DIC)+1 S DIFGDIC(DIC,DIFGDICS(DIC))="I "_DIFGDOL_$S($D(DIFGPTER(DIFGCT)):"",1:"DIFGVAL("_DIFGCT_")") Q ; GETVAL ;GETS VALUE TO RIGHT OF EQUAL SIGN I $P(DIFGDIX,"=",2)'?1"@"1N.N.1"E" S (DIFGVAL(DIFGCT),^UTILITY("DIFGX",$J,DIFGCT))=$P(DIFGDIX,"=",2) D:DIFGHAT["S" SETCODES D:DIFGHAT["D" DATE I 1 E S DIFGVAL(DIFGCT)=^UTILITY("DIFG@",$J,$P(DIFGDIX,"=",2)) S:$D(^UTILITY("DIFGX",$J,$P(DIFGDIX,"=",2))) ^UTILITY("DIFGX",$J,DIFGCT)=^($P(DIFGDIX,"=",2)) X1 Q ; SETCODES ;DETERMINE INTERNAL VALUE IF FIELD ATTRIBUTE IS SET OF CODES I $P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3)[":"_DIFGVAL(DIFGCT)_";" S DIFGSET=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3),%=$P(DIFGSET,":"_DIFGVAL(DIFGCT)_";"),%A=$L(%,";"),DIFGVAL(DIFGCT)=$P(%,";",%A) K DIFGSET,%,%A Q ; DATE ;GET INTERNAL FORM OF DATE S DIFGSAVX=X,%DT="T",X=$P(DIFGDIX,"=",2) D ^%DT S DIFGVAL(DIFGCT)=Y,X=DIFGSAVX I Y=-1 S DIFGER=5_U_DIFGY D ERROR^DIFG Q ; BASE ;BASE FILE ENTRY LINE K DIFGXRF(DIFGMULT) I $P($P(DIFGDIX,U,3),"=",2)?1"@"1N.N1"E" S (DIFGALNK,Y)=^UTILITY("DIFG@",$J,$E($P($P(DIFGDIX,U,3),"=",2),1,$L($P($P(DIFGDIX,U,3),"=",2))-1)),DIFGFLUS="" S:'Y DIFGSKIP(DIFGMULT)="" S DIFG("NOLKUP")="" I '$D(DIFG("NOLKUP")) S X=$S($P($P(DIFGDIX,U,3),"=",2)?1"@"1N.N:"`"_$S(^UTILITY("DIFG@",$J,$P($P(DIFGDIX,U,3),"=",2))["^UTILITY":"^"_$P(^($P($P(DIFGDIX,U,3),"=",2)),U,2),1:$P(^($P($P(DIFGDIX,U,3),"=",2)),U)),1:$P($P(DIFGDIX,U,3),"=",2)) I '$D(DIC) S DIC=$S(+$P(DIFGDIX,U,2):+$P(DIFGDIX,U,2),$D(^DIC("B",$P(DIFGDIX,U))):$O(^DIC("B",$P(DIFGDIX,U),"")),1:"") I DIC S:'$D(^DIC(DIC)) DIC="" I 'DIC S DIFGER=20_U_DIFGY D ERROR^DIFG I $P(DIFGDIX,U,4)]"" S DIFGXRF(DIFGMULT)=$P(DIFGDIX,U,4) Q ; FUNC ;CHECKS FUNCTION ON BASE ENTRY LINE S DIFGO=DIFGO+1 S DIFGINCR=DIFGO S %=$P(DIFGDIX,U,3),%=$P(%,"="),^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE")=$S(%?1A:%,1:"L")_"^"_DIFGY S DIFGMO(DIFGMULT)=$P(^("MODE"),U)_"^"_DIC K % Q ; DIFG0A DIFG0A ;SFISC/DG(OHPRD)-CALLED FOR CONTEXT SWITCH ;8MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SWITCH ;CONTEXT SWITCH N DIC,DIFGM,DIFGNDC,DA,DIFGINCR,DIFGSKIP,DIFGDI,DIFGMO,DIFGPOIN S DIFG=DIFG+1,(DIFGNDC,DIFGLAGO)=0 S DIFGTYPE="FILE" D BASE^DIFG0 I DIFGER G X1 D FUNC^DIFG0 I '$D(DIFG("NOLKUP")) D BEGEND I DIFGER G X1 D SET D KILLVAR0 D FILE^DIFG S DIFG=DIFG-1 D KILLVAR X1 Q ; BEGEND ;CALL DIFG3 TO PROCESS BEGIN-END BLOCK I "AL"[$P(DIFGMO(DIFGMULT),U) S DIFGSECP=$P(^DD(DIC,.01,0),U,2) S:DIFGSECP["P" DIFGPOIN="" I DIFGSECP'["'"!($D(DIFGENV("LAYGO",DIC,.01))) S DIFGLAGO=1 D ^DIFG3 Q ; SET ; I '$D(DIFGSKIP(DIFGMULT)),$D(^UTILITY("DIFG",$J,DIFGINCR,DIC)),'$D(^(DIC,"DA")) S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")=+Y,^("DR")="" I $D(DIFGSKIP(DIFGMULT)) S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")=DIFGALNK S:'$D(DIFGFLUS) ^("X")=$S($E(X)="`":$E(X,2,245)_"^N",X[("^UTILITY(""DIFG@"","_$J):X_"^N",1:X) I $D(DIFGFLUS),$P(DIFGMO(DIFGMULT),U)="L" S $P(^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE"),U)="M" S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"GL")=^DIC(DIC,0,"GL"),(DA,DIFGDA(0))=DIFGALNK I $D(^("DIC(""DR"")")) S ^("MODE")="A"_"^"_$P(^("MODE"),U,2) X2 K DIFGFLUS Q ; KILLVAR0 ;KILL VARIABLES AFTER LOOKUP FOR FILE ON THE WAY TO FIELDS K DIFGALNK,DIFGO(DIFGMULT),DIFGFLD,DIFGPC,DIFGVAL,DIFGDOL,DIFGNUMF,DIFGNOLK,DIFGLAGO,Y,DIFG("NOLKUP") Q ; KILLVAR ;KILL VARIABLES AFTER EACH CONTEXT SWITCH K DIFGDA,DIFGDIC,DIFGDOL,DIFGFIND,DIFGFIRP,DIFGFLDN,DIFGHAT,DIFGMLND,DIFGNODE,DIFGNUM,DIFGNUMF,DIFGPC,DIFGPTER,DIFGSECP,DIFGSTRT,DIFGVAL,DIFGNDC,DIFGM,DIFGFLD,DIFGDIC,DIFGSAVE,DIFGSVVL K:$P($G(DIFGMO(DIFGMULT)),U,2)]"" DIFGMOLK($P(DIFGMO(DIFGMULT),U,2)) K DIFGSKIP Q ; DIFG0B DIFG0B ;SFISC/DG(OHPRD)-PROCESS BASEFILE ; ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; BASEFILE ; S DIFGTYPE="FILE" D BASE^DIFG0 G:DIFGER X2 D FUNC^DIFG0 S DIFGLAGO=0 I $P(DIFGMO(DIFGMULT),U)="L",$D(DINUM),$D(@(^DIC(DIC,0,"GL")_"DINUM)")) S $P(^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE"),U)="M",$P(DIFGMO(DIFGMULT),U)="M" E I "AL"[$P(DIFGMO(DIFGMULT),U) S DIFGSECP=$P(^DD(DIC,.01,0),U,2) I DIFGSECP'["'"!($D(DIFGENV("LAYGO",DIC,.01))) S DIFGLAGO=1 I $D(DINUM),$P(^DD(DIC,.01,0),U,5,99)["DINUM","MD"'[$P(DIFGMO(DIFGMULT),U) S DIFGER=7_U_DIFGY D ERROR^DIFG G X2 I $D(DINUM) S ^UTILITY("DIFG",$J,DIFGINCR,DIC,$S("MD"[$P(DIFGMO(DIFGMULT),U):"DA",1:"DINUM"))=DINUM I $D(DIADD) S:"AL"'[$P(DIFGMO(DIFGMULT),U) DIFGER=8_U_DIFGY D:DIFGER ERROR^DIFG I 'DIFGER S $P(DIFGMO(DIFGMULT),U)="A",$P(^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE"),U)="A" K DIADD,DINUM I DIFGER G X2 S:$D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")) DIFGDINM="" D ^DIFG3 I DIFGER G X2 K DIFGLAGO D SET^DIFG0A D KILLVAR0^DIFG0A S DIFGBSE=^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")_"^"_DIC_$S(^("MODE")["A":"^1",1:"") X2 Q ; DIFG1 DIFG1 ;SFISC/DG(OHPRD)-SINGLE VALUED FIELDS ; [ 02/03/93 3:17 PM ] ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. START ;ASSIGNMENT STATEMENT FOR SINGLE VALUED FIELD I DIFGTYPE="WP FIELD" D WPFIELD G X1 S DIFGSECP=$P(DIFGDIX,"=",2) I DIFGSECP="^" S DIFGVAL="@" D SETDR G X1 I DIFGSECP?1"@"1N.N,'^UTILITY("DIFG@",$J,DIFGSECP),$D(DIFG("UNRESOLVED",DIFGSECP)) S DIFGER=21_U_DIFGY D ERROR^DIFG G X2 I $P(^DD(DIC,DIFGNUM,0),U,2)["P",DIFGSECP'?1"@"1N.N D LOOKUP I 1 E I DIFGSECP'?1"@"1N.N,DIFGSECP[";" D PARSE S DIFGVAL="^S X="_DIFGSECP I 1 E S DIFGVAL=$S(DIFGSECP'?1"@"1N.N:DIFGSECP,^UTILITY("DIFG@",$J,DIFGSECP)[DIFGSECP:"^S X="_"""`""_^UTILITY(""DIFG@"","_$J_","""_DIFGSECP_""")",DIFGNUM'=.01:"/"_^UTILITY("DIFG@",$J,DIFGSECP),1:"`"_^UTILITY("DIFG@",$J,DIFGSECP)) I DIFGER G X1 D SETDR K DIFGSECP,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNOLK,DIFGPARS,DIFGDOLF X1 Q ; PARSE ; PARSE AND CHANGE DIFGSECP IF CONTAINS ";" NEW I S DIFGPARS="" F I=0:0 S DIFGDOLF=$F(DIFGSECP,";") Q:'DIFGDOLF S DIFGPARS=DIFGPARS_$S(DIFGDOLF>2:""""_$E(DIFGSECP,1,DIFGDOLF-2)_"""_",1:"")_"$C(59)_" S DIFGSECP=$E(DIFGSECP,DIFGDOLF,245) S DIFGSECP=$S(DIFGSECP="":$E(DIFGPARS,1,$L(DIFGPARS)-1),1:DIFGPARS_""""_DIFGSECP_"""") Q ; SETDR ; S:'$D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR")) ^("DR")="" I $L(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR"))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^("DR")=^("DR")_DIFGNUM_"///"_DIFGVAL_";" G X2 I $D(^UTILITY("DIFG",$J,DIFGINCR,DIC,"DR",DIFGNDC)),$L(^(DIFGNDC))+$L(DIFGNUM_"///"_DIFGVAL_";")<241 S ^(DIFGNDC)=^(DIFGNDC)_DIFGNUM_"///"_DIFGVAL_";" E S DIFGNDC=DIFGNDC+1,^(DIFGNDC)=DIFGNUM_"///"_DIFGVAL_";" X2 Q ; LOOKUP ;FIELD LOOKUP S DIFG=DIFG+1 S X=$P(DIFGDIX,"=",2) S DIFGLAGO=0 I $P(^DD(DIC,DIFGNUM,0),U,2)'["'"!($D(DIFGENV("LAYGO",DIC,DIFGNUM))) S DIFGLAGO=1 D ^DIFG3 I DIFGER G X3 I Y>0 S DIFGVAL="/"_+Y G X3 S DIFGVAL="^S X="_"""`""_"_DIFGALNK X3 S DIFG=DIFG-1 K Y,DIFGLAGO Q ; WPFIELD ;PROCESS WP FIELD S DIFG("COUNT")=0 S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=DIFGFLDN F DIFGL=0:0 X DIFGLINE Q:DIFGDIX="." S DIFG("COUNT")=DIFG("COUNT")+1 D BUILD K DIFG("COUNT") Q ; BUILD ; S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"WP",DIFG("COUNT"))=$E(DIFGDIX,2,$L(DIFGDIX)-1) Q ; DIFG2 DIFG2 ;SFISC/DG(OHPRD)-PROCESSING OF MULTIPLES FROM FILEGRAM ; [ 02/02/93 4:21 PM ] ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. START ;CALLED BY DIFG S DIFG=DIFG+1 I DIFGMULT=0 S DIFGNDC=0,DIFGM(0)=DIC ;ENTERING HIGHEST LEVEL MULTIPLE N DIC D MULT I DIFGER G X1 I '$D(DIFG("NOLKUP")) D ^DIFG3 I 1 E D NOLOOK I DIFGER G X1 D SET K DIFGALNK,DIFGMLND,DIFGPC,DIFGFLD,DIFGVAL,DIFGDOL,DIFGNUMF,DIFGNOLK,DIFGLAGO,Y,DIFG("NOLKUP"),DIFG("ACGRV"),DIFGDIC(DIFGDIC) D FILE^DIFG K DIFGSKIP(DIFGMULT) ;Going up one level so kill this variable which tells lower level multiples not to do lookup D CHANGEDA S DIFG=DIFG-1 X1 Q ; MULT ;MULTIPLE FIELD LOOKUP AND CALL TO SET DR STRING FOR MULTIPLE I DIFGMULT=0 S DIFGMGBL(DIFGMULT)=$S(DIFGM(0):^DIC(DIFGM(0),0,"GL"),1:DIC),DIFGDA(DIFGMULT)=DA S DIFGNODE=$P($P(DIFGMLND,"^",4),";") S DIFGLAGO=0 I $P(^DD(DIFGNUM,.01,0),U,2)'["'"!($D(DIFGENV("LAYGO",DIFGNUM,.01))) S DIFGLAGO=1 ;Not a ptr or a ptr and laygo allowed S DIFGMULT=DIFGMULT+1 I $D(DIFGSKIP(DIFGMULT-1)) S DIFGSKIP(DIFGMULT)="" S DIFGMGBL(DIFGMULT)=DIFGMGBL(DIFGMULT-1)_DIFGDA(DIFGMULT-1)_","_""""_DIFGNODE_""""_"," S DIFGM(DIFGMULT)=DIFGNUM S DIC=DIFGNUM D BASE^DIFG0 Q:DIFGER D FUNC^DIFG0 Q ; NOLOOK ;IF NO LOOKUP REQUIRED, SET DA ARRAY F DIFGI=DIFGMULT:-1:1 S DA(DIFGI)=$S(DIFGI=1:DA,1:DA(DIFGI-1)) Q ; SET ; I '$D(DIFGSKIP(DIFGMULT)) S (DA,DIFGDA(DIFGMULT))=+Y E S (DA,DIFGDA(DIFGMULT))=DIFGALNK I '$D(DIFGFLUS) D . S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"X")=$S($E(X)="`":$E(X,2,245)_"^N",($D(DIFG("ACGRV"))!(X[("^UTILITY(""DIFG@"","_$J))):X_"^N",1:X_"^"),^("MODE")="A"_"^"_$P(^("MODE"),U,2),^("DIC(""P"")")=$P(DIFGMLND,U,2) S DIC=DIFGM(DIFGMULT) S ^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA")=DA,^("GL")=DIFGMGBL(DIFGMULT),^($S($D(DIFGSKIP(DIFGMULT))&('$D(DIFGFLUS)):"DIC(""DR"")",1:"DR"))="" F DIFGI=1:1:DIFGMULT S ^("DA("_DIFGI_")")=DA(DIFGI) I $D(DIFGSKIP(DIFGMULT)),'$D(DIFGFLUS) D ENADD^DIFG4 K DIFGTYP,DIFGFLUS ;DIFGTYP exists due to DIFG3 not killing it if DIFGTYP="MV FIELD" - Needed in case one calls ENADD^DIFG4 Q ; CHANGEDA ;BACK DOWN ONE LEVEL DA'S, I.E. DA=DA(1),DA(1)=DA(2) ETC. S DA=DA(1) I DIFGMULT>1 F DIFGI=DIFGMULT:-1:2 S DA(DIFGI-1)=DA(DIFGI) K DA(DIFGMULT) S DIFGMULT=DIFGMULT-1 Q ; DIFG3 DIFG3 ;SFISC/DG(OHPRD)-LOOKUP PROCESSING ;3/11/93 1:33 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DIFGTYP="" X DIFGLINE N DIC,DIFGDRAD,DIFGDRCT,DIFGFLUS S DIFG=DIFG+1 D BEGIN G:DIFGER X5 S DIFGTYP=$S(DIFGTYPE="MV FIELD":"MV FIELD",DIFGTYPE="SV FIELD":"SV FIELD",1:"FILE") I $D(DIFGDINM) K DIFGDINM S Y=^UTILITY("DIFG",$J,DIFGINCR,DIC,"DA") S:'$D(@(^DIC(DIC,0,"GL")_"Y)")) DIFGER=19_U_DIFGY D ERROR^DIFG:DIFGER,SET^DIFG3A:'DIFGER G X5 I '$D(DIFGNOLK) D PREDIC I 1 E I DIFGTYP="MV FIELD",$D(DIFGNOLK) D MVFIELD^DIFG3A I 1 E S DIFGDIC=DIC D ^DIFG4,SET^DIFG3A X5 S DIFG=DIFG-1 K DIFGNOLK,DIFGCOND,DIFG("CONDSET") I DIFGTYP'="MV FIELD" K DIFGTYP Q BEGIN I $P(DIFGDIX,":")'="BEGIN" S DIFGER=6_U_DIFGY D ERROR^DIFG G X S DIFGDRCT=0,DIC=$S(+$P(DIFGDIX,U,2):+$P(DIFGDIX,U,2),1:$O(^DIC("B",$P($P(DIFGDIX,U),":",2),""))),DIC("S")="F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))!('$T) X DIFGDIC(DIFGDIC,DIFGI)" I '$D(^DD(DIC)) S DIFGER=20_U_DIFGY D ERROR^DIFG G X I DIFGTYP="" S %=DIFGLAGO NEW DIFGLAGO S DIFGHAT=$P(^DD(DIC,.01,0),U,2) S DIFGLAGO=$S(%=0:0,DIFGHAT'["'":1,$D(DIFGENV("LAYGO",DIC,.01)):1,1:0) K % K DIFGHAT I DIFGTYPE="SV FIELD"!($D(DIFG("CHKCOND"))) S:$D(^DD(DIC,0,"FD")) DIFGCOND(DIFG,DIC)="" K DIFG("CHKCOND") D LINK^DIFG5 F DIFGL=0:0 X DIFGLINE S DIFGFIRP=$P(DIFGDIX,":") Q:DIFGFIRP="END"!DIFGER D LINES Q LINES I DIFGFIRP="BEGIN" D RCR S:$S($D(Y):Y<0,1:1) DIFGNOLK="" G:DIFGER X S:'$D(DIFGNOLK) X="`"_+Y S:$D(DIFGNOLK)&(DIFGTYP'="MV FIELD")&(DIFGTYP'="FILE") X=DIFGALNK D:$D(DIFGDIC(DIC))&'$D(DIFGNOLK) ARRAY^DIFG5 K Y G X I DIFGFIRP="IDENTIFIER"!(DIFGFIRP="SPECIFIER") D ^DIFG0 G:DIFGER X S:'$D(DIFGPTER(DIFGCT)) DIFGSVVL(DIFGCT)=DIFGVAL(DIFGCT) I $D(DIFGPTER(DIFGCT)) D IDENSPEC^DIFG5 G X I DIFGFIRP="KEY" S DIFGKEY="" D KEY^DIFG5 I DIFGFIRP="$DAT" S DIFGER=3_U_DIFGY D ERROR^DIFG X Q RCR N DIC,DIFGDRAD,DIFGDRCT,DIFGNOLK,DIFGFLUS S DIFG=DIFG+1,DIFG("CHKCOND")="" D BEGIN G:DIFGER X I '$D(DIFGNOLK) D PREDIC I 1 E S DIFGDIC=DIC D ^DIFG4,SET^DIFG3A I $D(DIFGDIC)#2 K DIFGCOND(DIFG,DIFGDIC) S DIFG=DIFG-1 Q PREDIC I $D(DIFGKEY) D:DIFGTYPE="MV FIELD" MVFIELD^DIFG3A G X2 S DIFGDIC=DIC I DIFGTYP="MV FIELD" D MVFIELD^DIFG3A G X2 I DIFGTYP="FILE",$P(DIFGMO(DIFGMULT),U)="A" S DIFGSKIP(DIFGMULT)="" D ^DIFG4,SET^DIFG3A G X2 I '$D(DIFGFLUS) D CALLDIC I 1 E D SET^DIFG3A X2 K DIFGKEY,DIFGSAVE(DIFG,"@NUM") K:DIFGTYP'="MV FIELD" DIFG("ACGRV") Q CALLDIC K D I $D(DIFGXRF(DIFGMULT)),(DIFGTYP="MV FIELD"!(DIFGTYP="FILE")) S DIFGX=X,X=^UTILITY("DIFG@",$J,$P(DIFGXRF(DIFGMULT),"=",2)) G:X["^UTILITY(""DIFG@""" NOLK S D=$P(DIFGXRF(DIFGMULT),"="),DIC(0)="FI" D G:$D(DIFGNK) NOLK . I $E(DIFGX)="`" S DIFGGRAV="",DIFGX=$E(DIFGX,2,245) . E NEW X S X=DIFGX X $P(^DD(DIFGDIC,.01,0),U,5,99) S:$D(X) DIFGX=X I '$D(X) S DIFGNK="" Q . F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI)) . S DIFGDIC(DIFGDIC,DIFGI)="I $P(^(0),U)=DIFGX" E I $E(X)'="`"!($P(^DD(DIFGDIC,.01,0),U,5,99)["DINUM") S DIC(0)="MFI" E S X=$E(X,2,245),DIC(0)="FI",D="B",DIFG("ACGRV")="" I $D(D),'$D(^DD(DIFGDIC,0,"IX",D)) D DOLO^DIFG5 I '$D(DIFG("FOUND")) S DIFGER=18_U_DIFGY D ERROR^DIFG G X6 K DIFGNK F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI))!$D(DIFGNK) I $P(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFGVAL",@$P(DIFGDIC(DIFGDIC,DIFGI),"=",2)["DIFG(" S DIFGNK="" I '$D(DIFG("FOUND")),'$D(DIFGNK) D @$S($D(D):"IX^DIC",1:"^DIC") NOLK I X["^UTILITY(""DIFG@"""!$D(DIFGNK) S Y=-1 I $D(DIFGX) S X=$S($D(DIFGGRAV):"`",1:"")_DIFGX K DIFGX,DIFGGRAV D CHECKY^DIFG5 D:'DIFGER SET^DIFG3A X6 K DIFG("FOUND"),D,DR,DIFGNK I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") K DIFGXRF(DIFGMULT) Q DIFG3A DIFG3A ;SFISC/DG(OHPRD)-SETS VARS BASED ON Y VALUE AFTER LOOKUP ;3/11/93 1:49 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SET ;SET VARIABLES BASED ON LOOKUP I $D(DIFGFLUS) S DIFGALNK=^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM")) I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") S DIFGSKIP(DIFGMULT)="" E S (DIFGALNK,^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM")))=$S(($D(DIFGSKIP(DIFGMULT))&(DIFGTYP="MV FIELD"!(DIFGTYP="FILE")))!($S($D(Y):Y<0,1:1)):"^UTILITY(""DIFG@"","_$J_","""_DIFGSAVE(DIFG,"@NUM")_""")",1:+Y) I DIFGALNK S ^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=X D EXTVAL I '$D(Y) S Y=-1 I DIFGTYP="MV FIELD",$D(DIFGSKIP(DIFGMULT)) E K:$D(DIFGDIC) DIFGDIC(DIFGDIC),DIFGDICS(DIFGDIC) Q ; EXTVAL ; Save external value K D I ($D(DIFG("ACGRV"))!($E(X)="`")),$D(Y),Y>0 K DIC("S") NEW Y S X=$S($E(X)="`":$E(X,2,245),1:X),DIC(0)="FIZ",D="B" D IX^DIC S:Y>0 ^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=Y(0,0) I 1 E I ($D(DIFG("ACGRV"))!($E(X)="`")),$S('$D(Y):1,Y<0:1,1:0) NEW DIC,Y S X=$S($E(X)="`":$E(X,2,245),1:X),DIC=+$P($P(^DD(DIFGDIC,.01,0),U,2),"P",2) I DIC S DIC(0)="FIZ",D="B" D IX^DIC S:Y>0 ^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=Y(0,0) Q ; MVFIELD F DIFGI=DIFGMULT:-1:1 S DA(DIFGI)=$S(DIFGI=1:DA,1:DA(DIFGI-1)) I $D(DIFGKEY) G X I $D(DIFGSKIP(DIFGMULT)) D SET G X I $P(DIFGMO(DIFGMULT),U)="A" S DIFGSKIP(DIFGMULT)="" D SET G X I '$D(DIFGFLUS) S DIC=DIFGMGBL(DIFGMULT),DIFGDIC=DIFGM(DIFGMULT) D CALLDIC^DIFG3 I 1 E D SET X Q DIFG4 DIFG4 ;SFISC/DG(OHPRD)-HANDLES FAILED IDENTIFIER, SPECIFIER, AND FIELD LOOKUPS ; [ 07/15/91 1:30 PM ] ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. START ; I DIFGTYP="FILE"!(DIFGTYP="MV FIELD") S DIFGPARM=$P(DIFGMO(DIFGMULT),U) I "DM"[DIFGPARM S DIFGER=9_U_DIFGY D ERROR^DIFG G X1 I DIFGTYP="MV FIELD" G X1 ;Call ENADD^DIFG4 from SET^DIFG2 if a MV FIELD I DIFGTYP="",'DIFGLAGO,'$D(DIFGCOND) S DIFGER=10_U_DIFGY D ERROR^DIFG G X1 I DIFGTYP="",DIFGLAGO,$D(DIFG("CONDSET")),'$D(DIFGCOND) S DIFGER=24_U_DIFGY D ERROR^DIFG G X1 I DIFGTYP="",DIFGLAGO,'$D(DIFG("CONDSET")) I DIFGTYP="",'DIFGLAGO,$D(DIFGCOND) D ^DIFG4A G X1 I DIFGTYP="SV FIELD",'DIFGLAGO,'$D(DIFGCOND(DIFG,DIFGDIC)) S DIFGER=11_U_DIFGY D ERROR^DIFG G X1 ;END for the BEGIN-END block for a SV FIELD; must have laygo to the pointed to file from the field allowed OR conditional I DIFGTYP="SV FIELD",DIFGLAGO,$D(DIFG("CONDSET")),'$D(DIFGCOND(DIFG,DIFGDIC)) S DIFGER=24_U_DIFGY D ERROR^DIFG G X1 I DIFGTYP="SV FIELD",DIFGLAGO,'$D(DIFG("CONDSET")) E I DIFGTYP="SV FIELD",'DIFGLAGO D ^DIFG4A G X1 D ENADD I $D(DIFGSVN) S DIFGADD=DIFGSVN K DIFGSVN X1 K %,DIFGPARM,DIFGADFL Q ; ENADD ; I DIFGTYP]"",DIFGTYP'="SV FIELD" S DIFGSVN=DIFGADD,DIFGADD=DIFGINCR,DIFGSKIP(DIFGMULT)="" E S DIFGADD=DIFGADD+.0001 I DIFGTYP'="MV FIELD",DIFGTYP'="FILE" D ENADD2 I $D(DIFGKEY),DIFGFIRP="KEY" S ^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")")=$S(DIFG("PARAM")["N":+$P(DIFGDIX,U,2),1:$O(^DD(DIC,"B",$P(DIFGDIX,U),"")))_"////"_$P(DIFGDIX,"=",2) G X3 I '$D(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")")) S ^("DIC(""DR"")")="" S DIFGDRCT=0 F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI)) S DIFGDIGT=+$P(DIFGDIC(DIFGDIC,DIFGI),"DIFGPC(",2) D:$D(DIFGNUMF(DIFGDIGT)) DICDR K DIFGDR,DIFGDRT,DIFGDRVL,DIFGDIGT,DIFGDRCT X3 Q ; ENADD2 ;SET VARS IF NOT MV FIELD OR FILE S ^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DA")="^UTILITY(""DIFG@"","_$J_","""_DIFGSAVE(DIFG,"@NUM")_""")",^("X")=$S($E(X)="`":$E(X,2,245)_"^N",(X["DIFG(""@")!($D(DIFG("ACGRV"))):X_"^N",1:X) S ^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"GL")=^DIC(DIFGDIC,0,"GL"),^("MODE")="A"_"^"_DIFGY Q ; DICDR ;SAVE FLD NUMBERS AND VALUES IN DIC("DR") I DIFGSVVL(DIFGDIGT)[("^UTILITY(""DIFG@"","_$J) S DIFGDRVL=$S(+@DIFGSVVL(DIFGDIGT):"/"_@DIFGSVVL(DIFGDIGT),1:"^S X="_"""`""_"_DIFGSVVL(DIFGDIGT)) E S DIFGDRVL="/"_DIFGSVVL(DIFGDIGT) I '$D(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")")) S ^("DIC(""DR"")")="" I $L(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")"))+$L(DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";")<241 S ^("DIC(""DR"")")=^("DIC(""DR"")")_DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";" G X2 I $D(^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")",DIFGDRCT)),$L(^(DIFGDRCT))+$L(DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";")<241 S ^(DIFGDRCT)=^(DIFGDRCT)_DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";" E S DIFGDRCT=DIFGDRCT+1,^UTILITY("DIFG",$J,DIFGADD,DIFGDIC,"DIC(""DR"")",DIFGDRCT)=DIFGNUMF(DIFGDIGT)_"///"_DIFGDRVL_";" X2 K DIFGDRVL Q ; DIFG4A DIFG4A ;SFISC/DG(OHPRD)-CONDITIONALS ; [ 08/21/91 5:15 PM ] ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; START ; D CHECK I $D(DIFGSTP) K DIFGSTP S DIFG("UNRESOLVED",DIFGSAVE(DIFG,"@NUM"))="" G X1 S DIFGDRCT=0 F DIFGI=1:1 Q:'$D(DIFGDIC(DIFGDIC,DIFGI)) S DIFGDIGT=+$P(DIFGDIC(DIFGDIC,DIFGI),"DIFGPC(",2) D:$D(DIFGNUMF(DIFGDIGT)) GETVAL I $E(X)="`",$S('$D(Y):1,Y<0:1,1:0) NEW DIC S DIC=+$P($P(^DD(DIFGDIC,.01,0),U,2),"P",2) I DIC S DIC(0)="FMZ" D ^DIC S:Y>0 X=Y(0,0) I X'["`" S ^UTILITY("DIFGFLD",$J,.01)=X K Y D COND ;dg/ohprd 8-21-91 I '$D(Y) S Y=-1 I Y>0 S DIFG("CONDSET")="" I Y=-1 S DIFGER=22_U_DIFGY D ERROR^DIFG K DIFGDRCT,DIFGDIGT,^UTILITY("DIFGFLD",$J) X1 Q ; CHECK ; Check for existence of higher level conds, if exist quit this level ; and continue processing NEW % S %=0 F S %=$O(DIFGCOND(%)) S:%0 K Y E I $D(Y),'$D(@(^DIC(DIFGDIC,0,"GL")_"Y)")) K Y Q ; DIFG5 DIFG5 ;SFISC/DG(OHPRD)-MISC FUNCTIONS ;3/11/93 1:25 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. CHECKY ;CHECKS Y AFTER DIC CALL I Y>0,DIFGTYP="FILE"!(DIFGTYP="MV FIELD"),$P(DIFGMO(DIFGMULT),U)="L" S ^("MODE")="M"_"^"_$P(^UTILITY("DIFG",$J,DIFGINCR,DIFGDIC,"MODE"),U,2) I Y>0 G X1 S DIFGCHEK=0 I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") S DIFGCHEK=1 I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="L",DIFGTYP'="MV FIELD" S X=$S($D(DIFG("ACGRV")):X_"^N",1:X),DIFGSKIP(DIFGMULT)="" D ^DIFG4 G X1 ;Set X to X^N if internal pointer value was used in lookup, lets ^DIFG7 know if X internal value or not I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="L",DIFGTYP="MV FIELD" S DIFGSKIP(DIFGMULT)="" G X1 I 'DIFGCHEK D ^DIFG4 G X1 I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="D" G X1 ;If no entry found to delete, continue I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="M" S DIFGER=12_U_DIFGY D ERROR^DIFG G X1 ;Lookup for entry failed (no earlier "add" since DIFGFLUS undefined - if DIFGFLUS defined, wouldn't have done ^DIC) X1 K DIFGCHEK Q ; KEY ;DETERMINE @LINK VALUE FROM KEY S DIFG("KEY","XREF")=""""_$P($P(DIFGDIX,U,3),"=")_"""",DIFG("KEY","VAL")=""""_$P(DIFGDIX,"=",2)_"""",DIFG("KEY","GLO")=^DIC(DIC,0,"GL") S Y=$O(@(DIFG("KEY","GLO")_DIFG("KEY","XREF")_","_DIFG("KEY","VAL")_","""")")) I Y="" S Y=-1 S DIFGER=13_U_DIFGY D ERROR^DIFG I 'DIFGER S (^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM")),DIFGALNK)=Y,^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=X Q ; LINK ;FINDS @NUMBER TO LINK DFN TO FROM LOOKUP I $F(DIFGDIX,"@") S DIFGSAVE(DIFG,"@NUM")="@"_+$E(DIFGDIX,$F(DIFGDIX,"@"),99) I $D(^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM"))) S DIFGFLUS="" ;Line before this checks if DIFG("@NUM") exists. If it exists because it was a modify then don't need to do the lookup. ;If exists and is equal to itself (+^UTILITY("DIFG@",$J,"@NUM"))=0, then previous reference to this @link was an add and stll don't do lookup Q ; ARRAY ;SETS EXECUTABLE ARRAY FOR DIC("S") F DIFGI=1:1 I '$D(DIFGDIC(DIC,DIFGI)) S DIFGI=DIFGI-1 Q S DIFGDIC(DIC,DIFGI)=DIFGDIC(DIC,DIFGI)_+Y,DIFGSVVL(DIFGCT)=+Y Q ; IDENSPEC ;called from ^DIFG3 S %=DIFGLAGO NEW DIFGLAGO S DIFGLAGO=$S(%=0:0,$D(DIFGENV("LAYGO",DIC,DIFGNUMF(DIFGCT))):1,DIFGHAT'["'":1,1:0) K % S DIFGSAVE(DIFG,"HX")=X,X=$P(DIFGDIX,"=",2) X DIFGLINE S DIFGSVVL(DIFGCT)="^UTILITY(""DIFG@"","_$J_",""@"_$P(DIFGDIX,"@",2)_""")" D RCR^DIFG3 G:DIFGER X S:$S($D(Y):Y<0,1:1) DIFGNOLK="" S X=DIFGSAVE(DIFG,"HX") D:$D(DIFGDIC(DIC))&'$D(DIFGNOLK) ARRAY X Q ; DOLO ;called from ^DIFG3 NEW %,%A S %A=$S($D(DIFGMGBL(DIFGMULT)):DIFGMGBL(DIFGMULT),1:^DIC(DIC,0,"GL")) F %=0:0 S %=$O(@(%A_"%)")) Q:'% I +^(%,0)=X X DIC("S") I $T S DIFG("FOUND")="",Y=% Q I '$D(DIFG("FOUND")) S Y=-1 Q ; EOJ ; S DIFGEL=DIFGY S:$G(DIFGBSE)["^UTILITY" DIFGBSE="~"_$P(DIFGBSE,U,2,99) I 'DIFGER!(DIFGER&($S($D(DIFGBSE):$S(+DIFGBSE:1,1:@($TR($P(DIFGBSE,U),"~","^"))),1:0))) S @("DIFGY="_$TR($P(DIFGBSE,U),"~","^")_"_U_$P(DIFGBSE,U,2,3)") E S DIFGY=-1 I 'DIFGER K DIFGER I $D(DIFGREI),($D(DIFGEROR)!'$D(DIFGER)) S DA=DIFGREI,DIK="^DIAR(1.13," D ^DIK K DIK,DA K DIFGI,DIFGL,DIFGDIX,DIFGLO,DIFGEND,DIFGMULT,DIFGO,DIFGCT,DIFGEXC,DIFGLINE,DIFGALNK,DIFGSAVX,DIFG,DIFGBSE,DIFGDOL,DIFGNUMF,DIFGPC,DIFGPTER,DIFGVAL,DIFGKEY,DIFGMLND,DIFGDINM,DIFGREI,DIFGCHKG,DIFGEROR,DIFGLC,DIFGENV K ^UTILITY("DIFGX",$J),^UTILITY("DIFG@",$J),^UTILITY("DIFG",$J) Q DIFG6 DIFG6 ;SFISC/DG(OHPRD)-UPDATE FILES ;2/3/93 12:23 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. START ; S DIFGORDR=0 F DIFGL=0:0 S DIFGORDR=$O(^UTILITY("DIFG",$J,DIFGORDR)) Q:DIFGORDR=""!(DIFGER) D SETVAR D:'$D(DIFGNODL) PROCESS K DIFGNODL D EOJ Q ; SETVAR ;SET UP VARIABLES FOR DI* CALLS FOR A GIVEN ENTRY IN ^UTILITY("DIFG",$J,...) S DIFGFILE=$O(^UTILITY("DIFG",$J,DIFGORDR,0)) S DIFGMODE=$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U) I DIFGMODE="D",^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA")=-1 S DIFGNODL="" G X3 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"X")) S:^("X")["^UTILITY" ^("X")="~"_$E(^("X"),2,$L(^("X"))) S X=$S($P(^("X"),U,2)'="N"!(+^("X")):$P(^("X"),U),1:@($TR($P(^("X"),U),"~","^"))) I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA(1)")) F DIFGI=1:1 Q:'$D(^("DA("_DIFGI_")")) S @("DA("_DIFGI_")="_^("DA("_DIFGI_")")) I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""P"")")) S DIC("P")=^("DIC(""P"")") ;Exists if a multiple and calling DIC to add I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""DR"")")) S DIC("DR")=^("DIC(""DR"")") ;I $D(DIC("DR")) S DIFGZRO=0 F DIFGL=0:0 S DIFGZRO=$O(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""DR"")",DIFGZRO)) Q:'DIFGZRO S DIC("DR" X3 Q ; PROCESS ;DETERMINE WHICH DI* ROUTINE(S) TO CALL FOR A GIVEN ENTRY I DIFGMODE="A" S DIC=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"GL") D CALLDIC^DIFG7 S:'DIFGER DIFGAVAL=+Y D:'DIFGER ADDCONT G X1 D BUILDDR S DIE=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"GL"),@("DA="_^("DA")) I $D(DR),DR]"" D CALLDIE^DIFG7 I $D(Y) S DIFGER=14_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG G X1 I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP")) D WP^DIFG7 I $D(Y) S DIFGER=17_"^"_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG G X1 I DIFGMODE="D",'DIFGER S DIK=DIE D CALLDIK^DIFG7 I 'DIFGER S $P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"),"^",2)="I" X1 K DIC,DIE,DIK,DA,DR,DIFGAVAL Q ; ADDCONT ;CONTINUATION OF MODE="A" PROCESSING UPON RETURN FROM ^DIC S DA=DIFGAVAL,DIE=DIC I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP")) D WP^DIFG7 I $D(Y) S DIK=DIE,@(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))="" D CALLDIK^DIFG7 S DIFGER=17_"^"_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2)_"^I" D ERROR^DIFG G X1 D BUILDDR I $D(DR),DR]"" S DA=DIFGAVAL D CALLDIE^DIFG7 I $D(Y) S DIK=DIE,@(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))="" D CALLDIK^DIFG7 S DIFGER=15_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG I 'DIFGER S @(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))=DIFGAVAL,^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA")=DIFGAVAL_"^I" D RESET Q ; BUILDDR ;SET DR (BUILD DR ARRAY IF APPROPRIATE) I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR")) S DR=^("DR") I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR"))=11 S DIFGZRO=0 F DIFGL=0:0 S DIFGZRO=$O(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR",DIFGZRO)) Q:'DIFGZRO S DR(1,DIFGFILE,DIFGZRO)=^(DIFGZRO) Q ; RESET ;RESETS MODE INDICATOR IN FILEGRAM FROM "A" TO "M" I DIFGORDR'<1 S DIFGTMP=DIFGLO_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2)_",0)",DIFGVL0=@DIFGTMP,DIFGVL1=$P(DIFGVL0,"="),DIFGVL2=$P(DIFGVL0,"=",2,3),$P(DIFGVL1,U,3)="M" E G X2 S DIFGTMP="^UTILITY(""DIFGFG"",$J,$P(^UTILITY(""DIFG"",$J,DIFGORDR,DIFGFILE,""MODE""),U,2))" S @(DIFGTMP_"=DIFGVL1_""=""_DIFGVL2") ; X2 Q ; EOJ K DIFGI,DIFGORDR,DIFGFILE,DIFGMODE,DIFGTMP,DIFGVL0,DIFGVL1,DIFGVL2,DIFGDRVL,DIFGDRPT,DIFGZRO Q DIFG7 DIFG7 ;SFISC/DG(OHPRD)-CALLS TO DIC,DIE,DIK ;9MAR2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;;22.0;VA FileMan;;Mar 30, 1999 ;THIS ROUTINE CONTAINS IHS MODIFICATIONS BY IHS/TUCSON/LAB 3/13/96 ;This routine is modified to pass back to the caller, an array, ;DIFGYFE(file,da) of all entries that were either added or edited ;during the filegram install. It is the responsibility of the ;caller to kill DIFGYFE ; CALLDIC ; I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DINUM")) S DINUM=^("DINUM") S DIADD=1,DIC(0)="FLI" I $P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"X"),U,2)]"" S X="`"_X S DLAYGO=DIFGFILE S DITC="" D ^DIC K DITC ;----- BEGIN IHS MODIFICATIONS ;ORIGINAL MODIFICATIONS BY IHS/TUCSON/LAB 3/13/96 ;COMMENTED OUT LINE BELOW AND REPLACED WITH NEXT LINE TO ADD ,K Q ;SO THAT IF THERE IS AN ERROR VARS WILL GET KILLED THEN QUIT ;I Y<1 S DIFGER=16_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG I Y<1 S DIFGER=16_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG,K Q ;ADDED NEXT LINE TO PASS BACK TO CALLER, THE IEN,FILE OF ENTRY ADDED S DIFGYFE(DIFGFILE,+Y)=$P(Y,U,3) ;COMMENTED LINE BELOW AND REPLACED BY NEXT LINE TO ADD LINE LABEL K ;SO IT COULD BE CALLED ;K DIADD,DLAYGO,DR,DINUM K K DIADD,DLAYGO,DR,DINUM ;----- END IHS MODIFICATIONS Q ; CALLDIE ; I DR[".01///"&($P(^DD(DIFGFILE,.01,0),U,5,99)["DINUM"!$D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DINUM"))) S DIFGDRVL=$P($P(DR,".01///",2),";"),DR=$P(DR,".01///"_DIFGDRVL)_$P(DR,".01///"_DIFGDRVL_";",2) NEW I F I=0:1 Q:'$D(@("D"_I)) K @("D"_I) S DITC="" D ^DIE K DITC ;----- BEGIN IHS MODIFICATION ;ORIGINAL MODIFICATION BY IHS/TUCSON/LAB 3/13/96 ;NEW LINE ADDED TO PASS BACK IEN,FILE THAT WAS EDITED I $G(DA),'$D(DIFGYFE(DIFGFILE,DA)) S DIFGYFE(DIFGFILE,DA)="" ;----- END IHS MODIFICATION Q ; WP ;PROCESS WORD PROCESSING FIELD S DIFG("FIELD")=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",0) F DIFGI=1:1 Q:'$D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",DIFGI)) D:^(DIFGI)[";" CHANGE S DR=DIFG("FIELD")_"///+"_^(DIFGI) D ^DIE K DR Q ; CHANGE ;TEXT CONTAINS A ";" S DIFGSECP=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",DIFGI) D PARSE^DIFG1 S ^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP",DIFGI)="^S X="_DIFGSECP Q ; CALLDIK ; D ^DIK Q ; DIFGA DIFGA ;SFISC/XAK-FILEGRAM TEMPLATES ;3/5/93 1:22 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DIC=DI,(DIPT,DC(0))=DA,DC(1)=0 D INIT^DIFGA1,GET^DIFGB,L S L=1,DE="",DJ=0 K DNP Q ; EN D INIT^DIFGA1 I $D(DIAX) G Q:Y'>0 L D RD I X=U!$D(DTOUT) G Q I X="",DL=1 D:DJ ^DIFGB D:$D(DIAXE01)&'(U[X) F1^DIAXMS G:(+$G(DIERR)&'(U[X)) ERR G Q I 'DJ,$E(X)="[" D TEM^DIFGB G Q:X=U D PR I $D(Y(0)),+$P(Y(0),U,2),$P(^DD(+$P(Y(0),U,2),.01,0),U,2)["W" S Y(0)=$P(Y,U,2) I $D(DIAX) S $P(Y(0),U,2)=$P(^(0),U,2) D:$D(Y) ST G Q:$D(DIRUT) I DINS,DINS

19 S Y=$P(DC(DC),U) D RW^DIR2 G 2 I DC(DC)]"" W "// " 1 R X:DTIME I '$T S DTOUT=1 Q 2 Q:'DC S DINS=X?1"^"1.E,X=$S(DINS:$E(X,2,999),X="":$P(DC(DC),U),1:X) S:DC(DC)=""&$L(X) DINS=1 S:DINS DINS=DL Q PR ; S (S,DM,DIFG,DIFGLINK)="" K DIC,Y I X="" D UP Q I X?1"""".E1"""".E G QQ I X="ALL",'DJ W " Do you mean ALL the fields in the file" S %=2 D YN^DICN S Y=$S(%<0:"",%=1:"ALL",1:%) Q:X[Y W !?10,X S DIC="^DD(DK,",DIC(0)="ZE"_$E("O",DC>0),DIC("W")="W:$P(^(0),U,2) "" (multiple)""" S DIC("S")=$S('$D(DIAX):"I $P(^(0),U,2)'[""C""",1:"") S:$D(DICS) DIC("S")=DIC("S")_" X DICS" D ^DIC Q:Y>0 I X?1"?".E K Y Q I DC,X="@" D DC K Y Q S DIC(0)="EYZ",D="GR" I $D(^DD(DK,D)),'$D(DIAX) D IX^DIC Q:$D(Y)=11 G:X'?.E1":" QQ I $L(X,":")>2 S %=$O(^DD(DK,"B",$P(X,":"),0)) G:'% QQ G:$P(^DD(DK,%,0),U,2)'["C" QQ S DM=X,DQI="DIP(",DA="",DICOMP=DIL_$E("?",''L)_"T" S (DICOMPX,DICMX)="",DIFG=$S($L(X,":")>2:5,1:1) D ^DICOMPW G:'$D(X) QQ S:+DIFG("DICOMP")=DK DM=$P(^DD(DK,+$P(DIFG("DICOMP"),U,2),0),U,1)_":" S:DIFG?1A.E DIFGLINK=DIFG,DIFG=4 Q ST ; I $D(DIAX),Y="ALL" W !,$C(7),"SORRY, THIS FUNCTIONALITY IS NOT SUPPORTED AT THIS TIME." Q I Y="ALL" D N S DJ=DJ+1 K DIFGALL Q I 'Y,$D(Y)=11 F Y=0:0 S Y=$O(Y(Y)) Q:Y'>0 S X=^DD(DK,Y,0) D Y Q:Y'>0 I $D(DIAX),$D(Y)=11,$P(Y(0),U,2)["m" W !,$C(7),"SORRY, CANNOT EXTRACT THIS TYPE OF COMPUTED FIELD AT THIS TIME." Q I DIFG]"" S %=Y,S=U_$P(DP,U,2)_U_S,X=1 D D1 S DK=+DP,Y=0,DIL=+% D Y Q I $P(Y(0),U,2) S DM=$P(Y(0),U) D D,Y S X=$P($P(Y(0),U,4),";"),I(DIL)=$S(+X=X:X,1:$C(34)_X_$C(34)),J(DIL)=DK Q S Y=+Y D Y Q ; D D D1 S DK=+$P(^DD(DK,+Y,0),U,2),DIL=DIL+1,Y=0,DIFG=3 Q D1 S DJ1(DL)=DJ,DIL(DL)=DIL,DJ=0,C(DL)=C,DL(DL)=DK,DL=DL+1,(C,C(0))=C(0)+1 Q ; U S DL=DL-1,C=C(DL),DK=DL(DL),DIL=DIL(DL) S:$D(DIAX) (DIAXF,DIAXFILE)=DIAXDL(DL) S DJ=$S(DJ&'DJ1(DL):1,1:DJ1(DL)) K:DL=1 DIAXSB I $D(DINS(DL)) S DC=DINS(DL)-1 K DINS(DL) F %=DIL:0 S %=$O(I(%)) Q:%'>0 K I(%),J(%),DJ1(%) Q ; DC I 'DINS K:DC>1 DC(DC) D DC1 S DC=DC+1 Q DC1 Q:(X'="@"!(DC'=2)) S DC=DC+1 F Q:'$D(DC(DC)) K DC(DC) S DC=DC+1 S DC=DC-2 Q ; Y S S=Y_S DJ I $D(DIAX) D DIAX Q I C,'DJ1(DL-1) S:'$D(^UTILITY("DIFG",$J,C-1)) ^(C-1)=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U I '$D(^UTILITY("DIFG",$J,C))#2 S ^(C)=DK_U_DL_U_$S(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK S:$D(DIFGALL) $P(^UTILITY("DIFG",$J,C),U,8)=1 S:S DJ=DJ+1,^(C,DJ)=S S S="" D DC:DC Q ; N S I=DL,DM="ALL",DIFGALL=1 D Y S DM="" NN S Y=.001 ;I $D(^DD(DK,Y)) D Y A S Y=$O(^DD(DK,Y)) I $D(^(Y,8)),$D(DICS) X DICS E G A I Y'>0 G UP:I'
1 D U,DC:DC Q ; QQ W $C(7)," ??" K Y Q ; DIAX I 'S,$G(DIFG)>2 S DIAXDICA=$S(DIFG=3:Y(0,0),1:DM) D ^DIAXMS I $D(DIAXUP) D UP K DIAXUP,DIAXSB Q S DIAXDK(DK)=DIAXF,DIAXDL(DL)=DIAXF I C,'$D(^UTILITY("DIFG",$J,C(DL-1))) S ^(C(DL-1))=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U_U_U_DIAXDL(DL-1)_U_DIAXDK(DL(DL-1)),DIAXE01(DIAXDL(DL-1))=(DL-1)_U_$G(DIAXSB) I '$D(^UTILITY("DIFG",$J,C))#2 S ^(C)=DK_U_DL_U_$S(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK_U_U_DIAXF_U_$S(DL>1:DIAXDK(DL(DL-1)),1:DIAXF)_U_$G(DIAXNP(DL-1)),DIAXE01(DIAXF)=DK_U_$G(DIAXSB) I S D EN2^DIAXM Q:$D(DIRUT) S S="" D DC:DC W ! Q DIFGA1 DIFGA1 ;SFISC/XAK,DCM-FILEGRAM TEMPLATES ;2/27/99 12:35 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. Q W:$D(DTOUT) $C(7) K Y,C,L,DM,DQI,DA,DICOMP,DICOMPX,I,J,S,DIL,DK K D,DIFG,DC,DICS,DP,DU,DXS,DL,DJ,DINS,DIFGLINK K DIAXLOC,DIAXMSG,DIAXGL,DIAXF,^UTILITY("DIFG",$J),DJ1,DIAXEF,DIAXDL,DIAXDI,DIAXFILE,DIAXFNO K DIAXDICA,DIAXNP,DIAXZ,DIAXDK,DTOUT,DUOUT,DIRUT D:$D(DIAX) Q1^DIAXMS Q ; INIT K ^UTILITY("DIFG",$J) S (L,DL)=1,(I(0),DI)=DIC,(DK,J(0))=+$P(@(DI_"0)"),U,2) S DINS="",(DC,DJ,C,C(0),DIL)=0 Q:'$D(DIAX) ; INET K DIC S DIC=1,DIC(0)="AEQZ",DIC("S")="I Y'<2,+Y'="_DK_" S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %",DIC("A")="DESTINATION FILE: " D ^DIC Q:Y'>0 S (DIAXF,DIAXFILE,DIAXFNO,DIAXDL(DL),DIAXDK(DK))=+Y,DIAXGL=$E(^DIC(+Y,0,"GL"),2,99),DIAXEF=Y(0,0),DIAXLOC(DIAXFILE)="" Q DIFGB DIFGB ;SFISC/XAK-STORE FILEGRAM TEMPLATE ;5/23/96 11:16 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. PUT ; W !,"STORE ",$S($D(DIAR):"ARCHIVE",$D(DIAX):"EXTRACT",1:"FILEGRAM")_" LOGIC IN TEMPLATE: " R X:DTIME S:'$T DTOUT=1,X="" G Q:U[X S DIC="^DIPT(",D="F"_DK S DIC("S")="S %=^(0) I $P(%,U,8)="_$S($D(DIAX):2,1:1)_",$P(%,U,4)=DK!'$L($P(%,U,4))"_$P(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&L) S DIC(0)="ELZSQI",DIC("S")="I Y'<1 "_DIC("S"),Y=-1,DLAYGO=0 D IX^DIC:X]"" K DIC,DLAYGO G:Y<0 PUT:X'[U,Q S S=$O(^DIPT(+Y,0))]"" I S W $C(7),!,"TEMPLATE ALREADY STORED THERE...." D W:DUZ(0)'="@" G PUT:'$T W " OK TO REPLACE" S %=0 D YN^DICN W ! G PUT:%-1 D PURGE S ^DIPT(+Y,0)=$P(Y,U,2)_U_DT_U_DUZ(0)_U_DK_U_DUZ_U_DUZ(0)_U_DT,^DIPT("F"_DK,$P(Y,U,2),+Y)=1 I '$D(DIAX) S ^DIPT("FG",$P(Y,U,2),+Y)="",$P(^DIPT(+Y,0),U,8)=1 E S $P(^DIPT(+Y,0),U,8,9)=2_U_DIAXFNO S Y=+Y,%X="" F %=1:1 S %X=$O(^UTILITY("DIFG",$J,%X)) Q:%X="" S ^DIPT(Y,1,%,0)=^(%X) D FLD S:%-1 ^DIPT(Y,1,0)="^.41^"_(%-1)_U_(%-1) I '$D(DIAX) S ^DIPT(Y,"F",2)="S DIFGT="""_$P(^DIPT(+Y,0),U)_""",DIFGBFN="_DK_" D FG^DIFGB;X" Q K ^UTILITY("DIFG",$J),DIFG Q ; PURGE L +^DIPT(+Y) S %Y=0 F %X=0:0 S %Y=$O(^DIPT(+Y,%Y)) Q:%Y="" K:%Y'="%D" ^DIPT(+Y,%Y) L -^DIPT(+Y) Q ; W S %=$P(^DIPT(+Y,0),U,6) F X=1:1:$L(%) I DUZ(0)[$E(%,X) Q Q ; FLD S %Y="" F S=1:1 S %Y=$O(^UTILITY("DIFG",$J,%X,%Y)) Q:%Y="" S ^DIPT(Y,1,%,"F",S,0)=^(%Y) S:S-1 ^DIPT(Y,1,%,"F",0)="^.411^"_(S-1)_U_(S-1) Q ; TEM ; S X=$E(X,2,99),DIC="^DIPT(",DIC(0)="SQEM",D="FG" I X["?"!($D(DIAX)) S D="F"_DK S DIC("S")="I $P(^(0),U,4)="_DK_",$P(^(0),U,8)="_$S($D(DIAX):2,1:1)_$S($D(DIAX):",$P(^(0),U,9)=DIAXFNO",1:"") D IX^DIC S X="" Q:Y<0 EN ; K DIR S DA=+Y S DIR(0)="Y",DIR("A")="WANT TO EDIT '"_$P(Y,U,2)_"' TEMPLATE" D ^DIR K DIR S:'Y!$D(DTOUT) X=U Q:'Y D DIE I '$D(DA) S DC=0 Q S DC(1)=0,DC(0)=DA K DA D GET S DJ=0,X="" ;D EN^DIFGA,PUT:X'=U Q GET S DC(1)=$O(^DIPT(DC(0),1,+DC(1))),DC=0 Q:+DC(1)'=DC(1) S %=^(DC(1),0),X=+% Q:'X S DC=1 I DL>1,$P(%,U,2)'>DL F J=$P(%,U,2):1:DL S DC=DC+1,DC(DC)="" I $D(DIAX),$P(%,U,4)>2 S $P(DC(1),U,3)=$O(^DD(+$P(%,U,9),0,"NM","")) I $P(%,U,5)]"" S DC=DC+1,DC(DC)=$P(%,U,5) F J=0:0 S J=$O(^DIPT(DC(0),1,+DC(1),"F",J)) Q:+J'=J S %=^(J,0),DIAXZ=$P(%,U,2,9),%=+%,%=$S($D(^DD(X,%,0)):$P(^(0),U),1:%) S:'% DC=DC+1,DC(DC)=%_U_DIAXZ S DC=$S($D(DC(2)):2,1:0) Q DIE N DL,DK,DI S DIE="^DIPT(",DR=".01;3;6" D ^DIE K DIE,DR S X="" Q FG ;Entry from Print template K ^UTILITY($J,"W") S DIFG("FE")=D0,DIFG("FUNC")="L",DIFG("FGR")="^UTILITY(""DIFG"",$J," I 'DIFGT S DIC="^DIPT(",D="FG",DIC("S")="I $P(^(0),U,4)="_DIFGBFN,DIC(0)="O",X=DIFGT K DIFGBFN D IX^DIC S:+Y DIFGT=+Y I Y'>0 K DIFG,DIFGT G Q I $G(DIAR)=4 S DIFG("FGR")="^DIAR(1.11,DIARC,""D""," I DIARF=DIARF2,$D(^DIC(+DIARF,0,"GL")) S D1=^("GL"),@(D1_"D0,-9)")=DIARC I $G(DIARP)]"",+DIARP'=+DIFGT S DIFGT=DIARP,^DIPT(DIARP,"F",2)="S DIFGT="_DIARP_" D FG^DIFGB;X" N DI,D0 D START^DIFGG I $D(DIARD) S DIARD=DIARD+1 W:(DIARD#50=0) !,DIARD," RECORDS PROCESSED" I $G(DIAR)=4 S ^DIAR(1.11,DIARC,"D",0)="^1.113^"_DILC_U_DILC Q S DIWL=1,DIWR=IOM-1,DIWF="NW" F D1=0:0 S D1=$O(^UTILITY("DIFG",$J,D1)) Q:D1'>0 S X=^(D1,0) D ^DIWP Q:'DN D:DN ^DIWW G Q WR F D1=0:0 S D1=$O(^DIAR(1.11,DIARC,"D",D1)) Q:D1'>0 S X=^(D1,0) W X G Q DIFGG DIFGG ;SFISC/XAK,EDE(OHPRD)-FILEGRAM GENERATOR ;7/25/92 2:15 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K DIFG S DIFG=DIC,DIC("A")="Select FILEGRAM TEMPLATE: " S DK=+Y,DIC="^DIPT(",DIC("S")="I $P(^(0),U,8)=1 S %=^(0) I $P(%,U,4)=DK!'$L($P(%,U,4))",DIC(0)="QEAIS",D="F"_+Y D IX^DIC K DIC,DY Q:Y<0 S (DIFG("TEMPLATE"),DIFGT)=+Y S DIC=DIFG,DIC(0)="QEAM" D ^DIC Q:Y<0 S DIFG("FE")=+Y,DIFG("FUNC")="L",DIFG("DUZ")=$S($D(^VA(200,DUZ,0)):$P(^(0),U),$D(^DIC(3,DUZ,0)):$P(^(0),U),1:DUZ) D START,SEND,LOG K DIFG,^UTILITY("DIFG",$J) Q ; EN ; EXTERNAL ENTRY POINT START ; D INIT I DIFG("QFLG") D EOJ Q D HDR,ENV,BODY,TLR,EOJ Q ; HDR ; FILEGRAM HEADER S V="$DAT"_U_DIFG(DILL,"FNAME")_U_DIFG(DILL,"FILE")_U_DIFG("PARM")_U D INCSET^DIFGGU K Y Q ; ENV ; ENVIRONMENTAL VARS I $D(DIFG("ENV")) E Q S DIFG("EV")="" F S DIFG("EV")=$O(DIFG("ENV",DIFG("EV"))) Q:DIFG("EV")="" S V="ENVIRONMENT:"_DIFG("EV")_"="""_DIFG("ENV",DIFG("EV"))_"""" D INCSET^DIFGGU ;ihs/ohprd/dg;patch 2;8-22-91 K DIFG("EV") Q ; BODY ; FILEGRAM BODY D BASE K DIFG("NOKEY") D NEXTLVL Q ; BASE ; BASEFILE ENTRY D LOOKUP^DIFGGU D FIELDS Q ; NEXTLVL ; DO NEXT LEVEL FILES/SUBFILES (CALLED RECURSIVELY) S DIFG(DILL,"DIFGI")=DIFGI S DILL=DILL+1 F DIFGI=DIFGI:0 S DIFGI=$O(^DIPT(DIFGT,1,DIFGI)) Q:DIFGI'=+DIFGI S X=^(DIFGI,0) D NEXTLVL2 Q:DIFGI="" S DILL=DILL-1 S DIFGI=DIFG(DILL,"DIFGI") Q ; NEXTLVL2 ; CHECK TEMPLATE ENTRY I $P(X,U,2)0 S %=$P(^(DIFG2,0),U,2) I $S('%:%'["C",1:$P(^DD(+%,.01,0),U,2)["W") S DR=DR_DIFG2_";" I $L(DR)>200 D DR S DR="" F DIFG2=0:0 S DIFG2=$O(^DIPT(DIFGT,1,DIFGI,"F",DIFG2)) Q:DIFG2'=+DIFG2 I $D(^(DIFG2,0)) S DR=DR_^(0)_";" I $L(DR)>200 D DR S DR="" D DR:DR]"" Q ; EN ; DR I '$D(DIFG(DILL,"MUL")) S DIC=DIFG(DILL,"FILE"),DA=DIFG(DILL,"FE") S DIQ(0)="N" D EN^DIQ1 K DIQ I $D(DIFGGF(DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) F DIFG2(DILL,"FLD")=0:0 S DIFG2(DILL,"FLD")=$O(DIFGGF(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))) Q:'DIFG2(DILL,"FLD") D . NEW VAL . S VAL=DIFGGF(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD")) . S ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))=$S(VAL]"":VAL,1:"^") . Q F DIFG2(DILL,"FLD")=0:0 D DR2 Q:DIFG2(DILL,"FLD")'=+DIFG2(DILL,"FLD") S V=^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD")) D FIELD I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE")),DIFGGF(DIFG(DILL,"FILE")) Q ; DR2 S DIFG2(DILL,"FLD")=$O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))) Q:DIFG2(DILL,"FLD")="" I $O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"),0)) S V("WP")=0,^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"))="wp" Q ; EN2 ; FIELD Q:V="" D SETXY K F,N,P,W S V=$P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,1)_U_$S(DIFG("PARM")["N":DIFG2(DILL,"FLD"),1:"")_"="_X D INCSET^DIFGGU D:Y'="" PTRCHK D:$D(V)>9 WP K X,Y,V Q ; WP NEW I S DITAB=DITAB+2 S DIFG("WP")="" F I=0:0 S I=$O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFG2(DILL,"FLD"),I)) Q:I="" S V=""""_^(I)_"""" D INCSET^DIFGGU S V="." D INCSET^DIFGGU K DIFG("WP") S DITAB=DITAB-2 Q ; SETXY S X=V S Y="" Q:$P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,2)'["P" S F=+$P($P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,2),"P",2),W=$P(^(0),U,4),N=$P(W,";",1),P=$P(W,";",2) S Y=$P(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",N)"),U,P) I $D(^UTILITY("DIFGLINK",$J,F,Y)) S X="@"_^UTILITY("DIFGLINK",$J,F,Y),Y="" Q S ^UTILITY("DIFGLINK",$J)=$S($D(^UTILITY("DIFGLINK",$J))#2:^UTILITY("DIFGLINK",$J)+1,1:1) S ^UTILITY("DIFGLINK",$J,F,Y)=^UTILITY("DIFGLINK",$J) S Y="@"_^UTILITY("DIFGLINK",$J) Q ; PTRCHK Q:$P(^DD(DIFG(DILL,"FILE"),DIFG2(DILL,"FLD"),0),U,2)'["P" S DITAB=DITAB+2 S DILL=DILL+1 D POINTER S DITAB=DITAB-2 K DIFG(DILL) S DILL=DILL-1 Q ; POINTER S DIFG(DILL,"FILE")=+$P($P(^DD(DIFG(DILL-1,"FILE"),DIFG2(DILL-1,"FLD"),0),U,2),"P",2),X=$P(^(0),U,4) S:$P(X,";")'=+X X=""""_$P(X,";")_""";"_$P(X,";",2) S DIFG(DILL,"FE")=$P(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_$P(X,";",1)_")"),U,$P(X,";",2)) I '$D(^DIC(DIFG(DILL,"FILE"),0)) D KILLLL^DIFGGU Q S DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL") I '$D(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",0)")) D KILLLL^DIFGGU Q S DIFG(DILL,"FNAME")=$P(^DIC(DIFG(DILL,"FILE"),0),U,1) I $D(Y),Y'="" S Z=Y,Y="" I $D(DIFGENV("LAYGO",DIFG(DILL-1,"FILE"),DIFG2(DILL-1,"FLD")))!($P(^DD(DIFG(DILL-1,"FILE"),DIFG2(DILL-1,"FLD"),0),U,2)'["'") S DIFG(DILL,"NOKEY")="" D ^DIFGGSB Q DIFGG4 DIFGG4 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SUBFILES ;6/10/93 1:41 PM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SUBFILE ; DO ONE SUBFILE F DIFG(DILL,"FE")=0:0 S DIFG(DILL,"FE")=$O(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_")")) Q:DIFG(DILL,"FE")'=+DIFG(DILL,"FE") D SUBENTRY Q ; SUBENTRY ; DO ONE SUBFILE ENTRY D DIS Q:'$T D DR S DR(DIFG(DILL,"FILE"))=.01 S DIFG(DILL,"MUL")=1 D LOOKUP^DIFGGU I $D(DIFGGUQ) K DIFGGUQ,DIFG(DILL,"MUL") Q D DR,DRS D RECURSEM S V="^" D INCSET^DIFGGU K DIFG(DILL,"MUL"),DA,DR Q ; DR ; CREATE DR-STRINGS K DR S I=0 F %=DIFG(DILL,"FILE"):0 Q:'$D(^DD(%,0,"UP")) S X=^("UP"),Y=$O(^DD(X,"SB",%,0)),DR(X)=Y,DA(%)=DIFG(DILL-I,"FE"),%=X,I=I+1 S DA=DIFG(DILL-I,"FE"),DIC=DIFG(DILL-I,"FILE"),DR=DR(%) K DR(%) Q ; DRS ; PROCESS ALL DR STRINGS FOR FILE S DR(DIFG(DILL,"FILE"))="",DITAB=DITAB+2 I $P(^DIPT(DIFGT,1,DIFGI,0),U,8) F DIFG2=.001:0 S %=DIFG(DILL,"FILE"),DIFG2=$O(^DD(%,DIFG2)) Q:DIFG2'>0 D DRA F DIFG2=0:0 S DIFG2=$O(^DIPT(DIFGT,1,DIFGI,"F",DIFG2)) Q:DIFG2'=+DIFG2 I $D(^(DIFG2,0)) S DR(DIFG(DILL,"FILE"))=DR(DIFG(DILL,"FILE"))_^(0)_";" I $L(DR(DIFG(DILL,"FILE")))>200 D EN^DIFGG2 S DR(DIFG(DILL,"FILE"))="" D EN^DIFGG2:DR(DIFG(DILL,"FILE"))]"" S DITAB=DITAB-2 Q ; DRA ;Process all subfields S %1=$P(^(0),U,0) I $S('%1:%1'["C",1:$P(^DD(+%1,.01,0),U,2)["W") S DR(%)=DR(%)_DIFG2_";" I $L(DR(%))>200 D EN^DIFGG2 S %=DIFG(DILL,"FILE"),DR(%)="" Q ; DIS ; SCREEN THIS ENTRY F %=1:1:DILL S @("D"_(%-1))=DIFG(%,"FE") I $D(DIFG(DIFG(DILL,"FILE"),"S"))#2 X DIFG(DIFG(DILL,"FILE"),"S") Q I 1 Q ; RECURSEM ; RECURSION FOR DEEPER SUBFILE SHIFTS S DITAB=DITAB+2 D NEXTLVL^DIFGG S DITAB=DITAB-2 Q ; ; DIFGG3 ; FILEGRAM NAVIGATION ; SEE DIFGG3^DIFGGDOC ; FILE ; PROCESS ONE FILE F DIFG(DILL,"FE")=0:0 D FILE2 Q:DIFG(DILL,"FE")="" D ENTRY K I,S,V,X Q ; FILE2 ; S X=$O(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),0)) Q:'X S Y=$O(^DD(DIFG(DILL,"FILE"),0,"IX",DIFG(DILL,"XREF"),X,0)) Q:'Y I $P(^DD(X,Y,0),U,2)["V" S DIFG(DILL,"FSV")=""""_DIFG(DILL-1,"FE")_";"_$P(^DIC(DIFG(DILL-1,"FILE"),0,"GL"),U,2)_"""" I 1 E S DIFG(DILL,"FSV")=DIFG(DILL-1,"FE") S DIFG(DILL,"FE")=$O(@(DIFG(DILL,"FGBL")_""""_DIFG(DILL,"XREF")_""","_DIFG(DILL,"FSV")_","_DIFG(DILL,"FE")_")")) Q ; ENTRY ; PROCESS ONE FILE ENTRY S DIFG(DILL,"NAV")=1 D LOOKUP^DIFGGU K DIFG(DILL,"NAV") I $D(DIFGGUQ) K DIFGGUQ Q S DITAB=DITAB+2 D ^DIFGG2 D RECURSEF S DITAB=2*(DILL-1) S V=":" D INCSET^DIFGGU Q ; RECURSEF ; RECURSION FOR DEEPER FILE SHIFTS D NEXTLVL^DIFGG Q DIFGGI DIFGGI ;SFISC/XAK,EDE(OHPRD)-FILEGRAM INITIALIZATION ;1/19/93 9:45 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; DIFGER values: 1 = required variable not passed ; 2 = variable form invalid ; 3 = variable content invalid ; INIT ; INITIALIZATION K ^UTILITY("DIFG",$J),^UTILITY("DIFGLINK",$J) D SET1,REQ Q:DIFG("QFLG") D OPT Q:DIFG("QFLG") D FIRST Q ; SET1 ; MISC SETS # 1 S DIFGI=0,DILL=1 K DIFGER S U="^",DIFG("QFLG")=0 Q ; REQ ; ; FE I '$D(DIFG("FE")) S DIFG("QFLG")=1 Q I DIFG("FE")'=+DIFG("FE") S DIFG("QFLG")=2 Q FUNC I '$D(DIFG("FUNC")) S DIFG("QFLG")="1" Q I DIFG("FUNC")="" S DIFG("QFLG")=2 Q I "AMLD"'[DIFG("FUNC") S DIFG("QFLG")=3 Q FGT I '$D(DIFGT) S DIFG("QFLG")=1 Q I DIFGT'=+DIFGT S DIFG("QFLG")=2 Q I '$D(^DIPT(DIFGT,0)) S DIFG("QFLG")=3 Q Q ; OPT ; ; FGR I '$D(DIFG("FGR")) S DIFG("FGR")="^UTILITY(""DIFG"",$J," S X=DIFG("FGR") I "(,"'[$E(X,$L(X)) S DIFG("QFLG")=2 Q I $P(X,"(")["DIFG" S DIFG("QFLG")=3 Q LC I $D(DILC),DILC'=+DILC S DIFG("QFLG")=2 Q S:'$D(DILC) DILC=0 PARM S:'$D(DIFG("PARM")) DIFG("PARM")="N" TAB I $D(DITAB),DITAB'=+DITAB S DIFG("QFLG")=2 Q S:'$D(DITAB) DITAB=0 FUNCSFT I $D(DIFG("FUNC SFT")) F X=0:0 S X=$O(DIFG("FUNC SFT",X)) Q:X'=+X D FUNCSFT2 Q:DIFG("QFLG") Q ; FUNCSFT2 S Y=DIFG("FUNC SFT",X) I Y="" S DIFG("QFLG")=2 Q I "AMLD"'[Y S DIFG("QFLG")=3 Q Q ; FIRST ; GET PRIMARY FILE VARIABLES S DIFGI=$O(^DIPT(DIFGT,1,DIFGI)) Q:DIFGI'=+DIFGI S X=^(DIFGI,0) D FVARS I '$D(@(DIFG(DILL,"FGBL")_DIFG("FE")_",0)")) S DIFG("QFLG")=3 Q Q ; FVARS ; SETUP FILE VARIABLES S DILL=$P(X,U,2),DITAB=2*(DILL-1),DIFG(DILL,"FILE")=+X S DIFG(DILL,"FNAME")=$O(^DD(DIFG(DILL,"FILE"),0,"NM",0)) I DILL=1 S DIFG(DILL,"FE")=DIFG("FE"),DIFG(DILL,"FUNC")=DIFG("FUNC") E S DIFG(DILL,"FUNC")=DIFG(DILL-1,"FUNC") I $D(DIFG("FUNC SFT",DIFG(DILL,"FILE"))) S DIFG(DILL,"FUNC")=DIFG("FUNC SFT",DIFG(DILL,"FILE")) I $P(X,U,4)=1 S DIFG(DILL,"FE")=DIFG(DILL-1,"FE") ; dinum back pointer S DIFG(DILL,"XREF")=$S($P(X,U,4)=4:$P(X,U,7),1:$P(X,U,4)),%=$P(X,U,5) ;Back pointer if $P=4 X-ref in $P7 I $E(%,$L(%))=":" S DIFG(DILL,"NAV")=1 I $P(X,U,4)=2 S DIFG(DILL,"NAV")=2 D DIRECT K %,Y I $P(X,U,4)=3 S %=$P(X,U,3),%=$O(^DD(%,"SB",+X,0)),%=^DD(+$P(X,U,3),%,0),%=$P($P(^(0),U,4),";") S:+%'=% %=""""_%_"""" S DIFG(DILL,"FGBL")=DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%_"," K DIFG(DILL,"NAV") Q ; multiple S DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL") D:$P(X,U,4)=5 LOOKUP Q ; DIRECT ;DIRECT POINTER S DIFG(DILL,"FE")=0,%=$P(%,":") S:'$D(^DD(DIFG(DILL-1,"FILE"),"B",%)) %=$O(^(%)) S %=$O(^DD(DIFG(DILL-1,"FILE"),"B",%,0)) Q:%'=+% S Y=$P(^DD(DIFG(DILL-1,"FILE"),%,0),U,4),%("N")=$P(Y,";"),%("P")=$P(Y,";",2) S:+%("N")'=%("N") %("N")=""""_%("N")_"""" I $D(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%("N")_")")) S Y=@("^("_%("N")_")"),DIFG(DILL,"FE")=$P(Y,U,%("P")) Q ; LOOKUP ;COMPUTED FIELD LOOKUP FOR FILE SHIFT S DIFG(DILL,"FE")="" S %=$O(^DD(DIFG(DILL,"FILE"),"B",$P($P(X,U,5),":"),0)) Q:'% X $P(^DD(DIFG(DILL,"FILE"),%,0),U,5,99) I $D(X) S DIFG(DILL,"FE")=$S(X?1"`"1N.N:$E(X,2,99),X?1N.N:X,1:"") Q DIFGGSB DIFGGSB ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SPECIAL BLOCK ; ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;EDE/OHPRD/IHS changed BEGEN/END line to match BNF ; START ; (CALLED RECURSIVELY) K DIFGSB(DILL) D BEGIN S DITAB=DITAB+2 D BODY^DIFGGSB1 S DITAB=DITAB-2 D END,EOJ Q ; BEGIN ; BEGIN LINE S V="BEGIN:"_DIFG(DILL,"FNAME")_"^"_$S(DIFG("PARM")["N":DIFG(DILL,"FILE"),1:"") I $D(Z),Z'="" S V=V_Z,Z="" D INCSET^DIFGGU Q ; ; END ; END LINE S V="END:"_DIFG(DILL,"FNAME")_"^"_$S(DIFG("PARM")["N":DIFG(DILL,"FILE"),1:"") D INCSET^DIFGGU Q ; EOJ ; K DIFGSB(DILL) K %,C,D0,J,S,V,X,Y,Z Q DIFGGSB1 DIFGGSB1 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SPECIAL BLOCK PART 2 ;8/12/98 13:16 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. BODY S DIFGSB(DILL,"SPSPEC")=0 I $D(DIFG(DILL,"FUNC")),"AL"[DIFG(DILL,"FUNC") I 1 E I $D(DIFG(DILL,"NOKEY")) E D SPSPEC^DIFGGSB2 Q:DIFGSB(DILL,"SPSPEC") D P01 D SPEC D IDENT Q ; P01 ; .01 FIELD WHEN IT IS A POINTER Q:$P(^DD(DIFG(DILL,"FILE"),.01,0),U,2)'["P" S DIFGSB(DILL,"FLD")=.01 D SETXY Q:Y="" D PTRCHK^DIFGGSB2 Q ; SPEC ; SPECIFIERS S DIFGSB(DILL,"SBT")="SPECIFIER:",%="" F DIFGSB(DILL,"FLD")=0:0 D SPEC2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD") S %=%_$S(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD")) I '$D(DIFG(DILL,"MUL")) S DR=% D:%'="" FIELDS I 1 E S DR(DIFG(DILL,"FILE"))=% D:%'="" FIELDS K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE")) I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR K % Q ; SPEC2 S DIFGSB(DILL,"FLD")=$O(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD"))) Q ; IDENT ; IDENTIFIERS S DIFGSB(DILL,"SBT")="IDENTIFIER:",%="" N DIXIEN,DIKEY S DIXIEN=0,DIKEY=";" I $G(DIAR)=4 S DIXIEN=$O(^DD("KEY","AP",DIFG(DILL,"FILE"),"P",0)) F DIFGSB(DILL,"FLD")=0:0 D IDENT2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD") D:'$D(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD"))) IDENT3 I '$D(DIFG(DILL,"MUL")) S DR=% D:%'="" FIELDS I 1 E S DR(DIFG(DILL,"FILE"))=% D:%'="" FIELDS K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE")) I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR K % Q ; IDENT2 N DIOUT S DIOUT=0 I DIXIEN F D Q:DIOUT!('DIFGSB(DILL,"FLD")) . S DIFGSB(DILL,"FLD")=$O(^DD("KEY",DIXIEN,2,"BB",DIFGSB(DILL,"FLD"))) . Q:'DIFGSB(DILL,"FLD")!(DIFGSB(DILL,"FLD")=.01) . Q:$O(^DD("KEY",DIXIEN,2,"BB",DIFGSB(DILL,"FLD"),0))'=DIFG(DILL,"FILE") . Q:'$D(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0)) . S DIOUT=1,DIKEY=DIKEY_DIFGSB(DILL,"FLD")_";" Q Q:DIOUT S DIXIEN=0 F S DIFGSB(DILL,"FLD")=$O(^DD(DIFG(DILL,"FILE"),0,"ID",DIFGSB(DILL,"FLD"))) Q:'DIFGSB(DILL,"FLD") Q:DIKEY'[(";"_DIFGSB(DILL,"FLD")) Q ; IDENT3 S %=%_$S(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD")) Q ; FIELDS I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) D DRFIX I '$D(DIFG(DILL,"MUL")) Q:DR="" E Q:DR(DIFG(DILL,"FILE"))="" K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE")) S:'$D(DIFG(DILL,"MUL")) DIC=DIFG(DILL,"FILE"),DA=DIFG(DILL,"FE") S DIQ(0)="N" D EN^DIQ1 K DIQ F DIFGSB(DILL,"FLD")=0:0 D FIELDS2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD") S X=^(DIFGSB(DILL,"FLD")) D FIELDS3 Q ; DRFIX ; ADJUST DR FOR MODIFIED/DELETED VALUES NEW T I '$D(DIFG(DILL,"MUL")) S T=DR E S T=DR(DIFG(DILL,"FILE")) F %=1:1 S X=$P(T,";",%) Q:X="" S %(X)="" I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X)) K %(X) S DIFGSB(DILL,"FLD")=X,X=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X) D DRFIX2 S (T,X)="" F %=0:0 S X=$O(%(X)) Q:X="" S T=T_$S(T="":"",1:";")_X I '$D(DIFG(DILL,"MUL")) S DR=T E S DR(DIFG(DILL,"FILE"))=T Q ; DRFIX2 NEW %,DR,T D FIELDS3 Q ; FIELDS2 S DIFGSB(DILL,"FLD")=$O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"))) Q ; FIELDS3 Q:X="" D SETXY K F,N,P,W S V=DIFGSB(DILL,"SBT")_$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,1)_U_$S(DIFG("PARM")["N":DIFGSB(DILL,"FLD"),1:"") S:DIFGSB(DILL,"SBT")["KEY" V=V_U_$P(DIFGSB(DILL,"SPSPEC"),U,2) S V=V_"="_X D INCSET^DIFGGU D:Y'="" PTRCHK^DIFGGSB2 K X,Y Q SETXY ; If previously looked up pointer set @LINK S Y="" Q:$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2)'["P" S F=+$P($P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2),"P",2),W=$P(^(0),U,4),N=$P(W,";",1),P=$P(W,";",2) I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P")) S Y=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P") I 1 E S Y=$P(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",N)"),U,P) I $D(^UTILITY("DIFGLINK",$J,F,Y)) S X="@"_^UTILITY("DIFGLINK",$J,F,Y),Y="" Q S ^UTILITY("DIFGLINK",$J)=$S($D(^UTILITY("DIFGLINK",$J))#2:^UTILITY("DIFGLINK",$J)+1,1:1) S ^UTILITY("DIFGLINK",$J,F,Y)=^UTILITY("DIFGLINK",$J) S Y="@"_^UTILITY("DIFGLINK",$J) Q DIFGGSB2 DIFGGSB2 ;SFISC/DG,EDE(OHPRD)- ;6/19/92 9:28 AM ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SPSPEC ; UNIQUE SPECIFIER F DIFGSB(DILL,"SPSPEC")=0:0 S DIFGSB(DILL,"SPSPEC")=$O(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"SPSPEC"))) Q:'DIFGSB(DILL,"SPSPEC") I +^(DIFGSB(DILL,"SPSPEC")) Q:$P(^(DIFGSB(DILL,"SPSPEC")),U,2)'="" Q:'DIFGSB(DILL,"SPSPEC") I $P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"SPSPEC"),0),U,2)["P" S DIFGSB(DILL,"SPSPEC")=0 Q S $P(DIFGSB(DILL,"SPSPEC"),U,2)=$P(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"SPSPEC")),U,2) S DIFGSB(DILL,"FLD")=+DIFGSB(DILL,"SPSPEC") I '$D(DIFG(DILL,"MUL")) S DR=+DIFGSB(DILL,"SPSPEC") E S DR(DIFG(DILL,"FILE"))=+DIFGSB(DILL,"SPSPEC") S DIFGSB(DILL,"SBT")="KEY:" D FIELDS^DIFGGSB1 Q ; PTRCHK ; CHECK FOR POINTER FIELD Q:$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2)'["P" S DITAB=DITAB+2 S DILL=DILL+1 D POINTER S DITAB=DITAB-2 K DIFG(DILL) S DILL=DILL-1 Q ; POINTER ; POINTER FIELDS S DIFG(DILL,"FILE")=+$P($P(^DD(DIFG(DILL-1,"FILE"),DIFGSB(DILL-1,"FLD"),0),U,2),"P",2),X=$P(^(0),U,4) S:$P(X,";")'=+X X=""""_$P(X,";")_""";"_$P(X,";",2) I $D(DIFGGU(DIFG(DILL-1,"FILE"),DIFG(DILL-1,"FE"),DIFGSB(DILL-1,"FLD"),"P")) S DIFG(DILL,"FE")=DIFGGU(DIFG(DILL-1,"FILE"),DIFG(DILL-1,"FE"),DIFGSB(DILL-1,"FLD"),"P") E S DIFG(DILL,"FE")=$P(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_$P(X,";",1)_")"),U,$P(X,";",2)) I '$D(^DIC(DIFG(DILL,"FILE"),0)) D KILLLL^DIFGGU Q S DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL"),DIFG(DILL,"FNAME")=$P(^DIC(DIFG(DILL,"FILE"),0),U,1) I '$D(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",0)")) D KILLLL^DIFGGU Q I $D(Y),Y'="" S Z=Y,Y="" I $D(DIFGENV("LAYGO",DIFG(DILL-1,"FILE"),DIFGSB(DILL-1,"FLD")))!($P(^DD(DIFG(DILL-1,"FILE"),DIFGSB(DILL-1,"FLD"),0),U,2)'["'") S DIFG(DILL,"NOKEY")="" D START^DIFGGSB ; RECURSE Q DIFGGU DIFGGU ;SFISC/XAK,EDE(OHPRD)-FILEGRAM FUNCTIONS ; [ 11/10/92 10:38 AM ] ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Required variables: ; ; DILC ; DITAB ; DIFG("PARM") ; DIFG("FGR") ; DILL ; DIFG(DILL,"FILE") ; DIFG(DILL,"FNAME") ; DIFG(DILL,"FE") ; DIFG(DILL,"FGBL") ; DIFG(DILL,"FUNC") ; Q ; INVALID ENTRY POINT ; LOOKUP ; EXTERNAL ENTRY POINT ; LOOKUP ENTRY IN FILE/SUBFILE D SETX Q:$D(DIFGGUQ) S Z="" I '$D(^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) D SETLINK I $D(^DD(DIFG(DILL,"FILE"),0,"UP")) S A=^("UP"),B=$O(^DD(A,"SB",DIFG(DILL,"FILE"),0)),C=$P(^DD(A,B,0),U,1),V=C_U_$S(DIFG("PARM")["N":B,1:"") K A,B,C E S V=DIFG(DILL,"FNAME")_U_$S(DIFG("PARM")["N":DIFG(DILL,"FILE"),1:"") S V=V_$S($D(DIFG(DILL,"NAV")):":",1:"")_U_DIFG(DILL,"FUNC")_"="_X I $D(DIFG(DILL,"NAV")),DIFG(DILL,"NAV")=1,$G(DIFG(DILL,"XREF"))?1A.E S V=V_U_DIFG(DILL,"XREF")_"=@"_^UTILITY("DIFGLINK",$J,DIFG(DILL-1,"FILE"),DIFG(DILL-1,"FE")) D INCSET D:Z'="" SPBLK K S,V,X,Z Q ; SETLINK ; S ^UTILITY("DIFGLINK",$J)=$S($D(^UTILITY("DIFGLINK",$J))#2:^UTILITY("DIFGLINK",$J)+1,1:1),^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))=^UTILITY("DIFGLINK",$J) S Z="@"_^UTILITY("DIFGLINK",$J) Q ; SETX ; SET X TO @LINK OR LOOKUP VALUE S X="" D SETX2 Q:$D(DIFGGUQ) Q:X'="" I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01)) S X=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01) Q K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE")) I '$D(DIFG(DILL,"MUL")) S DIC=DIFG(DILL,"FILE"),DA=DIFG(DILL,"FE"),DR=".01" S DIQ(0)="N" D EN^DIQ1 K DIQ S X=^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01) K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE")) I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR Q ; SETX2 ; IF POINTER AND ALREADY LOOKED UP SET @LINK K DIFGGUQ I $D(^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) S X="@"_^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"))_"E" Q:$P(^DD(DIFG(DILL,"FILE"),.01,0),U,2)'["P" S X=+$P($P(^DD(DIFG(DILL,"FILE"),.01,0),U,2),"P",2) I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01,"P")) S Y=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),.01,"P") I 1 E S Y=$P(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",0)"),U,1) NEW G S G="^"_$P(^DD(DIFG(DILL,"FILE"),.01,0),U,3) I '$D(@(G_Y_",0)")) S DIFGGUQ=1 Q S X=$S($D(^UTILITY("DIFGLINK",$J,X,Y)):"@"_^UTILITY("DIFGLINK",$J,X,Y),1:"") K Y Q ; SPBLK ; SPECIAL BLOCK S DITAB=DITAB+2 D ^DIFGGSB S DITAB=DITAB-2 Q ; INCSET ; EXTERNAL ENTRY POINT ; INCREMENT LINE COUNT AND SET LINE S DILC=DILC+1 S S="" I '$D(DIFG("WP")) S:DITAB $P(S," ",DITAB)=" " S @(DIFG("FGR")_DILC_",0)")=S_V Q ; KILLLL ; EXTERNAL ENTRY POINT ; KILL LAST LINE, DECREMENT LINE COUNT, KILL LAST LINK, DECREMENT LINK COUNT D KILLDEC,DELLINK Q ; KILLDEC ; EXTERNAL ENTRY POINT ; KILL LAST LINE AND DECREMENT LINE COUNT K @(DIFG("FGR")_DILC_",0)") S DILC=DILC-1 Q ; DELLINK ; EXTERNAL ENTRY POINT ; DELETE LAST @LINK AND DECREMENT LINK COUNTER K ^UTILITY("DIFGLINK",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE")) S ^UTILITY("DIFGLINK",$J)=^UTILITY("DIFGLINK",$J)-1 Q DIFGO DIFGO ;SFISC/XAK-FILEGRAM OPTIONS ;10:15 AM 7 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013; ;Per VHA Directive 2004-038, this routine should not be modified. 0 S DIC="^DOPT(""DIFG""," G OPT:$D(^DOPT("DIFG",6)) S ^(0)="FILEGRAM OPTION^1.01" K ^("B") F X=1:1:6 S ^DOPT("DIFG",X,0)=$P($T(@X),";;",2) S DIK=DIC D IXALL^DIK OPT ; S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0 ; EN ;Entry point for all filegram options S:'$D(Y) Y=0 S DIC("S")="I Y>1.99" D:DI#2 ^DICRW G:Y<0 Q K DIC("S") ;ihs/ohprd/dg 8-21-91 D @DI W !! Q K %,DIC,DIK,DI,DA,I,J,X,Y Q ; 1 ;;CREATE/EDIT FILEGRAM TEMPLATE G EN^DIFGA ; 2 ;;DISPLAY FILEGRAM TEMPLATE S DIC("A")="Select FILEGRAM TEMPLATE: " S DIC="^DIPT(",DIC(0)="QEAM",DIC("S")="I $P(^(0),U,8)=1" D ^DIC I Y<0 K DIC Q W !! S DA=+Y,DIQ(0)="C" D EN^DIQ K DIC,DIQ G 2 Q ; 3 ;;GENERATE FILEGRAM I '($D(IO)#2) D HOME^%ZIS I DUZ'>0 W $C(7),!!,"INVALID USER. YOU CAN'T USE THIS OPTION." Q S DIC=+Y G ^DIFGG ; ; 4 ;;VIEW FILEGRAM W !! S DIC(0)="ZQEAMIN",DIC=1.12 D ^DIC Q:Y<0 S IOP="HOME" D ^%ZIS Q:POP S D0=+Y D EN1 G 4 EN1 S X=Y(0),Y=$P(X,U,6),Y=$S($D(^XMB(3.9,+Y,0))#2:$P(^(0),U),1:Y) W !!,Y S Y=$P(X,U,2) W !,$S(Y="s":"Sent",Y="i":"Installed",1:Y) W " on " S Y=$P(X,U) D DT W " by ",$P(X,U,3) S DIWL=1,DIWR=78,DIWF="WN" S D0=$P(X,U,6) S:'$D(^XMB(3.9,+D0,0)) D0=-1 W !! S S=5,D=0 F S (D,D1)=$O(^XMB(3.9,D0,2,D)) Q:D'>0 I $D(^(D,0))#2 S X=^(0) D ^DIWP Q:'$D(D) S D=D1,S=S+1 I $E(IOST)="C",S+4>IOSL S DIR(0)="E" D ^DIR Q:'Y S S=0 S:D="" (D,D1)=-1 D 0^DIWW K DIP,Y,DIWF Q DT X ^DD("DD") W Y Q ; 5 ;;SPECIFIERS S DI=+Y G 99^DIU ; 6 ;;INSTALL/VERIFY FILEGRAM S DIC(0)="QEAMNIZ",DIC=1.12 D ^DIC K DIC Q:Y<0 Q:'$P(Y(0),U,6) S DIFGLO="^XMB(3.9,"_$P(Y(0),U,6)_",2,",DIFGG=+Y D ^DIFG W !,$S($D(DIFGER):"UNSUCCESSFUL INSTALLATION: "_DIFGER,1:"DONE") S $P(^DIAR(1.12,DIFGG,0),U,2)=$S($D(DIFGER):"u",1:"i") K DIFGER,DIFGG Q DIFGSRV DIFGSRV ;SFISC/RWF-SERVER INTERFACE TO FILEGRAMS ; ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q HIST ;Add a message to the FileGram History file so it can be processed. S DIXM=0,U="^" X XMREC ;get first line I $P(XMRG,U)'="$DAT" S DIXM=DIXM+1,XQSTXT(DIXM)="First line of message doesn't start with '$DAT'" S DIFG=$P(XMRG,U,3) I DIFG<2 S DIXM=DIXM+1,XQSTXT(DIXM)="Can't update a VA FileMan file." I "^2^3^19^"[(U_DIFG_U) S DIXM=DIXM+1,XQSTXT(DIXM)="Update to a protected file (#"_DIFG_")." Q:DIXM S DIFG("FE")=+$P(XQSUB,"#",2),DIFG("TEMPLATE")="",DIFG("DUZ")=XMFROM D LOG^DIFGG Q DIFROM DIFROM ;SFISC/XAK-GENERATE INITS ; 03DEC2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D Q S X=$S('$D(^DD("VERSION"))#2:0,1:^("VERSION")),Y=$P($T(DIFROM+1),";",3) G:X'=Y ERV K X,Y I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q D WARN S DIR("A")="Enter the Name of the Package (2-4 characters)" S DIR(0)="FO^2:4:0^I X'?1U1.NU K X" S DIR("?")="^D R^DIFROMH",DIR("??")=DIR("?") D ^DIR G Q:$D(DIRUT) K DIR S DIC="^DIC(9.4,",DIC(0)="EZ",D="C" D IX^DIC K D,DIC S DPK=+Y,DPK(0)=$S($D(Y(0)):Y(0),1:"") R W !!,"I am going to create a routine called '",X,"INIT'." S DTL=X,X=X_"INIT" D OS^DII I $D(^DD("OS",DISYS,18)) X ^(18) I W $C(7),!,"but '"_X_"' is ALREADY ON FILE!" S Q=1 K DIR S DIR("A")="Is that OK",DIR(0)="Y",DIR("??")="^D R1^DIFROMH" D ^DIR G Q:$D(DIRUT)!'Y S DIR("A")="Would you like to include Data Dictionaries",DIR("B")="YES" S DIR("??")="^D R3^DIFROMH" D ^DIR G Q:$D(DIRUT) I 'Y S F(-1)=0 G DD G L:DPK<0 S DIR("A")="Would you like to see the package definition" S DIR("??")="^D CUR^DIFROMH1",DIR("B")="NO" D ^DIR G Q:$D(DIRUT) I Y D L^DIFROMH1 S DIR("A")="Do you want to accept the current definition" S DIR(0)="Y",DIR("??")="^D PKG^DIFROMH1" D ^DIR G Q:$D(DIRUT) S DIH=Y F DA=0:0 S DA=$O(^DIC(9.4,DPK,4,DA)) G:'$D(^(+DA,0)) DD:$D(F),L S Y=+^(0) I $D(^DIC(Y,0))#2 S F(Y)=$P(^(0),U) W !!,F(Y) D SF G Q:%<0 L W !!,"THEN PLEASE LIST THE FILES THAT YOU WISH TO TRANSPORT:" S DIH=0,DPK=-1 F F=1:1 G Q:$D(DTOUT) K DIC S DIC("S")="I Y>1.9999&'$D(F(+Y))",DIC(0)="AIQEZ",DIC="^DIC(" D ^DIC G:Y<0 Q:X[U,DD S F(+Y)=$P(Y,U,2) D F DD W ! F Y=1,2,3,4 S D=$P("DIE^DIPT^DIBT^DIST",U,Y),DIC=$P("INPUT^PRINT^SORT^FORM(S):",U,Y)_$S(Y<4:" TEMPLATE(S):",1:"") F %=0:0 S %=$O(^DIC(9.4,DPK,D,%)) Q:'$D(^(+%,0)) S DH=$P(^(0),U),X=$P(^(0),U,2) D T S DN=DTL_$E("INI",1,5-$L(DTL)) K ^UTILITY(U,$J),DR S DRN=0,F=0,Q=DPK G Q:$D(F)+$D(Q)=2 D VER^DIFROM12 G Q:$D(DIRUT) S G ^DIFROM0 ; T W !,DIC,?24,DH I Y'=4 F F=0:0 S @("F=$O(^"_D_"(""B"",DH,F))"),DIC="" Q:'F I @("$D(^"_D_"(F,0))"),$P(^(0),U,4)=X!'X S Q(D,F)="",DIFC=1 G TQ I Y=4 F F=0:0 S F=$O(^DIST(.403,"B",DH,F)),DIC="" Q:'F I $D(^DIST(.403,F,0)),$P(^(0),U,8)=X S Q(D,F)="",DIFC=1 G TQ W $C(7)," **NOT FOUND** " TQ Q ; SF G F:$O(^DIC(9.4,DPK,4,DA,1,0))'>0 F %=0:0 S %=$O(^DIC(9.4,DPK,4,DA,1,%)) Q:%'>0 I $D(^(%,0)) S E=$P(^(0),U),D=$O(^DD(+Y,"B",E,0)) D:D="" ERF I $D(^DD(+Y,D,0)) S F(+Y,+Y,D)="",%C=+$P(^(0),U,2) I %C W " (",E,")" S F(+Y,%C)=0 S F(+Y,+Y)=1,E=+Y S:(+Y'=200)!(DTL="XU") F(+Y,+Y,.01)=0 G E F S F(+Y,+Y)=0,%=1,E=0 K %A ; VEN/SMH 3121029 - Change below to that S F(+Y,D)=0 not "", to conform with KIDS FIA format. ; IX & KEYS on subfiles don't get exported with KIDS otherwise. For V22.2. E F E=E:0 S E=$O(F(+Y,E)) Q:E'>0 F D=0:0 S D=$O(^DD(E,"SB",D)) Q:D'>0 I Y-E!'$D(%A)!$D(%A(D)) S F(+Y,D)=0 S:$D(%A) %A(D)=0 S F(+Y,0)=^DIC(+Y,0,"GL"),D=$P(@(F(+Y,0)_"0)"),U,4),DPK(1)=+Y S:D<2 D="" S DA(1)=DPK,DR="222.1;222.2;223;222.4;222.7;S:""n""[X Y=0;222.8;222.9;" S DIE=$S(DPK>0:"^DIC(9.4,",1:"^UTILITY($J,")_DA(1)_",4," I DPK<0 S ^UTILITY($J,-1,4,0)="^9.44",^(+Y,0)=+Y,DA=+Y I 'DIH W ! S DIE("W")="W !?2,$P(DQ(DQ),U),?32,"": """ D ^DIE I $D(Y) S %=-1 S F(DPK(1),-222)=$S($D(@(DIE_"DA,222)")):^(222),1:"y"),F(DPK(1),-223)=$S($D(^(223)):^(223),1:"") K DIE,DR Q ; ERF S D=-1 W $C(7),!," INVALID FIELD LABEL: "_E,! Q ERV W $C(7),!!,"Your FileMan Version number: "_X_" does not match the version number",!,"on the DIFROM routine: "_Y_" !!",!!,"You must run ^DINIT before you can build an INIT!!",! K X,Y Q Q G Q^DIFROM11 WARN N I F I=1:1 Q:$T(WARN+I)="" W !,$P($T(WARN+I),";;",2) ;; * * Please Note * * ;; ;; DIFROM generates routines in the following format: ;; ;; nmspInxx ;; ^^^^^^^^ ;; |||||||| ;; |||||| \\- xx is any combination of numbers and ;; |||||| uppercase alpha characters. ;; |||||| ;; ||||| \--- n is a number 0 - 9 and uppercase letter N. ;; ||||| ;; |||| \---- I is always uppercase letter I. ;; |||| ;; \\\\----- 2 to 4 characters of package namespace. ;; ;; Any routines that support the init process should not ;; be in this format. ;; DIFROM0 DIFROM0 ;SFISC/XAK-GATHER PCS TO SEND ; 31OCT2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S %=2,DIT=0,DIH="" I DPK<0,$O(F(0))>0 K DIR S DIR(0)="Y",DIR("A")="Do you want to include all the templates and forms",DIR("B")="NO",DIR("??")="^D NOPKG^DIFROMH" D ^DIR G Q:$D(DIRUT) S DIT=Y=1 W ! S DIR(0)="YA",DIR("??")="^D ^DIFROMH",DIR("B")="YES" ;NOTE: I removed 9.8 (ROUTINE FILE) from this list for V19 but none of the supporting code. (tkw) F DL=19,3.6,19.1,.5,9.2,8994 I $D(^DIC(DL,0)) S X=$P(^(0),U),DIR("A")="Would you like to include "_X_"S?"_$J("",17-$L(X)) D ^DIR G Q:$D(DIRUT) I Y=1 S DL(DL)=DL,DIFC=1 G:$D(F(-1))&('$D(DIFC)) Q S W ! S DIR("A")="Would you like security codes sent along: ",DIR("B")="NO" S DIR("??")="^D S^DIFROMH" D ^DIR G Q:$D(DIRUT) S DSEC=Y=1 K ^UTILITY("DI",$J) M ; S DIR("A")="Maximum Routine Size (2000 - "_^DD("ROU")_") : ",DIR("B")=^DD("ROU"),DIR(0)="NA^2000:"_^DD("ROU") ; VEN/SMH V22.2 S DIR("??")="^D M^DIFROMH" D ^DIR G Q:$D(DIRUT) S DIFRM=Y GO W ! D WAIT^DICD D:DPK>0 PKG^DIFROM12 D I DTL="DI" S DTL="DD" D S DTL="DM" D S DTL="DI" .F Y=19,3.6,19.1,.5,9.8,9.2,8994 I $D(DL(Y)) S X=$S(Y=19:"OPT",Y=3.6:"BUL",Y=19.1:"SE",Y=.5:"FUN",Y=9.8:"ROU",Y=9.2:"HEL",Y=8994:"REM") D ADD,A:'Y D SBF K DL,DIR S DL=DRN,DRN=1 G ^DIFROM1 ADD ; S DH=$S(DTL="XU":"DD",1:DTL) Q:$D(^DIC(Y,0))[0!$D(DTL(Y)) Q:$P(^(0),X,1)]""!'$D(^(0,"GL")) S Y=^("GL"),X=$S(X="ROU":"RTN",X="SE":"KEY",1:X) Q A F D=0:0 S D=$O(^DIC(9.4,DPK,"EX",D)) Q:D'>0 I $P(DH,$P(^(D,0),U))="" G DH S D=$O(@(Y_"""B"",DH,0)")),%X=Y_"D,",%Y="^UTILITY(U,$J,X,D," G DH:D'>0,DH:D<100&(X="FUN") S Q(X)=0 D %XY^%RCR G H:X'="OPT" S %=^UTILITY(U,$J,X,D,0),%1=+$P(%,U,12),%1=$S($D(^DIC(9.4,%1,0)):$P(^(0),U),1:""),$P(%,U,12)=%1,$P(%,U,5)="" S %1=+$P(%,U,7),%1=$S($D(^DIC(9.2,%1,0)):$P(^(0),U),1:""),$P(%,U,7)=%1,^UTILITY(U,$J,X,D,0)=% K ^(3.96),^(10,"B"),^("C") I $D(^UTILITY(U,$J,X,D,220)) S %=^(220),%1=$S($D(^XMB(3.6,+%,0)):$P(^(0),U),1:""),$P(%,U)=%1,%1=$S($D(^XMB(3.8,+$P(%,U,3),0)):$P(^(0),U),1:""),$P(%,U,3)=%1,^UTILITY(U,$J,X,D,220)=% F %=0:0 S %=$O(^DIC(19,D,10,%)) Q:%'>0 I $D(^(%,0)),$D(^DIC(19,+^(0),0)) S ^UTILITY(U,$J,X,D,10,%,U)=$P(^(0),U) H K:"BULKEY"[X ^UTILITY(U,$J,X,D,2) G:X'="HEL" DH K ^UTILITY(U,$J,X,D,4) S $P(^(0),U,4)="" K ^(2,"B"),^UTILITY(U,$J,X,D,10,"B") F %2=0:0 S %2=$O(^UTILITY(U,$J,X,D,10,%2)) Q:'%2 I $D(^(%2,0))#2 S %1=+^(0),%1=$S($D(^MAG(%1,0)):$P(^(0),U,1),1:"") K:%1="" ^UTILITY(U,$J,X,D,10,%2) I %1]"" S $P(^UTILITY(U,$J,X,D,10,%2,0),U,1)=%1 F %2=0:0 S %2=$O(^UTILITY(U,$J,X,D,2,%2)) G DH:%2'>0 I $D(^(%2,0))#2,$P(^(0),U,2) S %1=^(0),%=1 D HP1 Q:%<0 K %1,%2 Q HP1 I $D(^DIC(9.2,+$P(%1,U,2),0)) S ^UTILITY(U,$J,X,D,2,%2,0)=$P(%1,U)_U_$P(^(0),U) Q W !,$C(7),"The Help Frame, "_$P(^DIC(9.2,D,0),U)_" has the keyword "_$P(%1,U) W !,"whose Related Frame does not exist. Shall I exclude it" D YN^DICN K:%=1 ^UTILITY(U,$J,X,D,2,%2) Q ; DH S DH=$O(@(Y_"""B"",DH)")) G A:DH]""&(DTL="XU"!($P(DH,DTL,1)="")) Q ; ERM W $C(7),!!?5,"Was not able to get a message number for the network INIT",!?10,"DIFROM ABORTED!!",! Q ; Q G Q^DIFROM11 SBF N I,II S I=0 F S I=$O(F(I)) Q:I'>0 S II=0 F S II=$O(F(I,II)) Q:II'>0 S ^UTILITY("^",$J,"SBF",I,II)="" Q DIFROM1 DIFROM1 ;SFISC/XAK-CREATES RTNS WITH DD'S ; 29OCT2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. L S DH=" F I=1:2 S X=$T(Q+I) Q:X="""" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y",F=$O(F(F)) I F'>0 D:DSEC SEC K ^UTILITY("DI",$J) G ^DIFROM11 S ^UTILITY($J,DL+1,0)="^DIC("_F_",0,""GL"")",^UTILITY($J,DL+2,0)="="_F(F,0),^UTILITY($J,DL+3,0)="^DIC(""B"","""_F(F)_""","_F_")",^UTILITY($J,DL+4,0)="=",DL=DL+4 S DH=" Q:'DIFQ("_F_") "_DH EGP F E="ALANG","%","%D" S %X="^DIC("_F_","""_E_""",",E=0 D %XY ;**CCO/NI TO TRANSPORT FOREIGN-LANGUAGE FILE NAMES I DSEC S E="" F DSEC=DSEC:1 S E=$O(^DIC(F,0,E)) Q:E="" I E'="GL" S ^UTILITY("DI",$J,DSEC,0)="^DIC("_F_",0,"""_E_""")" S DSEC=DSEC+1 S ^UTILITY("DI",$J,DSEC,0)="="_^DIC(F,0,E) F D=0:0 S D=$O(F(F,D)),E=0,%X="^DD("_D_",0" Q:D'>0 S ^UTILITY($J,DL+1,0)=%X_")",DL=DL+2,^UTILITY($J,DL,0)="="_^DD(D,0),%X=%X_"," D V F X=0:0 S X=$O(^DD(D,X)) Q:X'>0 S %X="^DD("_D_","_X_",",E="%Z#2" D SAVE:$D(F(F,D))<9!$D(F(F,D,X)) ; KEYSNIX ; TRANSPORT INDEXES AND KEYS; VEN/SMH for FM V22.2 (fallthrough) ; FIA array has same format as F currently has. We will just reuse F. ; But we need to store it in a global as DIFROMS* uses naked refs. K ^UTILITY("FIA",$J),^UTILITY("KX",$J) ; FIA, Keys and Index output. M ^UTILITY("FIA",$J)=F ; Load FIA. ; ; Export DD from KIDS. Includes ^DD and ^DIC. ; New Style Indexes and Keys get exported too. ; Unfortunately, Indexes and Keys code expects DIFROM Server Style ^DD array. ; So this is the easiest way to get them out from the Server. D DDOUT^DIFROMS(F,"",$NA(^UTILITY("FIA",$J)),$NA(^UTILITY("KX",$J))) ; ; We don't need this any more. K ^UTILITY("FIA",$J) ; ; Remove ^DD and ^DIC from the output array. K ^UTILITY("KX",$J,"^DD") K ^UTILITY("KX",$J,"^DIC") ; ; Now we loop through output global and store in ^UTILITY($J) so that DIFROM ; will store the global in the outputted routines N GREF S GREF=$NA(^UTILITY("KX",$J)) ; Global reference for $Q N LREF S LREF=$E(GREF,1,$L(GREF)-1) ; Last reference -- w/o the comma. F S GREF=$Q(@GREF) Q:GREF'[LREF D ; Loop until the Global doesn't match itself. . S DL=DL+1 ; next line . N REF2STORE S REF2STORE=GREF ; We need to change the stored reference for the destination system. . S $P(REF2STORE,",",2)="$J" ; Remove our job number, and just put $J. Destination system will resolve it. . S ^UTILITY($J,DL,0)=REF2STORE ; Store ref . S DL=DL+1 ; next line . S ^UTILITY($J,DL,0)="="_@GREF ; store the value. ; ; We don't need this anymore. K ^UTILITY("KX",$J) ; ; This dumps the routines out for all of the above (^DD, ^DIC, and ^UTILITY("KX") ; Last part (IFff) says if data doesn't come with file do the next file. D FILE^DIFROM3 G:'$D(DRN) EQ^DIFROM11 I $P(F(F,-222),U,7)'="y" G L ; S DL=DL+1,E="%Z#2=0",%X=F(F,0),@("D="_%X_"0)") S ^UTILITY($J,DL+1,0)="^UTILITY(U,$J,"_F_")",^UTILITY($J,DL+2,0)="="_%X,^UTILITY($J,DL+3,0)="^UTILITY(U,$J,"_F_",0)",^UTILITY($J,DL+4,0)="="_D,%Y="^UTILITY(U,$J,"_F_",",%Z=0,%C(-1)=0,%B=0,%A="",DL=DL+5 D N S DH=$P(DH,"DIFQ")_"DIFQR"_$P(DH,"DIFQ",2,99) D FILE^DIFROM3 G:'$D(DRN) EQ^DIFROM11 G L SAVE K DSV I $D(^(X,8)) S DSV(8)=^(8) K ^(8) F %Z=8.5,9 I $D(^(%Z)),^(%Z)'=U,'($P(^(0),U,2)["K"&(^(%Z)="@")) S DSV(%Z)=^(%Z) K ^(%Z) D %XY F %Z=8,8.5,9 I $D(DSV(%Z)),DSV(%Z)]"" S ^DD(D,X,%Z)=DSV(%Z) I DSEC S ^UTILITY("DI",$J,DSEC,0)="^DD("_D_","_X_","_%Z_")",DSEC=DSEC+1,^UTILITY("DI",$J,DSEC,0)="="_DSV(%Z),DSEC=DSEC+1 Q ; SEC S DH=" I DSEC"_DH,%X="^UTILITY(""DI"",$J,",%Y="^UTILITY($J," D %XY^%RCR D FILE^DIFROM3:$O(^UTILITY($J,0))>0 G:'$D(DRN) EQ^DIFROM11 S DH=$E(DH,8,999) Q ; %XY ; W "." S %Z=0,%A="",%C(-1)=0,%Y=%X S S %B="" N S @("%B=$O("_%X_%A_"%B))"),%C(%Z)=%C(%Z-1) I '%B,%B'?1"0".E,@E S %B="" I %B["," F %C=0:0 S %C=$F(%B,",",%C) Q:'%C S %C(%Z)=%C(%Z)+1 I %B="" G Q:'%Z S @("%B="_$P(%A,",",%Z+%C(%Z-2),%Z+%C(%Z-1))),%Z=%Z-1,%A=$P(%A,",",1,%Z+%C(%Z-1))_$E(",",%Z>0) G N I @("$D("_%X_%A_"%B))#2=1") S %V=^(%B) D W:%V'?.ANP S %=$P("""",U,+%B'=%B),%=%Y_%A_%_%B_%_")" D B:$L(%V)>240 S DL=DL+1,^UTILITY($J,DL,0)=%,DL=DL+1,^UTILITY($J,DL,0)="="_%V I @("$D("_%X_%A_"%B))<9") G N G D:+%B=%B F %C=0:0 S %C=$F(%B,"""",%C) Q:'%C S %B=$E(%B,1,%C-1)_""""_$E(%B,%C,999),%C=%C+1 S %B=""""_%B_"""" D S %A=%A_%B_",",%Z=%Z+1 G S ; B I $L(%V)>255 W !,"WARNING--DATA TOO LONG: " D X S DL=DL+1,^UTILITY($J,DL,0)=%,%=$C(126)_$E(%V,1,160),%V=$E(%V,161,999) Q ; W W !,"WARNING--CONTROL CHARACTER IN DATA: " X W $C(7),%X,%A,%B,")--",!?3,%V Q Q V K DSV I $D(^DD(D,0,"VR"))#2 S DSV=^("VR") K ^("VR") D %XY I $D(DSV)#2 S ^DD(D,0,"VR")=DSV K DSV Q DIFROM11 DIFROM11 ;SFISC/XAK-CREATES RTN ENDING IN INIT1 ;APR 13, 1995@14:31;11/24/92 10:31 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S %Y="^UTILITY(U,$J,D,Y,",E=0 F D="DIE","DIPT","DIBT" S %X=U_D_"(Y,",Y=0 F S @("Y=$O(^"_D_"(Y))") Q:'Y I $D(^(Y,0))#2 S DSV=^(0),F=$P(DSV,U,4) I F,$P(DSV,U,8)<3,$D(F(F))!$D(Q(D,Y)) D 1 S D="DIST(.403,",%X=U_D_"Y,",Y=0 F S Y=$O(^DIST(.403,Y)) Q:'Y I $D(^(Y,0))#2 S DSV=^(0),F=$P(DSV,U,8) I F,$D(F(F))!$D(Q("DIST",Y)) D 1 S X="" F D=0:0 S X=$O(^UTILITY(U,$J,X)) Q:X="" S %X="^UTILITY(U,$J,"_""""_X_"""," D %XY^DIFROM1 K ^UTILITY(U,$J) D FILE^DIFROM3:DL K ^UTILITY($J) G:'$D(DRN) EQ D DIFROM2 G Q 1 ; I 'DIT F %=0:0 S %=$O(^DIC(9.4,DPK,"EX",%)) Q:%'>0 I $P($P(DSV,U),$P(^(%,0),U))="" G QQ I D["DIST" I DIT!($P($P(DSV,U),DTL)="")!$D(Q("DIST",Y)) S Q("DIST")=0 D %XY^%RCR S $P(DSV,U,4)="",$P(DSV,U,6)="" S:'DSEC $P(DSV,U,2,3)=U S ^UTILITY(U,$J,D,Y,0)=DSV D BLK G QQ I DIT!($P($P(DSV,U),DTL)="")!$D(Q(D,Y)) S Q(D)=0 D %XY^%RCR K ^UTILITY(U,$J,D,Y,"RD"),^("AB") K:'$D(DTL(F))&(D["DIBT") ^(1) S:'DSEC ^(0)=$P(DSV,U,1,2)_U_U_F_U_U_U_U_$P(DSV,U,8,9) W "." QQ Q BLK N D,%X S D="DIST(.404,",%X=U_D_"Y," F I=0:0 S I=$O(^UTILITY(U,$J,"DIST(.403,",Y,40,I)) Q:'I I $D(^(I,0)) S %=+$P(^(0),U,2) S:$D(^DIST(.404,%,0)) $P(^UTILITY(U,$J,"DIST(.403,",Y,40,I,0),U,2)=$P(^(0),U) S K=Y,Y=% D:$D(^DIST(.404,%,0)) %XY^%RCR S Y=K D B2 Q B2 F J=0:0 S J=$O(^UTILITY(U,$J,"DIST(.403,",Y,40,I,40,J)) Q:'J I $D(^(J,0)) S %=+^(0) I $D(^DIST(.404,%,0)) S $P(^UTILITY(U,$J,"DIST(.403,",Y,40,I,40,J,0),U)=$P(^(0),U),K=Y,Y=% D %XY^%RCR S Y=K Q ; DIFROM2 ; S DIFROM=5,Y=DRN-1,S="" S DH=" ; LOADS AND INDEXES DD'S",^UTILITY($J,.3,0)=" K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U=""^"",DSEC=1" S X="",DD="A" F E=1:1 S DD=$O(Q(DD)) Q:DD="" S X=X_","""_$E(DD,1,3)_"""" S DL=0,^UTILITY($J,1.4,0)=" S NO=$P(""I 0^I $D(@X)#2,X[U"",U,%) I %<1 K DIFQ Q" S DIRS(1)=" I %<1 K DIFQ Q" S:E>1 ^UTILITY($J,2,0)=" F X="_$E(X,2,99)_" D W Q:'$D(DIFQ)" G ^DIFROM2 ; EQ W $C(7),!!,"PACKAGE TOO LARGE! DIFROM CAN NOT BUILD ANY MORE INIT ROUTINES.",!! Q K ^UTILITY($J),^("^",$J),^UTILITY("DIF",$J),DIFROM,DR,DD,DLAYGO,DIRS,DIMA,DWLW,DREF,D1 K DI,DISYS,DIX,DIY,DO,DZ,DIK,DIDUZ,DIFQ,DDF,DDT,NO,DIF,DIG,DIH,DIU,DIV,DIW K %,%1,%2,%A,%B,%C,%DT,%V,%X,%Y,%Z,DDH,DG,D0,DA,DIFRM,DL,D,E,DIC,DIE,DN,DPK,DQ K DIFC,DRN,DIRUT,DIROUT,DTOUT,DUOUT,DIR,DIFQR,DNAME,DSEC,DTL K A,C,I,J,K,F,L,N,Q,R,S,X,Y,Z,DSV,DIDIU,DIFKEP,DIFR,DIFR1,DIFR2,DIT,DH,DILN2,DIFL,VERSION K DIFRDIFI,DIFRF,DIFRIR,DIFRRMAX,DIFRRN,DIFRRTN,DIFRRXT,DIFRS,DIFRTX K DIOVRD Q DIFROM12 DIFROM12 ;SFISC/XAK-CREATES RTN ENDING IN INIT1 ;12:50 PM 28 Sep 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. VER ; W !!?5,"Now you must enter the information that goes on the second line",!?5,"of the INIT routines.",! G:DPK<1 V2 S DIE=9.4,DA=Q,DR=22,DR(2,9.49)=1 D ^DIE I $D(Y) S (DUOUT,DIRUT)=1 Q G V2:'$D(D1) S X=^DIC(9.4,DPK,22,D1,0),DPK(1)=$P(X,U,1),DILN2=" ;;"_DPK(1)_";"_$P(^DIC(9.4,DPK,0),U,1)_";;",Y=$P(X,U,2) D DD^%DT S DILN2=DILN2_Y W !! Q V2 K DIR S DIR(0)="F^4:30",DIR("A")="Package Name",DIR("?")="^D PNM^DIFROMH1" D ^DIR Q:$D(DIRUT) S DILN2=Y K DIR S DIR(0)="F^1:9^K:'(X?1.3N.1""."".2N.1A.2N) X",DIR("A")="Version",DIR("?")="^D VER^DIFROMH1" D ^DIR Q:$D(DIRUT) S DPK(1)=Y,DILN2=" ;;"_Y_";"_DILN2_";;" K DIR S DIR(0)="D^::EX",DIR("A")="Date Distributed",DIR("?")="^D VDT^DIFROMH1" D ^DIR Q:$D(DIRUT) D DD^%DT S DILN2=DILN2_Y W !! Q PKG ; Q:DTL="DIPK"!(DTL="DI") S %Y="^UTILITY(U,$J,""PKG"",DPK,",%X="^DIC(9.4,"_DPK_"," W !,"Moving "_$P(^DIC(9.4,DPK,0),U)_" Entry into Init's." S D=%X_"""22""," D %XY^%RCR K DR S:$D(^DISV(DUZ,D)) DR=^(D) I $P(^DIC(9.4,DPK,0),U,4) S DL=$S($D(^DIC(9.2,+$P(^(0),U,4),0))#2:$P(^(0),U),1:""),$P(^UTILITY(U,$J,"PKG",DPK,0),U,4)=DL F %="PRE","INI","INIT" S:$D(^UTILITY(U,$J,"PKG",DPK,%)) $P(^(%),U,2)="" K ^UTILITY(U,$J,"PKG",DPK,"VERSION"),DIE Q:'$D(^ORD(100.99,1,5,DPK,0)) OR ; S %X="^ORD(100.99,1,5,DPK,",%Y="^UTILITY(U,$J,""OR"",DPK," D %XY^%RCR S %=$P(^ORD(100.99,1,5,DPK,0),U,4) I %]"" S %=$S($D(^ORD(100.98,%,0)):$P(^(0),U),1:"") I %]"" S $P(^UTILITY(U,$J,"OR",DPK,0),U,4)=% F I=0:0 S I=$O(^ORD(100.99,1,5,DPK,1,I)) Q:'I I $D(^(I,0)) S %=+$P(^(0),U) I $D(^ORD(101,%,0)) S $P(^UTILITY(U,$J,"OR",DPK,1,I,0),U)=$P(^(0),U) D OR1 F I=0:0 S I=$O(^ORD(100.99,1,5,DPK,5,I)) Q:'I I $D(^(I,0)) S %=+$P(^(0),U,3) I $D(^ORD(101,%,0)) S $P(^UTILITY(U,$J,"OR",DPK,5,I,0),U,3)=$P(^(0),U) K ^UTILITY(U,$J,"OR",DPK,"B") Q OR1 F J=0:0 S J=$O(^ORD(100.99,1,5,DPK,1,I,1,J)) Q:'J I $D(^(J,0)) S %=+$P(^(0),U) I $D(^ORD(101,%,0)) S $P(^UTILITY(U,$J,"OR",DPK,1,I,1,J,0),U)=$P(^(0),U) Q DIFROM2 DIFROM2 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT1' ;31OCT2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S ^UTILITY($J,2.5,0)=" Q:'$D(DIFQ) S %=2 W !!,""ARE YOU SURE EVERYTHING'S OK"" D YN^DICN I %-1 K DIFQ Q" I $D(^DIC(9.4,DPK,"INI")),$P(^("INI"),U)]"" S ^UTILITY($J,2.6,0)=" D ^"_$P(^("INI"),U)_" D NOW^%DTC S DIFROM(""INI"")=%" S ^UTILITY($J,2.7,0)=" I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0 S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2" S ^UTILITY($J,3,0)=" D DT^DICRW K ^UTILITY(U,$J),^UTILITY(""DIK"",$J) D WAIT^DICD" K Q S ^UTILITY($J,3.1,0)=" S DN=""^"_DN_""" F R=1:1:"_Y_" D @(DN_$$B36(R)) W "".""" S X=4,Q=" ;",^UTILITY($J,X,0)=" F S D=$O(^UTILITY(U,$J,""SBF"","""")) Q:D'>0 K:'DIFQ(D) ^(D) S D=$O(^(D,"""")) I D>0 K ^(D) D IX" S DIRS=" K:%<0 DIFQ" S E=$E(DTL_"INIT",1,7),DNAME=E_1,D=-9999 F DD=1:1 S X=$E($T(TEXT+DD),4,999) Q:X="" S ^UTILITY($J,DD+4,0)=X S:DD=19 ^UTILITY($J,DD+4,0)=X_DIRS S ^UTILITY($J,1.5,0)="ASK I %=1,$D(DIFQ(0)) W !,""SHALL I WRITE OVER FILE SECURITY CODES"" S %=2 D YN^DICN S DSEC=%=1"_DIRS(1) D ZI^DIFROM3 G ^DIFROM3 Q TEXT ; ;;KEYSNIX ; Keys and new style indexes installer ; new in FM V22.2 ;; N DIFRSA S DIFRSA=$NA(^UTILITY("KX",$J)) ; Tran global for Keys and Indexes ;; N DIFRFILE S DIFRFILE=0 ; Loop through files ;; F S DIFRFILE=$O(@DIFRSA@("IX",DIFRFILE)) Q:'DIFRFILE D ;; . K ^TMP("DIFROMS2",$J,"TRIG") ;; . N DIFRD S DIFRD=0 ;; . F S DIFRD=$O(@DIFRSA@("IX",DIFRFILE,DIFRD)) Q:'DIFRD D DDIXIN^DIFROMSX(DIFRFILE,DIFRD,DIFRSA) ; install New Style Indexes ;; . K ^TMP("DIFROMS2",$J,"TRIG") ;; . S DIFRD=0 ;; . F S DIFRD=$O(@DIFRSA@("KEY",DIFRFILE,DIFRD)) Q:'DIFRD D DDKEYIN^DIFROMSY(DIFRFILE,DIFRD,DIFRSA) ; install keys ;; K @DIFRSA ; kill off tran global ;; ; VEN/SMH v22.2: Below I added a K D1 because it leaks from the call causing the key matching algo to fail. ;;DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0 ;; I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 K D1 Q:'$D(^(D0,0)) S Z=^(0) D I^DITR ;; K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA ;; ; ;;W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0)) ;; S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W ;; S:%=2 DIFQ(X)=0 ;; Q ;; ; ;;OPT ;OPTION ;;RTN ;ROUTINE DOCUMENTATION NOTE ;;FUN ;FUNCTION ;;BUL ;BULLETIN ;;KEY ;SECURITY KEY ;;HEL ;HELP FRAME ;;DIP ;PRINT TEMPLATE ;;DIE ;INPUT TEMPLATE ;;DIB ;SORT TEMPLATE ;;DIS ;FORM ;;REM ;REMOTE PROCEDURE ;; ; ;;SBF ;FILE AND SUB FILE NUMBERS ;;IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK) ;; S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK ;; I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK ;; Q ;;B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1) ;;N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) DIFROM3 DIFROM3 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT2' (HELP FRAMES) ; 6 DEC 2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DIRS=" S DIFQ=1" S DNAME=E_2,DL=0,(DH,Q)=" ;" K ^UTILITY($J) F DD=1:1 S X=$T(TEXT+DD) Q:X="" S ^UTILITY($J,DD,0)=$E(X,4,999) S:$E(X,4)="U" ^(0)=^(0)_DIRS S DIFROM=2 D ZI G ^DIFROM4 ; FILE ; D:'$D(DISYS) OS^DII S DL=0,Q="Q Q",S=" ;;" NAME S D=0 I DRN>12959 K DRN Q S DNAME=DN_$$B36(DRN) ZI ; I '$D(DIFROM(1)) S %H=+$H D YX^%DTC S DIFROM(1)=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12) 2 K ^UTILITY($J,0) S ^(0,1)=DNAME_" ; ; "_DIFROM(1),D=$L(^(1))+2 ; (2 = CR/LF) S ^(1.1)=DILN2,D=D+$L(^(1.1))+2 ; (2 = CR/LF) S ^UTILITY($J,0,2)=DH,D=D+$L(^(2))+2 ; (2 ditto) S ^UTILITY($J,0,3)=Q,D=D+$L(^(3))+2 ; (2 ditto) F L=4:1 D Q:DL'>0 I D+257>DIFRM,$E(^(L),4)'="^",$E(^(L),4)'=$C(126) Q ; 255 for a line extra in M95 + 2 CR/LF . S DL=$O(^UTILITY($J,DL)) . Q:DL'>0 . S ^UTILITY($J,0,L)=S_^(DL,0) . S D=$L(^(L))+D+2 ; VEN/SMH - Add 2 charcaters for CR/LF S DRN=DRN+1,X=DNAME X ^DD("OS",DISYS,"ZS") W !,X_" HAS BEEN FILED..." G NAME:DL>0 K K %A,%B,%C,%Z,^UTILITY($J) S DL=0 Q ; B36(X) ;Calculate base 36 number from 0 (000) to 46,655 (ZZZ). S X=$G(X) I X>46655 Q "" Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1) N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) ; TEXT ; ;; K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5 ;; I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD ;; Q ;; ; ;;ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0 S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR ;; S DIK=DIC ;;HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R="" W !,"'"_R_"' Help Frame filed." S DA=^(R) ;; F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99) ;; S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0) ;; I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I ;;IX D IX1^DIK G HELP ;; ; ;;U I $D(DIRUT) ;; W ! Q ;;REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF ;; S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT) ;; I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q ;; S DIR("A")="Shall I replace your file with mine" ;; S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y ;; S DIU(0)="E",DIR("A")="Do you want to keep the Data" ;; S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT) ;; S:'Y DIU(0)=DIU(0)_"D" ;; S DIR("A")="Do you want to keep the Templates" ;; S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T" ;; S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q DIFROM4 DIFROM4 ;SFISC/XAK-CREATES 'INIT3' ;2:49 PM 25 Sep 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DNAME=E_3,DIRS=E_4,DL=0,(DH,Q)=" ;" K ^UTILITY($J) F DD=1:1 S X=$T(TXT+DD) Q:X="" S ^UTILITY($J,DD,0)=$E(X,4,999) S:$E(X,4,5)="OR" ^(0)=^(0)_DIRS D ^DIFROM41 S DIFROM=2 D ZI^DIFROM3 G ^DIFROM42 TXT ; ;; K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0)) ;; S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X="" W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins." ;; I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD ;; G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT ;; I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=% ;;OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^ ;;NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP ;; I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J) ;; I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD ;; S DIC=.5,DLAYGO=0,N="FUN" D ADD ;; I $P($G(^DIC(8994,0)),U)="REMOTE PROCEDURE" S (DIC,DLAYGO)=8994,N="REM" D ADD ;; S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD ;; K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD ;; S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD ;; K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ ;; K ^UTILITY("DIFROM",$J) Q DIFROM41 DIFROM41 ;SFISC/XAK-CREATES 'INIT3' (CONT.) ;11:02 AM 13 Sep 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S L=0 F DD=DD:1 S L=L+1,X=$T(TXT+L) Q:X="" S ^UTILITY($J,DD,0)=$E(X,4,999) Q TXT ; ;;DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII ;; E S DISYS=^DD("OS") ;; Q:'$D(^DD("OS",DISYS,"ZS")) ;; S DIFR1="" ;;DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1="" ;; F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z") ;; G DZ1 ;; ; ;;OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q ;; W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP ;; I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=% ;; S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0)) ;; S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0 ;; D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C") ;; F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X ;; S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP ;; ; ;;ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A ;;Q Q ;;A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0)) ;; K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^") ;; I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%) ;; I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D ;; .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!" ;; .Q ;; I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1) ;; I N="DIST(.403," D BLK ;; S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR ;; D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT ;; I N="DIST(.403," D ;; .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA) ;; .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q ;; .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled" ;; .Q ;; Q ;;BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1 ;; K A0,A1,A2,J,L Q ;;B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D ;; .N X S X=0 ;; .F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X) ;; .Q ;; S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0 ;; F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D ;; .N X S X=0 ;; .F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X) ;; .Q ;; S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK") ;; Q ;;KAD(D0) N D1,X ;; S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1) ;; Q DIFROM42 DIFROM42 ;SFISC/XAK-CREATES 'INIT4' ;10/9/95 05:59 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DNAME=E_4,DL=0,(DH,Q)=" ;" K ^UTILITY($J) F DD=1:1 S X=$T(TXT+DD) Q:X="" S ^UTILITY($J,DD,0)=$E(X,4,999) S DIFROM=2 D ZI^DIFROM3 G ^DIFROM5 TXT ; ;;EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK ;; S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_"," ;; S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1) ;; D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4) ;; I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=% ;; D OR ;; S DA(1)=1 D IX1^DIK ;; Q ;;OR S (N,I)=0,X="" ;; F S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1 ;; S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X="" ;; F S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1 ;; S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J ;; Q ;;OR1 N X F S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1 ;; S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J ;; Q ;;ADDP N I,J,N,R,DA,DLAYGO,DO S %="" ;; S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1 S %=+Y Q DIFROM5 DIFROM5 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT' ;03:14 PM 28 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DIFRF=0,DIFRRXT="567890ABCDEFGHIJKLMNOPQRUVWXZ",DIFRRN=E,DIFRTX=0 S DIFRRMAX=$S($G(DIFRM)>1999:DIFRM,$G(^DD("ROU"))>1999:^("ROU"),1:2000) F DIFRIR=1:1 S X=0,Q=" Q",DNAME=DIFRRN_$E(DIFRRXT,DIFRIR) D Q:DIFRF'>0 .S DIFRS=510 .F S DIFRF=$O(F(DIFRF)) Q:DIFRF'>0 D Q:DIFRS>DIFRRMAX ..S X=X+1 ..S DH=$P(@(F(DIFRF,0)_"0)"),U,2) ..S ^UTILITY($J,X,0)=" ;;"_DH_";"_F(DIFRF)_";"_F(DIFRF,0)_";"_$S($D(F(DIFRF,DIFRF)):F(DIFRF,DIFRF),1:"")_";"_$TR(F(DIFRF,-222),"^",";"),DIFRS=DIFRS+$L(^UTILITY($J,X,0)) ..S X=X+1 ..S ^UTILITY($J,X,0)=" ;;"_F(DIFRF,-223),DIFRS=DIFRS+$L(^UTILITY($J,X,0)) ..Q .S DH=$S(DIFRIR=1:" K ^UTILITY(""DIF"",$J) S DIFRDIFI=1",1:"") .S DH=DH_" F I=1:1:"_X_" S ^UTILITY(""DIF"",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1" .S ^UTILITY($J,.5,0)="IXF ;;"_$P(DPK(0),U,1,2) .S DIFRTX=DIFRTX+X,D=-9999,DIFROM=X D ZI^DIFROM3 K ^UTILITY($J) .Q S Q=$S('$D(^DIC(9.4,DPK,"INIT")):1,$P(^("INIT"),U)?1PA.E:$P(^("INIT"),U),1:1) S DRN=^DD("VERSION"),X=DIFROM S ^UTILITY($J,5,0)=" F DIF=1:2:"_DIFRTX_" S %=^UTILITY(""DIF"",$J,DIF),DIK=$P(%,"";"",5),N=$P(%,"";"",3),D=$P(%,"";"",4)_U_N D D K DIFQ(N)" S ^UTILITY($J,9,0)=" L S DUZ=DIDUZ W:"_(DIFRTX>0)_" !"_$S(Q:",$C(7),""OK, I'M DONE."",!",1:"")_",""NO""_$P(""TE THAT FILE"",U,DSEC)_"" SECURITY-CODE PROTECTION HAS BEEN MADE""" I 'Q S ^UTILITY($J,9.1,0)=" D ^"_Q_",NOW^%DTC S DIFROM(""INIT"")=%" S ^UTILITY($J,9.11,0)=" I DIFROM F DIF=1:2:"_DIFRTX_" S %=^UTILITY(""DIF"",$J,DIF),N=+$P(%,"";"",3) I N,$P(%,"";"",8)=""y"" S ^DD(N,0,""VR"")=DIFROM" S ^UTILITY($J,9.12,0)=" I DIFROM(0)>0 F %=""PRE"",""INI"",""INIT"" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)" S ^UTILITY($J,9.13,0)=" I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN" S ^UTILITY($J,9.2,0)=" S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),""VERSION"")=DIFROM G Q^DIFROM0" S ^UTILITY($J,9.3,0)="D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_""0)"")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)" S ^UTILITY($J,9.4,0)=" S DIFQR=DIFQR(+N) I ^DD(""VERSION"")>17.5,$D(^DD(+N,0,""DIK""))#2 S X=^(""DIK""),Y=+N,DMAX=^DD(""ROU"") D EN^DIKZ" S ^UTILITY($J,9.5,0)=" I DIFQR D IXALL^DIK:$O(@(DIK_""0)"")) W "".""" S ^UTILITY($J,9.6,0)=" Q" S ^UTILITY($J,9.7,0)="R G REP^"_E_2 F DD=1:1 S E=$T(T+DD) Q:E="" S E=$E(E,4,999) S:E="IXF ;;" E=E_$P(DPK(0),U,1,2)_";"_DUZ S ^UTILITY($J,9+DD,0)=E S DIFROM=10 G ^DIFROM6 T ;; ;; ; ;;1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) ;; W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") ;; I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S ;; I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 ;; S DIFQ(N)=$P(DIF(I),";",7)'="n" ;; I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 ;; S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S ;; I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y ;;S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) ;; I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q ;; S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 ;; Q ;;Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 ;; ; ;;PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC ;; Q ;; ; ;;IXF ;; DIFROM6 DIFROM6 ;SFISC/XAK-CREATES RTN ENDING IN 'INIT' ;03:06 PM 28 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DH=" ;",Q=" K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT" S ^UTILITY($J,.3,0)=" S DIOVRD=1,U=""^"",DIFQ=0,DIFROM="""_$S($D(DPK(1)):DPK(1),1:0)_""" W !,""This version"_$S($D(DPK(1)):" (#"_DPK(1)_")",1:"")_" of '"_DTL_"INIT' was created on "_DIFROM(1)_"""" S ^UTILITY($J,1,0)=" I $D(^DD(""VERSION"")),^(""VERSION"")'<"_+DRN_" G GO" S ^UTILITY($J,2,0)=" ;W !,""FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...."" D N^DINIT" S ^UTILITY($J,2.9,0)=" I ^DD(""VERSION"")<"_+DRN_" W !,""but I need version "_+DRN_" of the VA FileMan!"" G Q" S ^UTILITY($J,3,0)="GO ;" S ^UTILITY($J,3.5,0)="EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM" S ^UTILITY($J,3.6,0)=" S DIFQ=0 K DIRUT,DTOUT,DUOUT" S ^UTILITY($J,3.7,0)=" F DIFRIR=1:1:"_DIFRIR_" S DIFRRTN="_""""_U_DIFRRN_""""_"_$E("_""""_$E(DIFRRXT,1,DIFRIR)_""""_",DIFRIR) D @DIFRRTN" S ^UTILITY($J,3.8,0)=" W:"_(DIFRTX>0)_" !,""I AM GOING TO SET UP THE FOLLOWING FILE"_$E("S",X>1)_":"" F I=1:2:"_DIFRTX_" S DIF(I)=^UTILITY(""DIF"",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)" S X=$E(DTL_"INIT",1,7) S ^UTILITY($J,4,0)=" S DIFROM="""_$S($D(DPK(1)):DPK(1),1:0)_""" D PKG:'$D(DIFROM(0)),^"_X_"1 G Q:'$D(DIFQ) S DIK(0)=""AB""" S ^UTILITY($J,6,0)=" K DIFQR D ^"_X_"2,^"_X_3,X=0 D VERSION^DI S ^UTILITY($J,.6,0)=" W !?9,""("_$S($D(^DD("SITE")):"at "_^("SITE")_",",1:"")_" by "_X_")"",!" I DPK>0,$D(^DIC(9.4,DPK,"PRE")),$P(^("PRE"),U)]"" S ^UTILITY($J,3.1,0)=" W !,""I HAVE TO RUN AN ENVIRONMENT CHECK ROUTINE."" D PKG,^"_$P(^("PRE"),U)_" Q:'$D(DIFQ) D NOW^%DTC S DIFROM(""PRE"")=%" K ^UTILITY(U,$J),E S D=-9999,DNAME=DTL_"INIT",DL=0 D 2^DIFROM3 I $G(DPK)>0,$D(^%ZOSF),$D(^%ZTSK) N DIFRINIS D SETUP^DIFROM7(DTL_"INIT",.DIFRINIS) W:$G(DIFRINIS)["INIS" !,DTL,"INIS HAS BEEN FILED..." Q ; INTEG W !,"..." S X=0,%X="F %Y=1:1:DD S D=$A(DNAME,%Y)*%Y+D" F XCNP=XCNP:0 S X=$O(^UTILITY($J,X)) Q:X="" W "." X "ZL @X S D=0 F Y=1:1 S DNAME=$T(+Y),DD=$L(DNAME) X %X I 'DD S ^UTILITY(""DINTEG"",$J,X)=D ZL DIFROM6 Q" Q DIFROM7 DIFROM7 ;SFISC/(SLC/STAFF)-SITE TRACKING INSTALL BULLETIN ; 29NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. SETUP(ROUTINE,STATUS) ; K ^TMP($J) N LINE,LINE1,LINE2,NUM,OK,ROUTINIS,TXT D:'$D(DISYS) OS^DII D LOAD(ROUTINE,"^TMP($J,",0) I $P($P(^TMP($J,1,0),";")," ")'?1U1.3UN1"INIT" S STATUS="not changed" Q S ROUTINIS=$P(ROUTINE,"INIT")_"INIS" S (OK,LINE)=0 F S LINE=$O(^TMP($J,LINE)) Q:LINE<0 S TXT=^(LINE,0) S:TXT[("PAC^"_ROUTINIS) OK=2 Q:OK=2 I TXT["=DIFROM G Q^DIFROM" S OK=1 Q I 'OK S STATUS="not installed" Q I OK=1 D .S ^TMP($J,LINE-.9,0)=" I DIFROM,$D(^%ZTSK) S X="""_ROUTINIS_""" X ^%ZOSF(""TEST"") D:$T PAC^"_ROUTINIS_"($T(IXF),.DIFROM)" .D SAVE(ROUTINE,"^TMP($J,",0) .S STATUS="site tracking installed" I OK=2 S STATUS="already installed" S LINE1=ROUTINIS_$P(^TMP($J,1,0),ROUTINE,2,99),LINE2=^TMP($J,2,0) K ^TMP($J) S ^TMP($J,1,0)=LINE1,^TMP($J,2,0)=LINE2 F NUM=3:1 S LINE=$P($T(NMSPINIS+NUM),";",3,99) Q:LINE="" D .I LINE["@@@@@@" S LINE=$P(LINE,"@@@@@@")_ROUTINIS_$P(LINE,"@@@@@@",2) .S ^TMP($J,NUM,0)=LINE D SAVE(ROUTINIS,"^TMP($J,",0) S STATUS=STATUS_" -- "_ROUTINIS_" saved" K ^TMP($J) Q LOAD(X,DIF,XCNP) X ^DD("OS",DISYS,"LOAD") Q SAVE(X,DIE,XCN) ; VEN/SMH - Modified save code to work on Standalone Fileman K ^UTILITY($J,0) N I S I=0 F S I=$O(^TMP($J,I)) Q:'I S ^UTILITY($J,0,I)=^TMP($J,I,0) X ^DD("OS",DISYS,"ZS") K ^UTILITY($J,0) Q NMSPINIS ;; ;; ;; ;;PAC(PKG,VER) ; called from package init (DIFROM7 created this routine) ;; ; PKG = $T(IXF) of the INIT routine. ;; ; VER is an array that is contained in DIFROM from the INIT routine ;; ; ;; N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("@@@@@@",$J) ;; ; ;; ; Site tracking updates only occur if run in a VA production primary domain ;; ; account. ;; I $G(^XMB("NETNAME"))'[".VA.GOV" Q ;; Q:'$D(^%ZOSF("UCI")) Q:'$D(^%ZOSF("PROD")) ;; X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q ;; ; ;; S SERVER="S.A5CSTS@FORUM.VA.GOV" ;; S PACKAGE=$P($P(PKG,";",3),U) ;; S SITE=$G(^XMB("NETNAME")) ;; S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown" ;; D ; check if ok to use kernel functions ;; .S X="XLFDT" X ^%ZOSF("TEST") I $T D Q ;; ..S NOW=$$HTFM^XLFDT($H) ;; ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3) ;; ..S START=$$FMTE^XLFDT(START) ;; ..S DATE=NOW\1 ;; ..S NOW=$$FMTE^XLFDT(NOW) ;; .D NOW^%DTC S NOW=%,DATE=X ;; .S RUN="" ; don't bother to compute ;; .S Y=START D DD^%DT S START=Y ;; .S Y=NOW D DD^%DT S NOW=Y ;; ; ;; ; Message for server ;; S ^TMP("@@@@@@",$J,1,0)="PACKAGE INSTALL" ;; S ^TMP("@@@@@@",$J,2,0)="SITE: "_SITE ;; S ^TMP("@@@@@@",$J,3,0)="PACKAGE: "_PACKAGE ;; S ^TMP("@@@@@@",$J,4,0)="VERSION: "_VER ;; S ^TMP("@@@@@@",$J,5,0)="Start time: "_START ;; S ^TMP("@@@@@@",$J,6,0)="Completion time: "_NOW ;; S ^TMP("@@@@@@",$J,7,0)="Run time: "_RUN ;; S ^TMP("@@@@@@",$J,8,0)="DATE: "_DATE ;; ; ;; ; Data is sent to server on FORUM - S.A5CSTS ;; S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""@@@@@@"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION" ;; D ^XMD ;; K ^TMP("@@@@@@",$J) ;; Q ;; DIFROMH DIFROMH ;SFISC/XAK-HELP FOR DIFROM ; 31OCT2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;HELP FOR OPTIONS, BULLETINS, ETC. W !!?5,"YES means that you want to bring the ",$P(^DIC(DL,0),U) W "S in this namespace." W !?5,"NO means that you want to leave them out." Q:DL'=9.8 W !?5,"This question refers to entries in the ROUTINE documentation file." W !!?5,"Also, if you are building a network mail INIT, you must answer",!?5,"YES if you wish to include routines other than just the INIT",!?5,"routines (such as pre and post-inits) into the network mail message." Q R ; HELP FOR PREFIX W !!?5,"This is a unique 2 to 4 character prefix beginning with an uppercase" W !?5,"letter and followed only by uppercase letters or numbers." Q:X'?1"??".E W !?5,"If this is an established package, you may enter one of the prefixes" W !?5,"listed in the left column below." S DIC="^DIC(9.4,",DIC(0)="QE",DIC("W")="W ?10,$P(^(0),U)",D="C",DILN=15,DZ="??" D DQ^DICQ K DIC,DIZ,DILN Q ; R1 ; HELP FOR RTN NAME W !!?5,"Answer YES if you want to create a program called "_DTL_"INIT" W:$D(Q) !?5,"even though there already is one on file. (It will be overwritten.)" W !?5,"Answer NO if you don't want to do this." Q ; S ; HELP FOR SECURITY CODES W !!?5,"YES means you want to include the security protection currently" W !?5,"on the files in the initialization routines. A recipient of" W !?5,"this package will be able to decide whether or not to accept" W !?5,"these codes." W !?5,"NO means you do not want to include security codes." Q M ; HELP FOR MAX RTN SIZE W !!?5,"Enter the maximum number of characters each routine should" W !?5,"contain. This number must be between 2000 and "_^DD("ROU")_"." ; VEN/SMH V22.2 Q ; MSG ; HELP FOR MAILMAN MESSAGE W !!?5,"YES means that you are going to send this Package over" W !?5,"the Network as a message." W !?5,"NO means that you are going to generate routines." Q Q1 ; HELP FOR SCRAMBLE PASSWORD W !?5,"The scramble password is a private code, which must be " W !?5,"exactly correct for a reader to to see the message legibly" W !?5,"It may be from 3 to 20 characters long. Upper and lower" W !?5,"case characters are treated as the same.",! Q ; Q3 ; HELP FOR SCRAMBLE HINT W !?5,"A scramble hint is used to suggest to the reader what" W !?5,"the scramble password is. Since the password is not" W !?5,"recoverable after it is entered, the hint can be a " W !?5,"helpful reminder to the reader of the message. The" W !?5,"hint will be shown to the recipient just before he " W !?5,"is asked to enter the password.",! Q R3 ;DATA DICTIONARIES W !!?5,"Enter YES if you wish to transport dictionaries" W !?5,"or NO if you just want to Transport Options, Keys, etc." Q NOPKG ; TEMPLATES WITH NON-PACKAGE FILE PREFIX W !!?5,"If YES, then ALL of the templates and forms belonging to the files" W !?5,"selected will be included in the initialization routines." W !?5,"If NO, only NAMESPACED templates and forms will be included.",! Q DIFROMH1 DIFROMH1 ;SFISC/XAK-HELP FOR ANSWERING DIFROM PROMPTS ;03:15 PM 28 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. REP ;CHANGING YOUR FILE NAME W !!?5,"If YES, this will change the existing file name" W !?5,"to the incoming file name." W !?5,"If NO, it then will go on to the next Question.",! Q CHG ;KEEPING YOUR OLD DATA W !!?5,"This allows you to keep your old data if you wish." W !?5,"I suggest if you get to this" W !?5,"question Just Default to the Question.",! Q TEMP ;DELETING THE TEMPLATES W !!,"This will allow you to Delete or Keep the" W !,"(Sort,Print,Input) Templates if you wish.",! Q AG ;DELETING FILES THAT ARE THE SAME W !!?5,"Enter Yes if you wish to Delete your file" W !?5,"This will overwrite your file with my file" W !?5,"If you wish to save your file please say" W !?5,"NO. It will then Quit the INIT Process.",! Q PKG ;ACCEPT DEFAULT DEFINITION W !!?5,"YES means that the information currently in the Package" W !?5,"File will be used to generate the package. You will not be" W !?5,"to alter it." W !?5,"NO means that you will be able to define the package as you" W !?5,"proceed with the DIFROM." Q L ;DISPLAY CURRENT PKG DEFN N %A W ! D WAIT^DICD S DIC=9.4,L=0,BY="@NUMBER",FR=DPK,TO=DPK,FLDS="[DI-PKG-DEFAULT-DEFINITION]",IOP="HOME" D EN1^DIP K B,P,DP,DIJ,%9 Q CUR ;HELP FOR SEEING PACKAGE W !!?5,"YES means that the package definition will be displayed to" W !?5,"you on your current device." W !?5,"NO means that you will continue generating the package.",! Q DD ;HELP FOR OVERWRITING DD'S W !!?5,"YES means that the current data definitions will be overwritten" W !?5,"with the ones in these routines." W !?5,"NO means that only new data fields will be added." Q DTA ;HELP FOR ADDING DATA W !!?5,"YES means that the data coming in with these inits will" I DIF W !?5,"replace the data on file if a match is found." E W !?5,"only be added if there is no data on file." W !!?5,"Entries will be added if they do not match exactly" W !?5,"on Name and Identifiers." W !!?5,"NO means that everything will be left as is." Q VER ;HELP FOR VERSION NO. W !!?5,"Package Version No. must be entered to put onto the second" W !?5,"line of the INIT routines." W !!?5,"Format can be either the old type of version no. nnn.nn",!,?5,"or the new type, nnnXnn where X is either T for test phase",!?5,"or V for verification phase." Q PNM ;HELP FOR PACKAGE NAME W !!?5,"Enter the Package Name to go on the second line of the INIT routines." Q VDT ;HELP FOR VERSION DATE W !!?5,"Enter the Distribution Date for this Package, to go on the second",!?5,"line of the INIT routines. It should match the version date",!?5,"on the other routines being sent with this package." Q DIFROMS DIFROMS ;SFISC/DCL-DIFROM SERVER DD/DATA IN/OUT ;09:47 AM 19 Jan 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q DDOUT(DIFRFILE,DIFRFLG,DIFRFIA,DIFRTA,DIFRMSGR) ; DD OUT TO TARGET ARRAY ;FILE,FLAGS,FIA_ARRAY,TARGET_ARRAY,MSG_ROOT I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA")) D EN^DIFROMS1 G EXIT Q DDIN(DIFRFILE,DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; DD IN FROM SOURCE ARRAY ;FILE,FLAGS,FIA_ARRAY,SOURCE_ARRAY,MSG_ROOT I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRSA@("FIA")) N DIOVRD S DIOVRD=1 D EN^DIFROMS2 G EXIT Q DATAOUT(DIFRFILE,DIFRFLG,DIFRFIA,DIFRTA,DIFRMSGR) ; DATA OUT ;FILE,FLAGS,FIA_ROOT,TARGET_ARRAY_ROOT,MSG_ROOT I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA")) N DIFRERRC D EN^DIFROMS3 I $G(DIFRERRC) S DIERR=DIFRERRC G EXIT Q DATAIN(DIFRFILE,DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; DATA IN ;FILE,FLAGS,FIAROOT,SOURCE_ARRAY,MSG_ROOT I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRSA@("FIA")) N DIOVRD S DIOVRD=1 D EN^DIFROMS4 G EXIT Q ; EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q DIFROMS1 DIFROMS1 ;SFISC/DCL/TKW-MOVE DD TO TARGET ARRAY ;17APR2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q EN ; I '$D(@DIFRFIA) D ERR(1) Q G:$G(DIFRFILE) FCHK S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE Q FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(2) Q FILE N DSEC,DIFRD,DIFRX,DIFR01,DIFRFDD N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFRPFD S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)) S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p" S DSEC=$TR($P(DIFR01,"^",2),"y","Y")="Y" S DIFRPFD=@DIFRFIA@(DIFRFILE,DIFRFILE)=0 I DIFRFDD!DIFRPFD D .M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%")=^DIC(DIFRFILE,"%") .M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%D")=^DIC(DIFRFILE,"%D") .S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0)=$P(^DIC(DIFRFILE,0),"^",1,2) .S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0,"GL")=^DIC(DIFRFILE,0,"GL") .S @DIFRTA@("^DIC",DIFRFILE,"B",$E(@DIFRFIA@(DIFRFILE),1,30),DIFRFILE)="" .Q I DSEC,(DIFRFDD!(DIFRPFD)) D .D XY^%RCR("^DIC("_DIFRFILE_",0,",$$OREF^DILF($NA(@DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0)))) .K @DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0,"GL") .Q S DIFRD=0 ; * * Go through each DD and sub-DD * * F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 S DIFRPFD=^(DIFRD)=0 D .S DIFRX=0 .; * * Merge each field DD to transport structure * * .;F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I $D(@DIFRFIA@(DIFRFILE,DIFRD))<9!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D .F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I DIFRPFD!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D ..M @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX)=^DD(DIFRD,DIFRX) ..N SEC F SEC=8,8.5,9 I $D(^DD(DIFRD,DIFRX,SEC)) D:SEC=8 I SEC>8,^(SEC)'="^",$P(^(0),"^",2)'["K",^(SEC)'="@" D ...I DSEC S @DIFRTA@("SEC","^DD",DIFRFILE,DIFRD,DIFRX,SEC)=^DD(DIFRD,DIFRX,SEC) ...K @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX,SEC) ...Q ..; If multiple field sent, send ^DD(SUBFILE#,0) and ^("NM",multiple name) for partial DDs ..I 'DIFRPFD D ...N SUBNUM S SUBNUM=$$SUBNUM(DIFRD,DIFRX) ...I 'SUBNUM Q ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0)=^DD(SUBNUM,0) ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0,"NM",$O(^DD(SUBNUM,0,"NM","")))="" ...Q ..Q .; * * Clean up x-refs in DDs * * .S DIFRQ=$NA(@DIFRTA@("^DD",DIFRFILE,DIFRD)) .S DIFRTART=$$OREF^DILF(DIFRQ) .F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)["""" ..S DIFRK=1 ..S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0 ..F I=1:1 Q:I'0 D . I $O(^DD("IX","B",DIFRD,0)) D DDIXOUT^DIFROMSX(DIFRFILE,DIFRD,DIFRFDD,DIFRTA) . I $O(^DD("KEY","B",DIFRD,0)) D DDKEYOUT^DIFROMSY(DIFRFILE,DIFRD,DIFRTA) . Q Q ; Q SUBNUM(F,FD) ; ;Returns 0 if FielD in File is not multiple, otherwise subfile#. N SUBNUM S SUBNUM=+$P($G(^DD(F,FD,0)),U,2) I 'SUBNUM Q 0 I $P($G(^DD(SUBNUM,.01,0)),U,2)["W" Q 0 Q SUBNUM ; ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q ;;FIA Array Does Not Exist;1;9501 ;;FIA File Number Invalid;2;9502 DIFROMS2 DIFROMS2 ;SFISC/DCL/TKW-INSTALL DD FROM SOURCE ARRAY ;12MAR2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; Q EN ; I '$D(@DIFRSA) D ERR(5) Q I '$D(@DIFRFIA) D ERR(4) Q G:$G(DIFRFILE) FCHK S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE ;LOOP THRU ALL INCOMING TOP-LEVEL FILES Q FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(6) Q FILE ; N DIFR01,DIFR02,DIFRVR,DIFRFDD S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFR02=$G(^(2)) I $TR($E(DIFR01),"NY","ny")="n" D ERR(1) Q S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p" ;DIFRFDD=0 means PARTIAL DEFINITION I 'DIFRFDD,'$D(^DIC(DIFRFILE)) D ERR(7) Q I $D(^DIC(DIFRFILE,0)),$G(@DIFRFIA@(DIFRFILE,0,10))]"" X ^(10) I '$T D ERR(3) Q ;I $TR($E(@DIFRFIA@(DIFRFILE,0,5)),"NY","ny")="y",$D(^DIC(DIFRFILE)) D ERR(2) Q ;INSTALL ONLY IF NEW * * PHASING OUT * * N %1,DSEC,D,DA,DIC,DIK,DIFRD,DIFRDATA,DIFRFLD,DIFRDIC,DIFRGL,DIFRX,I,X,Y,Z S DSEC=$P(DIFR02,"^") ; **>> add file security if new file only <<** I 'DSEC,'$D(^DIC(DIFRFILE,0))#2 S DSEC=1 ; Check to see if the file was Deleted during Pre-Install ;delete DD wp text for file, field and x-ref description and field tech description ;also delete "NM" nodes when installing full DD at specified level I 'DIFRFDD D .K @DIFRSA@("DIFRNI",DIFRFILE) .N DIFRD .S DIFRD=DIFRFILE .F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D ..Q:$$UP(DIFRSA,DIFRFILE,DIFRD) ;abort DIFRD subfile if we can't see its parent ..S @DIFRSA@("DIFRNI",DIFRFILE,DIFRD)="" ..N DIFRNGF,DIFRNGFD ..S DIFRNGF=+$G(@DIFRSA@("UP",DIFRFILE,DIFRD,-1)) ..S DIFRNGFD=.01 F S DIFRNGFD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)) Q:DIFRNGFD="" Q:+$P($G(^(DIFRNGFD,0)),U,2)=DIFRD ..I DIFRNGFD'="" K @DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD) ..Q .Q K:DIFRFDD ^DIC(DIFRFILE,"%D") S DIFRD=0 F S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0 D .I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q .K:$D(@DIFRSA@("^DD",DIFRFILE,DIFRD,0,"NM"))\10 ^DD(DIFRD,0,"NM") .S DIFRFLD=0 .F S DIFRFLD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD)) Q:DIFRFLD'>0 D ..K ^DD(DIFRD,DIFRFLD,21),^(23) ..S DIFRX=0 ..F S DIFRX=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD,1,DIFRX)) Q:DIFRX'>0 D ...K ^DD(DIFRD,DIFRFLD,1,DIFRX,"%D") ...Q ..Q .Q I DIFRFDD F DIFRX="^DIC","^DD" D .;I DIFRX="^DIC",'DIFRFDD Q .N X .I DIFRX="^DIC",$G(^DIC(DIFRFILE,0))]"" S X=$P(^(0),"^",3,9) .M @DIFRX=@DIFRSA@(DIFRX,DIFRFILE) .I DIFRX="^DIC",$G(X)]"" S $P(^DIC(DIFRFILE,0),"^",3,9)=X .I DSEC,$D(@DIFRSA@("SEC",DIFRX,DIFRFILE)) M @DIFRX=@DIFRSA@("SEC",DIFRX,DIFRFILE) .Q I 'DIFRFDD D .N DIFRD .S DIFRD=0 .F S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0 D ..I $D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q ;ABORT ..M ^DD(DIFRD)=@DIFRSA@("^DD",DIFRFILE,DIFRD) ;HERE IS WHERE A WHOLE DD COMES OVER! SETUP ..I $G(@DIFRSA@("UP",DIFRFILE,DIFRD,-1)) S ^DD(DIFRD,0,"UP")=+^(-1) ;SET THE "UP" NODE, SINCE IT SEEMS NOT TO BE SENT WITH THE REST OF THE ^DD ..I DSEC,$D(@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)) M ^DD(DIFRD)=@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD) ..Q .Q S DIFRD=0 F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D .I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q .S D=DIFRD,DIK="A" F S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK) .S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK .I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," D IXALL^DIK .Q I 'DIFRFDD D G IXKEY .Q:'$D(@DIFRSA@("^DD",DIFRFILE,DIFRFILE,.01)) .S $P(@(^DIC(DIFRFILE,0,"GL")_"0)"),"^",2)=$$HDR2P^DIFROMSS(DIFRFILE) .Q S DIFRGL=^DIC(DIFRFILE,0,"GL"),DIFRDIC=$P(^DIC(DIFRFILE,0),U,1,2) S $P(DIFRDIC,"^",2)=@DIFRFIA@(DIFRFILE,0,0) I DIFRFDD,+$G(@DIFRFIA@(DIFRFILE,0,"VR")) S DIFRVR=^("VR") D .S ^DD(DIFRFILE,0,"VR")=$P(DIFRVR,"^") .S ^DD(DIFRFILE,0,"VRPK")=$P(DIFRVR,"^",2) .Q S DIFRDATA=$D(@(DIFRGL_"0)")),^(0)=DIFRDIC_"^"_$S(DIFRDATA#2:$P(^(0),"^",3,9),1:"^") ; IXKEY ; Bring INDEX and KEY entries K ^TMP("DIFROMS2",$J,"TRIG") S DIFRD=0 F S DIFRD=$O(@DIFRSA@("IX",DIFRFILE,DIFRD)) Q:'DIFRD D DDIXIN^DIFROMSX(DIFRFILE,DIFRD,DIFRSA) K ^TMP("DIFROMS2",$J,"TRIG") S DIFRD=0 F S DIFRD=$O(@DIFRSA@("KEY",DIFRFILE,DIFRD)) Q:'DIFRD D DDKEYIN^DIFROMSY(DIFRFILE,DIFRD,DIFRSA) ; DIKZ I $D(^DD(DIFRFILE,0,"DIK")) D .N %X,DIKJ,DIR,DMAX,X,Y,DIFRDIKA .D EN2^DIKZ(DIFRFILE,"",^DD(DIFRFILE,0,"DIK"),^DD("ROU"),"DIFRDIKA") .I $D(DIFRDIKA) M @DIFRSA@("DIKZ",DIFRFILE)=DIFRDIKA .S @DIFRSA@("DIKZ",DIFRFILE)=^DD(DIFRFILE,0,"DIK") .Q I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE)) D .N DIFRD .S DIFRD=0 .F S DIFRD=$O(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q:DIFRD'>0 D ..N DIFRERR S DIFRERR(1)=DIFRD ..D BLD^DIALOG(9512,.DIFRERR) ;"parent DD(s) missing" ..Q .Q Q ; UP(ROOT,FILE,DDN) ;Return 1 or 0 to install Q:FILE=DDN 1 Q:$D(^DD(DDN)) 1 Q:'$D(@ROOT@("UP",FILE,DDN)) 1 N MP,PARENT,T,X S MP=0,X="",T=0 F S X=$O(@ROOT@("UP",FILE,DDN,X)) Q:X="" S PARENT=+^(X) D Q:T!(MP) .I $D(^DD(PARENT))!$D(@ROOT@("FIA",FILE,PARENT)) S:X>-2 T=1 Q ;***GFT .S MP=1 .Q Q T ; ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q ;;FIA Node Is Set To "No DD Update";1;9503 ;;Already Exist On Target System (INSTALL ONLY IF NEW);2;9504 ;;Did Not Pass DD Screen;3;9505 ;;FIA Array Does Not Exist;4;9511 ;;Distribution Array Does Not Exist;5;9506 ;;FIA File Number Invalid;6;9507 ;;Partial DD/File Does Not Already Exist On Target System;7;9508 DIFROMS3 DIFROMS3 ;SFISC/DCL,TKW- DATA TO DISTRIBUTION ARRAY ;5/14/98 12:30 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q EN ; I '$D(@DIFRFIA) D ERR(2) Q G:$G(DIFRFILE) FILE S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE Q FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q ; * * * * PHASING OUT * * * * FILE N DIFRS,DIFRSCR,DIFRDA,DIFROOT,DIFRRLR,DIFR01,DIFRPR,DIFRDNSC,DIFRFRV,DIFRFRVX N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFR2DD,DIFRNODE,DIFRFELD,DIFRPCE,DIFRIENS,DIFRDD0 S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)),DIFRPR=$TR($P(DIFR01,"^",5),"Y","y")="y" I $TR($P(DIFR01,"^",7),"Y","y")'="y" Q I DIFRPR D PGL^DIFROMSP(DIFRFILE,"",DIFRTA) S DIFRS=$G(@DIFRFIA@(DIFRFILE,0,11))]"",DIFRSCR=$G(^(11)) S DIFROOT=$NA(@($$ROOT^DILFD(DIFRFILE,"",1))),DIFRDA=0 ;$NA/trans gbl $Q S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRO")) S:DIFRRLR="" DIFRRLR=DIFROOT I $D(@DIFRRLR)'>9 D ERR(4) Q N Y F S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0 D .I '$D(@DIFROOT@(DIFRDA,0)) D Q ..N DIFRERR S DIFRERR(1)=DIFRDA,DIFRERR(2)=DIFRFILE ..D BLD^DIALOG(9513,.DIFRERR) ..Q .I DIFRS,$D(@DIFRRLR@(DIFRDA,0)) S Y=DIFRDA X DIFRSCR Q:'$T ;set *NAKED* and *Y* .M @DIFRTA@("DATA",DIFRFILE,DIFRDA)=@DIFROOT@(DIFRDA) .Q S DIFRQ=$NA(@DIFRTA@("DATA",DIFRFILE)) ;$NA/trans gbl/$Q S DIFRTART=$$OREF^DILF(DIFRQ) F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""!(DIFRPR) .K R1 .S DIFRK=1 .S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0 .F I=1:1 Q:I>C S G=$P(R2,",",F,I) Q:G="" I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1(R1)=G,R1=R1+1,C=C+($L(G,",")-1) I 'G,G'?1"0".E,R1#2 S DIFRK=DIFRTART_$P(R2,",",1,I)_")" Q .I DIFRPR,DIFRK,'(R1#2) D Q ;RESOLVE POINTERS ..D Q:DIFR2DD'>0 ...I R1'>3 S DIFR2DD=DIFRFILE Q ...S R3="" ...F I=0:1:R1-3 S R3=R3_R1(I)_"," ...S DIFR2DD=+$P($G(@(DIFRTART_R3_"0)")),"^",2) ...Q ..S DIFRNODE=R1($O(R1(""),-1)),DIFRDNSC=R2 ..Q:'$D(@DIFRTA@("PGL",DIFR2DD,DIFRNODE)) ..S DIFRPCE=0 ..F S DIFRPCE=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE)) Q:DIFRPCE="" D:DIFRPCE>0 ...Q:$P(@DIFRQ,"^",DIFRPCE)="" ...S DIFRFELD=$O(@DIFRTA@("PGL",DIFR2DD,DIFRNODE,DIFRPCE,"")),(I,DIFRIENS)="" ...;CREATE IENS * * * * * * * * * * * * * * * * * ...F S I=$O(R1(I),-1) Q:I="" S:'(I#2) DIFRIENS=DIFRIENS_R1(I)_"," ...S DIFRDD0=^DD(DIFR2DD,DIFRFELD,0) ...D DIERR ...S DIFRFRV=$$GET1^DIQ(DIFR2DD,DIFRIENS,DIFRFELD) ...D DIERR ...I DIFRFRV']"" D Q ....N DIFRERR ....S DIFRERR(1)=DIFR2DD,DIFRERR(2)=DIFRIENS,DIFRERR(3)=DIFRFELD ....D BLD^DIALOG(9514,.DIFRERR) ....D DIERR ....Q ...S DIFRFRVX="FRV1" ...; If .01 field on file level is a pointer use "FRV0" subscript ...;I R1'>3,DIFRPCE=1,DIFRNODE=0 S DIFRFRVX="FRV0" ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE)=DIFRFRV ...S @DIFRTA@(DIFRFRVX,DIFRFILE,DIFRDNSC,DIFRPCE,"F")=$S($P(DIFRDD0,"^",2)["P":";"_$P(DIFRDD0,"^",3),$P(DIFRDD0,"^",2)["V":"1;"_$P($P(@DIFRQ,"^",DIFRPCE),";",2),1:"") ...D KEYVAL ...Q ..Q ..;Q:IF HEADER NODE OR IF NOT DATA NODE THEN FIND DD AND CHECK ..; IF DD#,"PGL",DATA NODE EXIST IF SO GET PIECE AND FIELD ..; AND SET IT UP INTO A STRUCTURE ; ALL RESOLVED; .01,IDs AND PTR. ..;IT WAS DECIDED NOT TO RESOLVE .01 AND ID POINTERS ..Q .Q:DIFRK .K @DIFRK .Q Q ; KEYVAL ; Send KEY values if pointed-to file has a primary KEY N DIFL S DIFL=$P(DIFRDD0,"^",2) I DIFL["P" S DIFL=+$P(DIFL,"P",2) E D . S DIFL=$P($P(@DIFRQ,"^",DIFRPCE),";",2) . S DIFL=+$P($G(@("^"_DIFL_"0)")),"^",2) Q Q:'DIFL N DIKEY S DIKEY=$O(^DD("KEY","AP",DIFL,"P",0)) Q:'DIKEY N X,DIOUT S DIOUT=0 D Q:DIOUT . S X=$P(^DD("KEY",DIKEY,0),U,4) I 'X S DIOUT=1 Q . S X=$P($G(^DD("IX",X,0)),U,2) I X="" S DIOUT=1 Q . S @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)=X Q N DIFLD,DIVAL,DIPTR,DIER,DIERR,DIFLDDA,DISEQ S DIPTR=+$P(@DIFRQ,"^",DIFRPCE),DIFLDDA=0,DIOUT=0 F S DIFLDDA=$O(^DD("KEY",DIKEY,2,DIFLDDA)) Q:'DIFLDDA S X=$G(^(DIFLDDA,0)) D Q:DIOUT . S DIFLD=$P(X,U),DISEQ=$P(X,U,3) I 'DISEQ S DIOUT=1 Q . I $P(X,U,2)'=DIFL S DIOUT=1 Q . I DIFLD=.01 S DIVAL=DIFRFRV . E S DIVAL=$$GET1^DIQ(DIFL,DIPTR_",",DIFLD,"","","DIER") . I $D(DIER) K DIER S DIOUT=1 Q . S @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE,DISEQ)=DIVAL . Q I DIOUT K @DIFRTA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE) Q ; DIERR I $G(DIERR) S DIFRERRC=$$ERRC($G(DIFRERRC),DIERR) K DIERR Q ; ERRC(X,Y) ; S X=$G(X),Y=$G(Y) S $P(X,"^")=+X+Y,$P(X,"^",2)=$P(X,"^",2)+$P(Y,"^",2) Q X ; ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y D BLD^DIALOG(Y) Q ;;FIA Node Is Set To "No Data";1;9509 ;;FIA Array Does Not Exist;2;9501 ;;;3; ;;Records Do Not Exist;4;9510 ;;FIA File Number Invalid;5;9502 DIFROMS4 DIFROMS4 ;SFISC/DCL- DATA FROM DISTRIBUTION ARRAY ;5/24/00 15:22 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q EN ; I '$D(@DIFRFIA) D ERR(2) Q ;N DIFRFILP S DIFRFILP=$D(DIFRFILP)#2 N %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU N DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z G:$G(DIFRFILE) FILE S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE Q FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(5) Q ; * * * PHASING OUT * * * FILE N DIFRDA,DIFRND0,DIFROOT,DIFR01,DIFR02,DIFRRLR,DIFRFRV N DIFRDKP,DIFRDKPD,DIFRDKPR,DIFRDKPS D KILL I '$D(@DIFRFIA) D ERR(2) Q I $G(@DIFRFIA@(DIFRFILE,DIFRFILE)) D Q .N DIFRERR S DIFRERR(1)=DIFRFILE .D BLD^DIALOG(9515,.DIFRERR) .Q S DIFROOT=@DIFRFIA@(DIFRFILE,0),DIFRDA=0 S DIFR01=@DIFRFIA@(DIFRFILE,0,1),DIFR02=$G(^(2)) I $P(DIFR02,"^",8)="" S $P(DIFR02,"^",8)=$$TL^DIFROMSP(DIFRFILE,"",DIFRSA) S DIFRRLR=$G(@DIFRFIA@(DIFRFILE,0,"RLRI")) ; * * * phasing out * * * S:DIFRRLR="" DIFRRLR=$NA(@DIFRSA@("DATA",DIFRFILE)) I $D(@DIFRRLR)'>9 D ERR(4) Q ; ; Recover from a failure in Replace Mode RE-INSTALL on target system I $D(@DIFRSA@("TMP")) D K @DIFRSA@("TMP") .S (D,DDF(1),DDT(0))=DIFRFILE .S DTO=0,DMRG=1,DTO(0)=DIFROOT,DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1) .S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0," .S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0)) S Z=^(0) .D I^DITR,REINDEX .D KILL Q ; F S DIFRDA=$O(@DIFRRLR@(DIFRDA)) Q:DIFRDA'>0 D .S (D,DDF(1),DDT(0))=DIFRFILE .S DTO=0,DMRG=1,DTO(0)=DIFROOT .S DFR(1)=$$OREF^DILF($NA(@DIFRSA@("DATA")))_"DDF(1),D0," .S DKP=$S($TR($P(DIFR01,"^",8),"O","o")="o":0,1:1) .S (DIFRDKPD,DIFRDKPR)=$S($TR($P(DIFR01,"^",8),"R","r")="r":1,1:0) .S (DIFRND0,DIFRDKP)=0 .S:+DIFR02 (DIFRDKPD,DIFRDKPR)=0 ;if file is new Replace not needed .S DIFRDKPS=$P(DIFR02,"^",8) ;save local data .S DIFRFRV=$TR($P(DIFR01,"^",5),"Y","y")="y" .S D0=DIFRDA,Z=@DIFRSA@("DATA",DIFRFILE,DIFRDA,0) .K @DIFRSA@("TMP") .D I^DITR,REINDEX .; If no data in local fields, quit. .I $D(@DIFRSA@("TMP"))'>9 D KILL Q .; restore data in local fields from old entry .S DIFRDKP=1,DIFRFRV=0 .K DFR,DA,D0 .;S DFR(1)="^TMP(""DIFRDKPD"",$J,DIFRFILE,D0," .S DFR(1)=$$OREF^DILF(DIFRSA)_"""TMP"",DIFRFILE,D0," .S D0=$O(@DIFRSA@("TMP",DIFRFILE,0)) Q:'$D(^(D0,0)) S Z=^(0) .D I^DITR,REINDEX,KILL .Q K @DIFRSA@("TMP") ; DO A CHECK HERE LIKE Q:'$D(DIFQ) LATER ON Q ; KILL K %,%H,A,B,D,D0,D1,DA,DDF,DDT,DFL,DFN,DFR,DIC,DIFL,DIIX,DIK,DINUM,DIU K DKP,DMRG,DTL,DTN,DTO,I,V,W,X,Y,Z Q ; REINDEX ; REINDEX ENTRY Q:DIFRND0'>0 N DIK,DA S DA=DIFRND0,DIK=DIFROOT,DIK(0)="AB" D IX1^DIK Q ; ERR(X) N Y S Y=$P($T(ERR+X),";",5) Q:'Y D BLD^DIALOG(Y) Q ;;FIA Node Is Set To "No Data";1;9509 ;;FIA Array Does Not Exist;2;9501 ;;;3; ;;Records Do Not Exist;4;9510 ;;FIA File Number Invalid;5;9502 ;;Partial DD. No sending of data allowed for file |1|;1;9515 DIFROMS5 DIFROMS5 ;SCISC/DCL-DIFROM SERVER PROCESS TEMPLATES OUT ;5APR2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q ; EDEOUT ;EXTENDED DATABASE ELEMENTS OUT N DIFRDSV,DIFRF,DIFRGBL,DIFRSEC,DIFRTRT I $G(DIFRIEN)>0 G EDE N DIFRIENX,DIFRIENZ S DIFRIENX=$O(@DIFRLST@(0)),DIFRIENZ=$D(@DIFRLST@(DIFRIENX,0))#2,DIFRIENX=0 F S DIFRIENX=$O(@DIFRLST@(DIFRIENX)) Q:DIFRIENX'>0 D .I DIFRIENZ S DIFRIEN=+@DIFRLST@(DIFRIENX,0) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q .S DIFRIEN=+@DIFRLST@(DIFRIENX) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q Q EDE ; ; DIFRTRT=FULL ROOT IN DIST ARRAY ; DIFRDSV=0TH NODE OF TEMPLATE ; :.401, .4, .402 ; :TEMPL NAME^DATE CREATED^READ^FILENR^DUZ^WRITE^DATE LAST USED ; :.403 ; :FORM NAME^READ^WRITE^DUZ^DATE CREATED^DATA LAST USED^^FILE^ ; :.84 ; :DIALOG NUMBER^TYPE^INTERNAL PARM^PACKAGE FILE (pointer) ; DIFRSEC=FILE SECURITY 1=EXPORT SECURITY,0=NO FILE SECURITY ; DIFRIEN=TEMPLATE'S INTERNAL ENTRY NUMBER ; :.5 (FUNCTIONS) S DIFRTRT=$NA(@DIFRTA@(DIFRFILE,DIFRIEN)) S DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1) ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ; ; For stand alone FileMan only - KIDS will do the Merge ; v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v v ; I $G(DIFRSTNA) S DIFRGBL=$$ROOT^DILFD(DIFRFILE,"",1) M @DIFRTRT=@DIFRGBL@(DIFRIEN) ; ; ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - I DIFRFILE=.5 Q ;no processing necessary S DIFRDSV=$G(@DIFRTRT@(0)),DIFRF=$P(DIFRDSV,U,$S(DIFRFILE=.403:8,1:4)) I DIFRDSV="" D Q .N DIFRERR S DIFRERR(1)=DIFRFNAM,DIFRERR(2)=DIFRIEN .D BLD^DIALOG(9516,.DIFRERR) .Q I DIFRFILE=.84 G DIALOG S DIFRSEC=DIFRFLG'["S" I DIFRFILE=.403 G T403 Q:'$D(@DIFRTRT@(0)) K ^("RD"),^("AB") K:DIFRFILE=.401 ^(1) S $P(@DIFRTRT@(0),U,5)="" S:'DIFRSEC ^(0)=$P(DIFRDSV,U,1,2)_U_U_DIFRF_U_U_U_U_$P(DIFRDSV,U,8,9) Q ; T403 ;PROCESS FORMS AND EACH BLOCK IT CONTAINES S $P(DIFRDSV,U,4)="",$P(DIFRDSV,U,6)="" S:'DIFRSEC $P(DIFRDSV,U,2,3)=U S @DIFRTRT@(0)=DIFRDSV D T404 K @DIFRTRT@("AY"),@DIFRTRT@(40,"B"),^("C") N X S X=0 F S X=$O(@DIFRTRT@(40,X)) Q:X'>0 K @DIFRTRT@(40,X,40,"AC"),^("B") Q ; T404 ;PROCESS BLOCKS ; :.404 ; :BLOCK NAME^ N DIFR1,DIFR2,D1,D2 S D1=0 F S D1=$O(@DIFRTRT@(40,D1)) Q:'D1 I $D(^(D1,0)) S DIFR1=+$P(^(0),U,2) D .I $D(^DIST(.404,DIFR1,0)) D ..S $P(@DIFRTRT@(40,D1,0),U,2)=$P(^DIST(.404,DIFR1,0),U) ;SEND PAGE'S HEADER BLOCK NAME, instead of NUMBER POINTER ..M @DIFRTA@(.404,DIFR1)=^DIST(.404,DIFR1) ..K @DIFRTA@(.404,DIFR1,40,"B"),^("C"),^("D") ..Q .S D2=0 .F S D2=$O(@DIFRTRT@(40,D1,40,D2)) Q:'D2 I $D(^(D2,0)) S DIFR2=+^(0) D ..I $D(^DIST(.404,DIFR2)) D ...S $P(@DIFRTRT@(40,D1,40,D2,0),U)=$P(^DIST(.404,DIFR2,0),U) ;SEND THE BLOCK NAME, instead of NUMBER POINTER ...M @DIFRTA@(.404,DIFR2)=^DIST(.404,DIFR2) ...K @DIFRTA@(.404,DIFR2,40,"B"),^("C"),^("D") ...Q ..Q .Q Q ; DIALOG ; Q:'$D(@DIFRTRT@(0)) K ^(3,"B") K @DIFRTRT@(4,"B") ;GFT -- USED TO KILL ^(4) SO TRANSLATIONS WOULD NOT BE TRANSPORTED! Q:$G(DIFRF)'>0 S:DIFRF DIFRF=$P($G(^DIC(9.4,DIFRF,0)),"^"),$P(@DIFRTRT@(0),"^",4)=DIFRF Q DIFROMS6 DIFROMS6 ;SCISC/DCL-DIFROM SERVER PROCESS TEMPLATES IN;03:07 PM 25 Mar 1994; ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q ; EDEIN ;EXTENDED DATABASE ELEMENTS IN N DIFRDSV,DIFRF,DIFRGBL,DIFRSEC,DIFRTRT I $G(DIFRIEN)>0 G EDE N DIFRIENX,DIFRIENZ S DIFRIENX=$O(@DIFRLST@(0)),DIFRIENZ=$D(@DIFRLST@(DIFRIENX,0))#2,DIFRIENX=0 F S DIFRIENX=$O(@DIFRLST@(DIFRIENX)) Q:DIFRIENX'>0 D .I DIFRIENZ S DIFRIEN=+@DIFRLST@(DIFRIENX,0) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q .S DIFRIEN=+@DIFRLST@(DIFRIENX) S:DIFRIEN'>0 DIFRIEN=DIFRIENX D EDE Q Q EDE ; ; DIFRTRT=FULL ROOT IN DIST ARRAY ; DIFRDSV=0TH NODE OF TEMPLATE ; :.401, .4, .402 ; :TEMPL NAME^DATE CREATED^READ^FILENR^DUZ^WRITE^DATE LAST USED ; :.403 ; :FORM NAME^READ^WRITE^DUZ^DATE CREATED^DATA LAST USED^^FILE^ ; DIFRSEC=FILE SECURITY 1=EXPORT SECURITY,0=NO FILE SECURITY ; DIFRIEN=TEMPLATE'S INTERNAL ENTRY NUMBER ; :.5 (FUNCTIONS) S DIFRTRT=$NA(@DIFRTA@(DIFRFILE,DIFRIEN)) ; ERR(X,Y) ; S X(1)=X D BLD^DIALOG(Y,.X) Q DIFROMSB DIFROMSB ;SCISC/DCL-SILENT DIFROM/INSTALL BLOCKS ;08:35 AM 22 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q BLKSIN(DIFRNAME,DIFRFLG,DIFRSA,DIFRMSGR) ; ;PACKAGE_NAME,FLAGS,SOURCE_ROOT,MSG_ROOT ;* ;PACKAGE_NAME=Package Name ; (Required if Source Root is not passed) - Identifies the ; unique key subscript in the transport structure. ;* ;FLAGS=O ; (Optional) - "O"=use Old calls (DIC) ;* ;SOURCE_ROOT=Source Array Root ; (Optional) - Closed array reference which contain all the ; Blocks that are to be installed. ; (Note) - Required if Package_Name is not passed. ;* ;MSG_ROOT=Closed Root for Error Messages ; (Optional) - Array where messages such as errors will be ; returned. If not passed, decendents of the ^TMP ; will be used. ;* I $G(DIFRNAME)=""&($G(DIFRSA))="" D ERR("PACKAGE NAME/SOUCE ROOT") Q N DIFRFILE,DIFRDA,DIFROLD,DIFRX,DIFRY,DIC,DA,DLAYGO,X,Y S DIFRFILE=.404,DIFRDA=0 I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN")) S DIFROLD=$G(DIFRFLG)["O" I DIFROLD S DLAYGO=DIFRFILE,DIC="^DIST(.404,",DIC(0)="LX" D Q .F S DIFRDA=$O(@DIFRSA@(.404,DIFRDA)) Q:DIFRDA'>0 S DIFRX=^(DIFRDA,0) D ..S X=$P(DIFRX,"^"),DIFRFL=$P(DIFRX,"^",2) ..K DA ..D ^DIC ..I Y>0 S DIFRY=Y D DELADD Q ..N DIFRERR S DIFRERR(1)=$P(DIFRX,"^") ..D BLD^DIALOG(9517,.DIFRERR) ..Q ; CODE FOR NEW CALLS <<<*** G EXIT Q DELADD ; K ^DIST(.404,+DIFRY),DA,DIK M ^DIST(.404,+DIFRY)=@DIFRSA@(.404,DIFRDA) S DIK="^DIST(.404,",DA=+DIFRY D IX1^DIK I '$D(DD(+DIFRFL)) D .N DIFRERR S DIFRERR(1)=$P(DIFRX,"^"),DIFRERR(2)=DIFRFL .D BLD^DIALOG(9518,.DIFRERR) .Q Q ; ERR(X) S X(1)=X D BLD^DIALOG(202,.X) Q EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q DIFROMSC DIFROMSC ;SCISC/DCL-EDE IN CONTINUE FPRE & FPOST ;08:38 AM 22 Nov 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FPRE ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW N DIOVRD S DIOVRD=1 S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL) I DIFRFILE'>0 D BLD^DIALOG(9519) Q Q:DIFRFILE'=.403 I $G(DIFRNAME)="" D BLD^DIALOG(9520) Q I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN")) I DIFRFILE=.403 D Q .N DIC,DIK,DIFRR,DIFRFILE,DIFRL,DIFRX,X,Y .S DIC="^DIST(.404,",DIC(0)="LX",DLAYGO=.404,DIFRFILE=.404 .S DIFRR=0 .F S DIFRR=$O(@DIFRSA@(DIFRFILE,DIFRR)) Q:DIFRR'>0 S DIFRX=^(DIFRR,0) D ..S DIFRL=$P(DIFRX,"^",2) ..S X=$P(DIFRX,"^") ..K DA ..D ^DIC ..I Y'>0 D Q ...N DIFRERR S DIFRERR(1)=$P(DIFRX,"^") ...D BLD^DIALOG(9517,.DIFRERR) ...Q ..K ^DIST(.404,+Y) ..I '$D(^DD(+DIFRL)) D ...N DIFRERR S DIFRERR(1)=$P(DIFRX,"^"),DIFRERR(2)=DIFRL ...D BLD^DIALOG(9518,.DIFRERR) ...Q ..M ^DIST(.404,+Y)=@DIFRSA@(DIFRFILE,DIFRR) ..S DIK=DIC,DA=+Y ..D IX1^DIK ..Q .Q Q FPOST ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW N DIOVRD S DIOVRD=1 Q EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q DIFROMSD DIFROMSD ;SFISC/DCL-DIFROM SERVER DD LIST(KIDS/BUILD FILE) ;16JAN2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; DD(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS ;FILE, FLAGS, TARGET ARRAY ;FILE = File number ;FLAG = "W" Include Word Processing DD numbers ;DIFRTA = Target Array in closed array root format where informaiton ; is returned. ; Returns a list of sub DD numbers. A flag allows wp DD ; numbers to also be returned. N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX S DIFRFW=$G(DIFRFLG)'["W" F S @DIFRTA@(DIFRFILE,DIFRFILE)=$O(^DD(DIFRFILE,0,"NM",""))_" "_$S($D(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)"),DIFRFE=0 E F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D .S DIFRFD=0 .F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 D ..I DIFRFW,$P($G(^DD(DIFRFD,.01,0)),"^",2)["W" Q ..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=$O(^DD(DIFRFD,0,"NM",""))_" (sub-file)" ..Q .Q Q ; DDIOLDD(DIFRFILE,DIFRFLG) ; ;FILE,FLAGS ;FILE = File number ;FLAGS = None ; Returns a list of all the valid DD numbers within a file ; via a call to DDIOL. N I,X,Y K ^TMP("DIFROMSP",$J) D DD(DIFRFILE,"","^TMP(""DIFROMSP"",$J)") S (I,X)=0 F S I=$O(^TMP("DIFROMSP",$J,DIFRFILE,I)) Q:I'>0 S Y=^(I),X=X+1,^TMP("DIFROMSP",$J,"DDIOL",X,0)=I_$J("",(20-$L(I)))_Y D EN^DDIOL("","^TMP(""DIFROMSP"",$J,""DDIOL"")") K ^TMP("DIFROMSP",$J) Q ; CHKDD(DIFRFILE,DIFRDD,DIFRFLG) ; $$ EXTRINSIC FUNCTION $$ ;Extrinsic; Pass file and DD numbers returns 1 if OK ; and 0 if not DD not part of File ;FILE,DD# ;FILE = File number ;DD# = File or sub-file number. ; Used to determine if ; the value in DD# is valid for FILE. ;FLAGS = "N"umber_"^"_"N"ame of field returned ; Default returns a 1 (true) or 0 (false). Q:$G(DIFRDD)="" 0 Q:$G(DIFRFILE)="" 0 N DIFRARAY,N S N=$G(DIFRFLG)["N" D DD(DIFRFILE,"","DIFRARAY") I $D(DIFRARAY(DIFRFILE,DIFRDD)) Q:N DIFRDD_"^"_DIFRARAY(DIFRFILE,DIFRDD) Q 1 Q 0 ; DDIOLFLD(DIFRDD,DIFRFLG) ; ;FILE/SUB_FILE,FLAGS ;FILE = File or sub-file number ;FLAGS = "M"ultiple fields excluded ; "W"ord processing fields excluded ; Returns a list of valid field numbers within a file or ; sub-file via a call to DDIOL. N I,M,W,X,Y,Z S M=$G(DIFRFLG)["M",W=$G(DIFRFLG)["W" K ^TMP("DIFROMSP",$J) S (I,X)=0 F S X=$O(^DD(DIFRDD,X)) Q:X'>0 S Y=$G(^(X,0)) D .I $P(Y,"^",2) D Q:Y="" ..S Z=$P(^DD(+$P(Y,"^",2),.01,0),"^",2) ..I M,Z'["W" S Y="" Q ..I W,Z["W" S Y="" Q ..S $P(Y,"^")=$P(Y,"^")_$S(Z["W":" (word-processing)",1:" (multiple)") ..Q .S I=I+1,^TMP("DIFROMSP",$J,I,0)=X_$J("",(12-$L(X)))_$P(Y,"^") D EN^DDIOL("","^TMP(""DIFROMSP"",$J)") K ^TMP("DIFROMSP",$J) Q ; FLDCHK(DIFRDD,DIFRFLD,DIFRFLG) ; $$ EXTRINSIC FUNCTION $$ ;Check if field exist; return 1/FIELD#_NAME, true, or 0, false. ;FILE/SUB_FILE,FIELD,FLAGS ;FILE/SUB_FILE = File or sub-file number ;FIELD = Field number ; If FIELD is valid, returns 1; Otherwise 0 is returned. ;FLAGS = "M"ultiple fields excluded ; "W"ord processing fields excluded ; "N"umber_"^"_"N"ame of field returned. ; Default is to return 1 or 0. ; Q:$G(DIFRDD)="" 0 Q:$G(DIFRFLD)="" 0 N M,N,W,Z S M=$G(DIFRFLG)["M",W=$G(DIFRFLG)["W",N=$G(DIFRFLG)["N" I $P($G(^DD(DIFRDD,DIFRFLD,0)),"^",2) S Z=$P(^DD(+$P(^(0),"^",2),.01,0),"^",2) D Q:N $S(Z:DIFRFLD_"^"_$P(^DD(DIFRDD,DIFRFLD,0),"^"),1:Z) Q Z .I M,Z'["W" S Z=0 Q .I W,Z["W" S Z=0 Q .S Z=1 .Q I $D(^DD(DIFRDD,DIFRFLD,0))#2 Q:N DIFRFLD_"^"_$P(^(0),"^") Q 1 Q 0 DIFROMSE DIFROMSE ;SFISC/DCL-FILE ORDER TO RESOLVE POINTERS ;07:27 AM 2 Jun 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q ;File Order List for Resolving Pointers FOLRP(DIFRFLG,DIFRTA) ;FLAGS,TARGET_ARRAY ; Creates the "DIORD" subscript ; structure in the transport array. ;FLAGS,TARGET_ARRAY ;* ;FLAGS = None ;* ;TARGET_ARRAY = CLOSED ROOT ; This is the Transport Array Root. ; "DIORD" is appended to the array root. ; A ordered list of files is returned ; in the target array. Each file is given ; a value to determine which file should have ; pointers resolved. After each file has been ; assigned a value it is ordered by value then ; by file number. If files have the same value ; the file number is then used to determine the ; order. This call is used after all the file ; being transported are in the "FIA" structure. ;* Q:$G(DIFRTA)']"" N DIFRCNT,DIFRDD,DIFRF,DIFRFILE,DIFRFLD,DIFRX S DIFRFILE=0 K ^TMP("DIFROMSE",$J),^TMP("DIFRORD",$J),^TMP("DIFRFILE",$J),@DIFRTA@("DIORD") F S DIFRFILE=$O(@DIFRTA@("FIA",DIFRFILE)) Q:DIFRFILE'>0 D .D FSF^DIFROMSP(DIFRFILE,"","^TMP(""DIFROMSE"",$J)") .Q S DIFRFILE=0 F S DIFRFILE=$O(^TMP("DIFROMSE",$J,DIFRFILE)) Q:DIFRFILE'>0 D .S DIFRDD=0,^TMP("DIFRORD",$J,DIFRFILE)=0 .F S DIFRDD=$O(^TMP("DIFROMSE",$J,DIFRFILE,DIFRDD)) Q:DIFRDD'>0 D ..S DIFRFLD=0 ..F S DIFRFLD=$O(^DD(DIFRDD,DIFRFLD)) Q:DIFRFLD'>0 S DIFRX=$G(^(DIFRFLD,0)) D ...Q:$P(DIFRX,"^",2) ...Q:$P(DIFRX,"^",2)'["P"&($P(DIFRX,"^")'["V") ...S DIFRCNT=0 ...I $P(DIFRX,"^",2)["V" D G P ....S DIFRF=0 F S DIFRF=$O(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF)) Q:DIFRF'>0 S ^TMP("DIFRFILE",$J,DIFRF)=DIFRCNT+1 ....Q ...I +$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2)=DIFRFILE S:$G(^TMP("DIFRORD",$J,DIFRFILE))'>DIFRCNT ^(DIFRFILE)=DIFRCNT Q ...I $P(DIFRX,"^",2)["P" S ^TMP("DIFRFILE",$J,+$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1 P ...S DIFRF=$O(^TMP("DIFRFILE",$J,"")) Q:DIFRF="" S DIFRCNT=^(DIFRF) K ^(DIFRF) ...I $G(^TMP("DIFRORD",$J,DIFRF))'>DIFRCNT S ^(DIFRF)=DIFRCNT ...S DIFRX=^DD(DIFRF,.01,0) ...I $P(DIFRX,"^",2)["P" S ^TMP("DIFRFILE",$J,+$P(@("^"_$P(DIFRX,"^",3)_"0)"),"^",2))=DIFRCNT+1 G P ...G:$P(DIFRX,"^",2)'["V" P ...S DIFRF=0 F S DIFRF=$O(^DD(DIFRDD,DIFRFLD,"V","B",DIFRF)) Q:DIFRF'>0 S ^TMP("DIFRFILE",$J,DIFRF)=DIFRCNT ...S DIFRCNT=DIFRCNT+1 ...G P ...Q ..Q .Q S DIFRFILE=0 F S DIFRFILE=$O(^TMP("DIFRORD",$J,DIFRFILE)) Q:DIFRFILE'>0 S DIFRX=^(DIFRFILE),^TMP("DIFRORD",$J,"DIORD",DIFRX,DIFRFILE)="" S DIFRX="",DIFRCNT=1 F S DIFRX=$O(^TMP("DIFRORD",$J,"DIORD",DIFRX),-1) Q:DIFRX="" D .S DIFRFILE=0 F S DIFRFILE=$O(^TMP("DIFRORD",$J,"DIORD",DIFRX,DIFRFILE)) Q:DIFRFILE'>0 D ..S @DIFRTA@("DIORD",DIFRCNT)=DIFRFILE,DIFRCNT=DIFRCNT+1 D KILL Q KILL ; K ^TMP("DIFROMSE",$J),^TMP("DIFRORD",$J),^TMP("DIFRFILE",$J) Q ; CHK(DIFRFLG,DIFRSA,DIFRTA) ;CHECK FILES POINTED TO AGAINST FILES GOING OUT WITH DATA ;Compares the "DIORD" with the "FIA" structures ;FLAGS,SOURCE_ARRAY,TARGET_ARRAY ;* ;FLAGS = None ;* ;SOURCE_ARRAY = TRANSPORT ARRAY ROOT ;* ;TARGET_ARRAY = TARGET ARRAY ROOT ; Returns a list of files that are pointed to ; but not being exported. This is used after ; all the files being exported are in the "FIA" ; structure. ;* Q:$G(DIFRSA)']"" Q:$G(DIFRTA)']"" N DIFRX,DIFRFILE S DIFRX=0 F S DIFRX=$O(@DIFRSA@("DIORD",DIFRX)) Q:DIFRX'>0 S DIFRFILE=^(DIFRX) D .Q:$D(@DIFRSA@("DATA",DIFRFILE))&($P($G(@DIFRSA@("FIA",DIFRFILE,0,1)),"^",5)="y") .S @DIFRTA@(DIFRFILE)="" .Q Q DIFROMSF DIFROMSF ;SCISC/DCL-SILENT DIFROM EXTENDED DATABASE FILES;08:41 AM 22 Nov 1994; ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q ; ; * EXTENDED DATABASE ELEMENTS (EDE) * EDEOUT(DIFRIEN,DIFRNAME,DIFRFLG,DIFRFIA,DIFRTA,DIFRLST,DIFRMSGR) ; ;ENTRY,PKGNAME,FLAGS,FIA_ARRAY,TARGET_ARRAY,LIST_ARRAY,MSG_ROOT I $G(DIFRNAME)']"" D ERR("PACKAGE NAME") Q N DIFRFILE S DIFRFILE=$S(DIFRFLG="F":.403,DIFRFLG="I":.402,DIFRFLG="P":.4,DIFRFLG="S":.401,DIFRFLG="$":.5,1:"") I DIFRFILE'>0 D ERR("FLAG") Q I $G(DIFRTA)="" S DIFRTA=$NA(^XTMP("XPDT",DIFRNAME,"KRN")) ; ; >*>*>*> c h e c k h e r e <*<*<*< ; S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRTA@("FIA")) I $G(DIFRIEN)'>0&($G(DIFRLST)="") D ERR("NO IENs PASSED") Q I $G(DIFRIEN)'>0,$D(@DIFRLST)'>9 D ERR("LIST DOES NOT CONTAIN IENs") Q D EDEOUT^DIFROMS5 G EXIT ; EDEIN ; * EXTENDED DATABASE ELEMENTS * Q FPRE(DIFRFILE,DIFRNAME,DIFRSA) ; FILE-PRE K ^TMP("DIFROMS",$J) ;FILENUMBER,SUBSCRIPT_NAME(package name for KIDS),SOURCE_ARRAY S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL) I DIFRFILE'>0 D ERR("FILE NUMBER") Q Q:DIFRFILE'=.403 I $G(DIFRNAME)="" D ERR("SUBSCRIPT NAME") Q I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN")) I DIFRFILE=.403 D Q ;If Forms bring in Blocks .N DIC,DIFRR,DIFRFILE,DIFRL,DIFRX,X,Y .S DIC="^DIST(.404,",DIC(0)="LX",DLAYGO=.404,DIFRFILE=.404 .S DIFRR=0 .F S DIFRR=$O(@DIFRSA@(DIFRFILE,DIFRR)) Q:DIFRR'>0 S DIFRX=^(DIFRR,0) D ..S DIFRL=$P(DIFRX,"^",2) ..S X=$P(DIFRX,"^") ..K DA ..D ^DIC ..I Y'>0 D ERR("UNABLE TO ADD "_$P(DIFRX,"^")_" BLOCK") Q ..K ^DIST(.404,+Y) ..I '$D(^DD(+DIFRL)) D ERR("BLOCK: "_$P(DIFRX,"^")_" installed but associated file "_DIFRL_" missing") ..M ^DIST(.404,+Y)=@DIFRSA@(DIFRFILE,DIFRR) ..S DIK=DIC,DA=+Y ..D IX1^DIK ..Q .Q Q ; EPRE(DIFRFILE,DIFRIEN,DIFROIEN,DIFRNAME,DIFRSA) ; ENTRY-PRE ;FILENUM,NEW_ENTRY_NUM,OLD_ENTRY_NUM,PKG/SUBSCRIPT_NAME,SOURCE_ARRAY ; Entry Pre - delete template on target system N DIFRRDA,DIFRX,DIFRF S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL) I DIFRFILE'>0 D ERR("FILE NUMBER") Q S DIFRIEN=$G(DIFRIEN) S:DIFRIEN'>0 DIFRIEN=$G(DA) I DIFRIEN'>0 D ERR("ENTRY NUMBER") Q S DIFROIEN=$G(DIFROIEN) S:DIFROIEN'>0 DIFROIEN=$G(OLDA) I DIFRIEN'>0 D ERR("OLD ENTRY NUMBER") Q I $G(DIFRNAME)="" D ERR("PACKAGE/SUBSCRIPT NAME MISSING") Q ;GET VARIABLE FROM RON I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDT",DIFRNAME,"KRN")) ; build file root with entry number and kill entry on target system S DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN) S DIFRX=$P(@DIFRRDA@(0),"^") S DIFRF=$S(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",DIFRFILE=.401:"DIBT",DIFRFILE=.403:"DIST(.403,",DIFRFILE=.404:"DIST(.404,",1:"FUN") S ^TMP("DIFROMS",$J,DIFRF,DIFRX)=DIFRIEN K @DIFRRDA I DIFRFILE=.403 D ;If Forms resolve Block Pointers .N DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY .S DIFRJ=0 .F S DIFRJ=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ)) Q:'DIFRJ I $D(^(DIFRJ,0)) S DIFRP=$P(^(0),"^",2) D ..S:DIFRP]"" DIFRP=$O(^DIST(.404,"B",DIFRP,0)) ..S:DIFRP $P(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP ..S DIFRL=0 ..F S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL)) Q:'DIFRL S DIFRA0=$G(^(DIFRL,0)),DIFRP=$P(DIFRA0,"^") I DIFRP]"" D ...S DIFRP=$O(^DIST(.404,"B",DIFRP,0)) I DIFRP D ....S $P(DIFRA0,"^")=DIFRP,@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0 ....Q ...Q ..S DIFRA0=$G(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)) ..Q:DIFRA0="" ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40) ..S (DIFRA1,DIFRA2)=0 ..S DIFRL=0 ..F S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL)) Q:'DIFRL S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,0)=^(DIFRL,0),DIFRA1=DIFRL,DIFRA2=DIFRA2+1 ..S $P(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2 ..S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0 ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK") ..Q .Q Q EPOST ; ENTRY-POST Q FPOST ; FILE-POST RECOMPILE TEMPLATES N DIFR,DIFR1,DIFR2,DMAX,X,Y K DIC,DLAYGO F DIFR="DIE","DIPT" D .I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII .E S DISYS=^DD("OS") .Q:'$D(^DD("OS",DISYS,"ZS")) .S DIFR1="" DZ1 .S DIFR1=$O(^TMP("DIFROMS",$J,DIFR,DIFR1)) Q:DIFR1="" .F DIFR2=0:0 S DIFR2=$O(^TMP("DIFROMS",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 D ..S Y=DIFR2 ..I $D(@("^"_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD") D ...S DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z") ...Q ..Q .G DZ1 K ^TMP("DIFROMS",$J) Q INITCHK ; check ; ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW Q ; ERR(X) S X(1)=X D BLD^DIALOG(1700,.X) EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q DIFROMSI DIFROMSI ;SCISC/DCL-EDE IN ;3:19 PM 16 Nov 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FPRE(DIFRFILE,DIFRFLG,DIFRNAME,DIFRSA) ; G FPRE^DIFROMSC EPRE(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA,DIFROIEN) ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW N DIOVRD S DIOVRD=1 N DIFRRDA,DIFRX S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL) I DIFRFILE'>0 D BLD^DIALOG(9521) Q S DIFRIEN=$G(DIFRIEN) S:DIFRIEN'>0 DIFRIEN=$G(DA) I DIFRIEN'>0 D BLD^DIALOG(9522) Q S DIFROIEN=$G(DIFROIEN) S:DIFROIEN'>0 DIFROIEN=$G(OLDA) I DIFROIEN'>0 D BLD^DIALOG(9523) Q I $G(DIFRNAME)="" D BLD^DIALOG(9524) Q I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN")) S DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN) S DIFRX=$P(@DIFRRDA@(0),"^") G:DIFRFILE=.84 DIALOG ; ; preserve security codes if template/form is not new I $G(DIFRFLG)'["N",DIFRFILE'=.5 D .N X,Y .S Y=@DIFRRDA@(0) .S X=@DIFRSA@(DIFRFILE,DIFROIEN,0),$P(X,U,3)=$P(Y,U,3),$P(X,U,6)=$P(Y,U,6),^(0)=X .Q ; I DIFRFILE'=.403 K @DIFRRDA E D .Q:$G(DIFRFLG)["N" .N DA,DIC,DIK,DINUM,X,Y,DO .S DIK="^DIST(.403,",DA=DIFRIEN .D ^DIK .S DIC="^DIST(.403,",DIC(0)="LX",X=DIFRX,DINUM=DIFRIEN .D FILE^DICN .Q I DIFRFILE=.403 D .N DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY .S DIFRJ=0 .F S DIFRJ=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ)) Q:'DIFRJ I $D(^(DIFRJ,0)) S DIFRP=$P(^(0),"^",2) D ..S:DIFRP]"" DIFRP=$O(^DIST(.404,"B",DIFRP,0)) ..S:DIFRP $P(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP ..S DIFRL=0 ..F S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL)) Q:'DIFRL S DIFRA0=$G(^(DIFRL,0)),DIFRP=$P(DIFRA0,"^") I DIFRP]"" D ...S DIFRP=$O(^DIST(.404,"B",DIFRP,0)) I DIFRP D ....S $P(DIFRA0,"^")=DIFRP,@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0 ....N DIFRX ....S DIFRX=0 ....F S DIFRX=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX)) Q:DIFRX="" S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,DIFRX)=^(DIFRX) ....Q ...Q ..S DIFRA0=$G(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)) ..Q:DIFRA0="" ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40) ..S (DIFRA1,DIFRA2)=0 ..S DIFRL=0 ..F S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL)) Q:'DIFRL S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,0)=^(DIFRL,0),DIFRA1=DIFRL,DIFRA2=DIFRA2+1 D ...N DIFRX ...S DIFRX=0 ...F S DIFRX=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL,DIFRX)) Q:DIFRX="" S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX)=^(DIFRX) ...Q ..S $P(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2 ..S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0 ..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK") ..Q .Q Q DIALOG N DIFRF,DIFRX S DIFRF=$P(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4) I DIFRF]"" D .S DIFRF=$O(^DIC(9.4,"B",DIFRF,0)) I DIFRF,$O(^(DIFRF)) D S DIFRF="" ..N DIFRERR S DIFRERR(1)=DIFRF,DIFRERR(2)=DIFRIEN ..D BLD^DIALOG(9525,.DIFRERR) ..Q .S $P(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4)=DIFRF F DIFRX=1,2,3,5,6 K @DIFRRDA@(DIFRX) Q EPOST(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA) ; I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW N DIOVRD S DIOVRD=1 I '$G(DIFRFILE)!('$G(DIFRIEN)) Q I $G(DIFRNAME)="" Q S:$G(DIFRSA)']"" DIFRSA=$NA(^XTMP("XPDI",DIFRNAME)) N DA,DIFR,DIFR3,DIFROU,DIK,DMAX,DNM,X,Y,Z,DIFRTN S DIK=$$ROOT^DILFD(DIFRFILE),DA=DIFRIEN D IX1^DIK I DIFRFILE=.403,DIFRIEN D ENGRP^DDSZ(DIFRIEN) Q S DIFR=$S(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",1:"") Q:DIFR="" I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII E S DISYS=^DD("OS") I '$D(^DD("OS",DISYS,"ZS")) D BLD^DIALOG(9526) Q S Y=DIFRIEN I $D(@("^"_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S (DIFROU,X)=^("ROUOLD"),DIFRTN=$P(^(0),"^") D:X]"" .N %X,DIR,DMAX,X,Y,DIFRZTA .S DIFR3="DI"_$E(DIFR,3)_"Z" .I $$VAL^DIFROMSS(DIFRFILE,DIFRIEN) D Q ..D @("EN2^"_DIFR3_"(DIFRIEN,"""",DIFROU,"""",""DIFRZTA"")") ..I $D(DIFRZTA) M @DIFRSA@(DIFR3,DIFRIEN)=DIFRZTA ..S @DIFRSA@(DIFR3,DIFRIEN)=DIFROU ..Q .N DIFRTT,DIFRERR S DIFRTT=$S(DIFRFILE=.4:"PRINT",1:"INPUT") .S DIFRERR(1)=DIFRTT,DIFRERR(2)=DIFRTN .D BLD^DIALOG(9528,.DIFRERR) .Q Q FPOST ; G FPOST^DIFROMSC EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q DIFROMSK DIFROMSK ;SCISC/DCL-DIFROM SERVER DELETE PARTS ;9:27 AM 4 Jan 2007 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 1 ;Per VHA Directive 2004-038, this routine should not be modified. Q ; DEL(DIFRFILE,DIFRFLG,DIFRSA,DIFRMSGR) ;DELETE TEMPLATES ;FILE_NUMBER,FLAGS,SOURCE_ARRAY,MSG_ARRAY_ROOT ;* ;FILE_NUMBER = Template File Number ; ; (Required) - ; Forms .403 ^DIST(.403, "DIST(.403," ; Blocks .404 ^DIST(.404, "DIST(.404," ; Note: only Forms can be deleted in KIDS ; Input Template .402 ^DIE( "DIE" ; Print Template .4 ^DIPT( "DIPT" ; Sort Template .401 ^DIBT( "DIBT" ; Dialog .84 ^DI(.84, "DI(.84," ;* ;FLAGS = None at this time ;* ;SOURCE_ARRAY = Source Array where the list of internal ; entry numbers are passed (IEN/DA). ; Format is: ARRAY(DA)="" ; In this example "ARRAY" is passed. ;* ;MSG_ARRAY_ROOT = Array Root where the error message will be sent. ;* I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW D I '$G(DIFRFILE) D BLD^DIALOG(9529) Q .I $G(DIFRFILE)'>0 Q .I DIFRFILE=.4!(DIFRFILE=.401)!(DIFRFILE=.402)!(DIFRFILE=.403)!(DIFRFILE=.404)!(DIFRFILE=.84) Q ;22*128 .S DIFRFILE=0 .Q I $G(DIFRSA)']"" D BLD^DIALOG(9506) Q I '$D(@DIFRSA) D BLD^DIALOG(9506) Q N DIFRDA,DIFROOT,DIFRCR S DIFRDA=0,DIFROOT=$$ROOT^DILFD(DIFRFILE),DIFRCR=$$ROOT^DILFD(DIFRFILE,"",1) I DIFROOT']"" D BLD^DIALOG(9529) Q ;I $$NPT( F S DIFRDA=$O(@DIFRSA@(DIFRDA)) Q:DIFRDA'>0 D:$D(@DIFRCR@(DIFRDA,0)) .I DIFRFILE=.4!(DIFRFILE=.401)!(DIFRFILE=.402) D DT(DIFROOT,DIFRDA) Q .I DIFRFILE=.403 D DFB(DIFRDA) Q ;22*153 .404 to .403 .I DIFRFILE=.84,DIFRDA>10000 D DT(DIFROOT,DIFRDA) Q ;22*128 .Q Q ; DT(DIK,DA) ;Delete Template or Dialog ;22*128 N DIFRFILE,DIFRSA,DIFRFLG,DIFRMSGR,DIFRDA,DIFRCR,DIFROOT N %,A,B,D0,I,W,X,Y,Z S Y="" D ^DIK Q ; DFB(DA) ;Delete Forms(.403) and Blocks(.404), within the specified form. D EN^DDSDFRM(DA) Q ; EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q ; DIFROMSO DIFROMSO ;SCISC/DCL-DIFROM SERVER EDE OUT ;01:18 PM 8 Feb 1995 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q ; ; * EXTENDED DATABASE ELEMENTS (EDE) OUT * EDEOUT(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRFIA,DIFRTA,DIFRLST,DIFRMSGR) ; ;FILE,IEN,FLAGS,PKGNAME,FIA_ARRAY,TARGET_ARRAY,RECORD_LIST,MSG_ROOT ;FILE=FILE NUMBER can only be:.5,.4,.401,.402,.403 ; (.404 automatically comes with .403) ; (Required) - ; Forms .403 ^DIST(.403, "DIST(.403," ; Blocks .404 ^DIST(.404, "DIST(.404," ; Input Template .402 ^DIE( "DIE" ; Print Template .4 ^DIPT( "DIPT" ; Sort Template .401 ^DIBT( "DIBT" ; Functions .5 ^DD("FUNC", "FUN" ; Dialog .84 ^DI(.84, ???? ; ; Note: Blocks pointed to by Forms ; are automatically sent ;* ;IEN=INTERNAL ENTRY NUMBER - DA ; (Required if LIST_ARRAY is not passed) - Identifies ; the internal entry number for the ; EDE being exported. ;* ;FLAGS="S" Strip Security Codes in Transport Structure (Do not send security codes for Forms and Templates) ;* ;PKGNAME=Package Name ; (Required) - Identifies the unique key subscript ; in the export target array. ;* ;FIA_ARRAY="FIA"_ARRAY_INPUT_ARRAY_ROOT * *NO LONGER USED* * ; (Optional) - Close Input Array Reference ; See DIFROM SERVER documentation for FIA array structure ; definitions. If undefined Target Array Root will be used ; to append the "FIA" subscript Default will be ; ^XTMP("XPDT",DIFRNAME,"FIA") ;* ;TARGET_ARRAY=CLOSED_OUTPUT_ARRAY_ROOT ; (Optional) - Closed Output Array Reference where the data will ; be retuned to be temporarily stored for distribution. ; ^XTMP("XPDT",DIFRNAME,"KRN") will be default. ;* ;LIST_ARRAY=LIST OF IENs PASSED BY VALUE ; (Required if ENTRY not passed) - Closed Array ; Reference where records for this type of template ; exist. Nodes can contain ,0). If +value is greater ; than 0 it is used, otherwise the subscript is ; used as the IEN. ;* ;MSG_ROOT=CLOSED ARRAY REFERENCE ; (Optional) - Closed array reference where messages such as ; errors will be returned. If not passed, decendents of ^TMP ; will be used. ;* I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW I $G(DIFRNAME)']"" D BLD^DIALOG(9530) Q D .N X .S X=DIFRFILE .I X=.5!(X=.4)!(X=.401)!(X=.402)!(X=.403)!(X=.84) Q .S DIFRFILE=0 .Q I DIFRFILE'>0 D BLD^DIALOG(9531) Q I $G(DIFRTA)="" S DIFRTA=$NA(^XTMP("XPDT",DIFRNAME,"KRN")) ;* ; * *DIFRFIA NO LONGER USED* * ;S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(^XTMP("XPDT",DIFRNAME,"FIA")) ;I '$D(@DIFRFIA) D BLD^DIALOG(9501) Q ;* I $G(DIFRIEN)'>0&($G(DIFRLST)="") D BLD^DIALOG(9531) Q I $G(DIFRIEN)'>0,$D(@DIFRLST)'>9 D BLD^DIALOG(9532) Q S DIFRFLG=$G(DIFRFLG) N DIFRFNAM S DIFRFNAM=$P($P(".4;PRINT TEMPLATE^.401;SORT TEMPLATE^.402;INPUT TEMPLATE^.403;FORM^.404;BLOCK^.5;FUNCTION^.84;DIALOG",DIFRFILE_";",2),"^") D EDEOUT^DIFROMS5 G EXIT ; EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q DIFROMSP DIFROMSP ;SFISC/DCL-DIFROM SERVER POINTER LIST ;5/18/98 08:29 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; POINTERS(DIFRFILE,DIFRFLG,DIFRPTA) ;FILENUMBER, POINTER X-REF TARGET ARRAY ROOT ;FILE, FLAGS, TARGET ARRAY S DIFRFLG=$G(DIFRFLG) N DIFRDDNS,DIFRALL S DIFRALL=DIFRFLG["A" D FP(DIFRFILE,"","DIFRDDNS") ;ALL DD#s FOR FILE IN DIFRDDNS array S DIFRDDNS=0 F S DIFRDDNS=$O(DIFRDDNS(DIFRFILE,DIFRDDNS)) Q:DIFRDDNS'>0 D .D P(DIFRDDNS,DIFRFLG,$NA(@DIFRPTA@("P",DIFRFILE))) ;set "P" x-refs in target array .Q Q ; FP(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS ;FILE, FLAGS, TARGET ARRAY N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX S DIFRFW=$G(DIFRFLG)'["W" F S @DIFRTA@(DIFRFILE,DIFRFILE)=$O(^DD(DIFRFILE,0,"NM",""))_" "_$S($D(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)"),DIFRFE=0 E F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D .S DIFRFD=0 .F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 D ..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q ..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=$O(^DD(DIFRFD,0,"NM",""))_" (sub-file)" ..Q .Q Q ; P(DIFRPDD,DIFRFLG,DIFRPTA) ;DIFRPDD=DD#,DIFRPTA=TARGET ARRAY BY VALUE TO SET "P" X-REF ;FILE/SUB-DD#,FLAGS,TARGET_ARRAY N X,Y,PN,PIDF,PFILE,DIFRALL S DIFRFLG=$G(DIFRFLG),DIFRALL=DIFRFLG["A" I $G(U)'="^" N U S U="^" S X=$S(DIFRALL:0,1:.01) F S X=$O(^DD(DIFRPDD,X)) Q:X'>0 I $D(^(X,0)),'$P(^(0),U,2),$P(^(0),U,2)["P" S Y=^(0) D .I 'DIFRALL,$D(^DD(DIFRPDD,0,"IX",X)) Q .S PN=0 .S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3) .F Q:$P($G(^DD(+$P($P(Y,U,2),"P",2),.01,0)),U,2)'["P" S Y=^(0) D ..S PN=PN+1 ..S @DIFRPTA@(DIFRPDD,X,PN)=U_$P(Y,U,3) ..Q .S PIDF=0,PFILE=+$P($P(Y,U,2),"P",2) .F S PIDF=$O(^DD(PFILE,0,"ID",PIDF)) Q:PIDF'>0 D ..S @DIFRPTA@(DIFRPDD,X,PN,"ID",PIDF)="" ..Q .;HERE FIND ALL REQUIRED ID OR ALL ID FOR POINTED TOO FILE .;AND LIST IN @DIFRPTA@(DIFRPDD,X,PN,"ID",FILEDNUMBER) .Q Q ; PGL(DIFRFILE,DIFRFLG,DIFRTA) ; RETURN GL NODES FOR POINTERS IN TARGET ARRAY ;FILE,FLAGS,TARGET ARRAY N DIFR,DIFRD,DIFRF,DIFRPGL,DIFRX,DIKEY Q:'$D(^DD(DIFRFILE)) Q:$G(DIFRTA)']"" D FSF(DIFRFILE,"","DIFRPGL") S DIKEY=$O(^DD("KEY","AP",DIFRFILE,"P",0)) S (DIFR,DIFRD)=0 F S DIFRD=$O(DIFRPGL(DIFRFILE,DIFRD)) Q:DIFRD'>0 D .S DIFRF=.01 ;Dont select .01 fields .F S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0 I $D(^(DIFRF,0)) S DIFRX=^(0) D ..Q:$P(DIFRX,"^",2) ;Don't select Multiple/WP fields ..I $D(^DD(DIFRD,0,"ID",DIFRF)) Q ;Don't select IDENTIFIER fields ..I DIKEY,$O(^DD("KEY",DIKEY,2,"BB",DIFRF,DIFRD,0)) Q ;Don't select fields in Primary KEY ..I $P(DIFRX,"^",2)["P"!($P(DIFRX,"^",2)["V") S @DIFRTA@("PGL",DIFRD,$$Q^DIQGU($P($P(DIFRX,"^",4),";")),$P($P(DIFRX,"^",4),";",2),DIFRF)=DIFRX Q ..;SEND WHOLD NODE NOT $P(DIFRX,"^",2) Q ..Q .Q Q TP(DIFRFILE,DIFRFLG,DIFRTA) ; $$ Extrinsic Function - Test for Pointers OR Variable Pointers ;Returns 1 or 0, if pointers in file ;FILE,FLAGS,TARGET ARRAY ;If target array exist the entire list of fields being exported will be ;in array N DIFR,DIFRTMP,DIFRD,DIFRF,DIFRX S DIFRX=$G(DIFRTA)]"" D FSF(DIFRFILE,"","DIFRTMP") S (DIFR,DIFRD)=0 F S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0 D Q:DIFR .S DIFRF=.01 ; Do not include .01 fields .F S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0 I $D(^(DIFRF,0)),'$P(^(0),"^",2),($P(^(0),"^",2)["P"!($P(^(0),"^",2)["V")),'$D(^DD(DIFRD,0,"ID",DIFRF)) S:'DIFRX DIFR=1 Q:DIFR D ..S:DIFRX @DIFRTA@(DIFRD,DIFRF)=$S($P(^DD(DIFRD,DIFRF,0),"^",2)["P":"P",1:"V") ..Q .Q Q:DIFRX $D(@DIFRTA)>9 Q DIFR ; TL(DIFRFILE,DIFRFLG,DIFRSA) ; $$ Extrinsic Function - Test for local fields ;FILE,FLAGS,SOURCE_ARRAY - compares local DD with Transport DD ;Returns 1 or 0, if local changes exist ;RUN THIS AFTER DD IS INSTALLED ON TARGET SITE N DIFR,DIFRD,DIFRF,DIFRTMP D FSF(DIFRFILE,"","DIFRTMP") S (DIFR,DIFRD)=0 F S DIFRD=$O(DIFRTMP(DIFRFILE,DIFRD)) Q:DIFRD'>0 D Q:DIFR .S DIFRF=0 .F S DIFRF=$O(^DD(DIFRD,DIFRF)) Q:DIFRF'>0 I $D(^(DIFRF,0)),'$D(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRF,0)) S DIFR=1 Q .Q Q DIFR ; FSF(DIFRFILE,DIFRFLG,DIFRTA) ;File-Sub-File List ;FILE, FLAGS, TARGET ARRAY N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX S DIFRFW=$G(DIFRFLG)'["W" S @DIFRTA@(DIFRFILE,DIFRFILE)="",DIFRFE=0 F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D .S DIFRFD=0 .F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 D ..I DIFRFW,$P(^DD(DIFRFD,.01,0),"^",2)["W" Q ..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)="" ..Q .Q Q DIFROMSR DIFROMSR ;SFISC/DCL,TKW-RESOLVE POINTERS ON TARGET SYSTEM ;5/14/98 12:29 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q RP(DIFRFLG,DIFRFIA,DIFRSA,DIFRMSGR) ; Resolve Pointers on Target System ;The "FRV1" and "FRVL" structures within the ;transport array are used. ;FILE,FLAGS,FIAROOT,SOURCE_ARRAY,MSG_ROOT ;* ;FLAGS=(RESERVED FOR LATER USE) ; (Optional) ; None ;* ;FIA_ARRAY="FIA"_ARRAY_INPUT_ARRAY_ROOT ; (Optional) - Close Input Array Reference ; See DIFROM SERVER documentation for FIA array structure ; definitions. If undefined SOURCE_ARRAY will be used ; by appending "FIA" to the source array root subscript. ;* ;SOURCE_ARRAY=CLOSED_INPUT_ARRAY_ROOT ; (Required) - Closed Input Array Reference where the file data ; is temporarily stored for distribution. ;* ;MSG_ROOT=CLOSED ARRAY REFERENCE ; (Optional) - Closed array reference where messages such as ; errors will be returned. If not passed, decendents of ^TMP ; will be used. ;* I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW I $G(DIFRSA)']"" D ERR(6) G EXIT S DIFRFIA=$G(DIFRFIA) S:DIFRFIA="" DIFRFIA=$NA(@DIFRSA@("FIA")) ; I '$D(DIFRFIA) D ERR(2) G EXIT N DIFRFRVX,DIFRFILE S DIFRFRVX="FRV1",DIFRFILE=0 F S DIFRFILE=$O(@DIFRSA@(DIFRFRVX,DIFRFILE)) Q:DIFRFILE'>0 D FILE G EXIT ; FILE N DIFRTART,DIFRDNSC,DIFRPCE,DIFRSDA,DIFRY,DIFRPRV,DIFRPTF,DIFRPTFR,DIFRPRVL,DIFR2DD,DIFRTARL N C,D0,DA,DIC,DIK,F,G,I,R1,R2,R3,X,Y S DIFRTART=$NA(@DIFRSA@(DIFRFRVX,DIFRFILE)) S DIFRTARL=$NA(@DIFRSA@("FRVL",DIFRFILE)) S DIFRSDA=$$OREF^DILF($NA(@DIFRSA@("DATA",DIFRFILE))),DIFRDNSC="" F S DIFRDNSC=$O(@DIFRTART@(DIFRDNSC)) Q:DIFRDNSC="" D .K R1 .S R2=DIFRDNSC,C=$P(R2,","),F=1,R1=0 .F I=1:1 Q:I>C S G=$P(R2,",",F,I) Q:G="" I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1(R1)=G,R1=R1+1,C=C+($L(G,",")-1) .I R1'>3 S DIFR2DD=DIFRFILE .E D ..S R3="" ..F I=0:1:R1-3 S R3=R3_R1(I)_"," ..S DIFR2DD=+$P($G(@(DIFRSDA_R3_"0)")),"^",2) ..Q .; .S DIFRPCE="" .F S DIFRPCE=$O(@DIFRTART@(DIFRDNSC,DIFRPCE)) Q:DIFRPCE'>0 D ..S DIFRPRV=$G(@DIFRTART@(DIFRDNSC,DIFRPCE)),DIFRPTF=$G(^(DIFRPCE,"F")) ..S DIFRPRVL=$G(@DIFRTARL@(DIFRDNSC)),DIFRPTFR=$P(DIFRPTF,";",2) ..I DIFRPRVL="" D ERR(7," (^"_DIFRPTFR_"/"_DIFRPRV_")") Q ..I DIFRPTFR="" D ERR(8," ("_DIFRPRVL_"/"_DIFRPRV_")") Q ..I DIFRPRV="" D ERR(9," (^"_DIFRPTFR_"/"_DIFRPRVL_")") Q ..I '$D(@("^"_DIFRPTFR_"0)")) D ERR(10," (^"_DIFRPTFR_"/"_DIFRPRV_")") Q ..D LOOKUP ..I +Y'>0 D ERR(11," ("_DIC_" Entry:"_DIFRPRV_")") S Y=-1 ..S DIFRY=+Y S:DIFRPTF DIFRY=+Y_";"_DIFRPTFR ..S $P(@DIFRPRVL,"^",DIFRPCE)=DIFRY ..Q ; S DIK=@DIFRFIA@(DIFRFILE,0),DIK(0)="AB" D IXALL^DIK:$O(@(DIK_"0)")) ; Q ; LOOKUP ; Lookup entry on pointed-to file N DIFRS S DIFRS=$NA(@DIFRSA@("FRV1K",DIFRFILE,DIFRDNSC,DIFRPCE)) S DIC="^"_DIFRPTFR I '$O(@DIFRS@(0)) S DIC(0)="X",X=DIFRPRV D ^DIC Q N DIFL,DIKEY,I,DIFRVAL S DIKEY=@DIFRS S DIFL=+$P(@("^"_DIFRPTFR_"0)"),U,2) I 'DIFL S Y=-1 Q F I=0:0 S I=$O(@DIFRS@(I)) Q:'I S DIFRVAL(I)=@DIFRS@(I) S Y=$$FIND1^DIC(DIFL,",","X",.DIFRVAL,DIKEY) S:'Y Y=-1 Q ; EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q ERR(X,Y) S X=$P($T(ERR+X),";",5) S:$D(Y) Y(1)=Y Q:'X D BLD^DIALOG(X,.Y) Q ;;FIA Node Is Set To "No Data";1;9509 ;;FIA Array Does Not Exist;2;9501 ;;;3; ;;Records Do Not Exist;4;9510 ;;FIA File Number Invalid;5;9502 ;;Source Array Root Missing;6;9533 ;;Resolved Value Data Link Missing;7;9534 ;;Pointed Too File Missing;8;9535 ;;Pointer Resolved Value Missing;9;9538 ;;Pointed Too File NOT on Target System;10;9536 ;;Unable To Find Exact Match And Resolve Pointer;11;9537 DIFROMSS DIFROMSS ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;6/2/96 18:55 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q SEL(DIFRFILE,DIFRX) ;Extrinsic function to return resolved value for ;freetext pointer ;FILE,X-VALUE N D,DIC,DIE,DIX,DIY,DO,DS,X,Y N %,%K,%Y,DA,D0,D1,D2,D3 S DIC="^DIBT(",DIC(0)="QEMZ",X=DIFRX S DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9" D ^DIC Q:Y'>0 "" Q Y(0,0) ; HELP(DIFRFILE) ; N D,DIC,DIE,DIX,DIY,DO,DS,X,Y N %,%K,%Y,DA,D0,D1,D2,D3 S DIC="^DIBT(",DIC(0)="M",DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9",X="??" D ^DIC Q ; SB(DIFRDD,DIFRFLG,DIFRTA,DIFRVAL) ;Returns a list of sub-DDs for any DD# ;DD#,FLAGS,TARGET ARRAY(by value) ;DD/SUB DD NUMBER (required) ;FLAGS "W"=Include Word-processing fields (optional) ;TARGET ARRAY (required) ;DIFRVAL - SET TARGET ARRAY EQUAL TO N DIFRSDD,DIFRSSDD,DIFRNW S DIFRSDD=0,DIFRNW=$G(DIFRFLG)'["W",DIFRVAL=$G(DIFRVAL) F S DIFRSDD=$O(^DD(DIFRDD,"SB",DIFRSDD)) Q:DIFRSDD'>0 D .S DIFRSSDD=0 .I DIFRNW,$P($G(^DD(DIFRSDD,.01,0)),"^",2)["W" Q .S @DIFRTA@(DIFRSDD)=DIFRVAL,DIFRSSDD=$O(^DD(DIFRSDD,"SB",0)) .I DIFRSSDD D SB(DIFRSDD,$G(DIFRFLG),DIFRTA,DIFRVAL) .Q Q ; HDR2P(DIFRDD) ;Header Node/2nd piece update Q:$G(DIFRDD)'>0 "" Q:'$D(^DIC(+DIFRDD,0,"GL")) "" S DIFRDD=$TR(DIFRDD_$P($P(@(^("GL")_"0)"),"^",2),+DIFRDD,2),"DPSVIs") N DIFRDDT I $D(^DD(+DIFRDD,0,"ID")) S DIFRDD=DIFRDD_"I" I $D(^DD(+DIFRDD,0,"SCR")) S DIFRDD=DIFRDD_"s" F DIFRDDT="D","P","S","V" I $P(^DD(+DIFRDD,.01,0),"^",2)[DIFRDDT S DIFRDD=DIFRDD_DIFRDDT Q Q DIFRDD ; EXAM(TA) ;Examine what's in 2nd piece of data Header and put into array sub ;TA=Target Array Q:$G(TA)']"" N FN,GR,P2 S FN=0 F S FN=$O(^DIC(FN)) Q:FN'>0 I $D(^DIC(FN,0,"GL")) S GR=^("GL") D .Q:'$D(@(GR_"0)")) S P2=$P(^(0),"^",2),P2=$P(P2,+P2,2) .S:P2]"" @TA@(P2)=FN .Q Q ; VAL(DIFRFILE,DIFRIEN) ;Validate Edit and Print Template's and also Forms S DIFRFILE=$G(DIFRFILE),DIFRIEN=$G(DIFRIEN) Q:DIFRIEN'>0 0 N ROOT,PIECE,FILE D .N X .S X=DIFRFILE .I X=.4!(X=.402)!(X=.403)!(X=.404) Q .S DIFRFILE=0 .Q Q:DIFRFILE'>0 0 S ROOT="^"_$P($P(".4;DIPT^.402;DIE^.403;DIST(.403)^.404;DIST(.404)",DIFRFILE_";",2),"^") S PIECE=$P($P(".4;4^.402;4^.403;8^.404;2",DIFRFILE_";",2),"^") Q:'$D(@ROOT@(DIFRIEN,0)) 0 S FILE=$P(^(0),"^",PIECE) I DIFRFILE=.404&('FILE) Q 1 Q:FILE'>0 0 I DIFRFILE=.403 N BLOCK D Q:'BLOCK 0 .N PAGE,BLOCKP .S PAGE=0,BLOCK=1 .F S PAGE=$O(@ROOT@(DIFRIEN,40,PAGE)) Q:PAGE'>0 S BLOCKP=$P($G(^(PAGE,0)),"^",2) S:BLOCKP BLOCK=$$VAL(.404,BLOCKP) Q:'BLOCK D Q:'BLOCK ..N M40 ..S M40=0 ..F S M40=$O(@ROOT@(DIFRIEN,40,PAGE,40,M40)) Q:M40'>0 S BLOCK=$$VAL(.404,M40) Q:'BLOCK ..Q .Q I DIFRFILE=.4,$P(@ROOT@(DIFRIEN,0),"^",8) Q 0 Q $D(^DD(FILE,0))#2 DIFROMSU DIFROMSU ;SCISC/DCL-DIFROM SERVER BUILD "FIA" SUBSCRIPTS IN TRANSPORT ARRAY ;6/2/96 18:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. FIA(DIFRFILE,DIFRFLG,DIFRPFL,DIFRTAR,DIFR222,DIFR223,DIFRDSCR,DIFRVER,DIFRMSGR) ; ;FILE,FLAGS,PARTIAL_FILE_LIST,TARGET_ARRAY_ROOT,ANSWERS,DD_SCREEN,DATA_SCREEN,VERSION,MSG_ARRAY I '$D(DIQUIET) N DIQUIET S DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW N DIFRFD,DIFRFE,DIFRX,FIELD,FIELDNR,DIFRTA,DIFRP,DIFR00 S DIFRTA=$NA(@DIFRTAR@("FIA")) I $G(DIFRFILE)'>0 D BLD^DIALOG(9542) Q I '$D(^DIC(DIFRFILE)) D BLD^DIALOG(9539,DIFRFILE) Q I $P($G(DIFR222),"^",3)'="p" G F I $G(DIFRPFL)']"" G F I $D(@DIFRPFL)'>9 G F G F:$O(@DIFRPFL@(0))'>0 N DIFRDDC,DIFRFLDC,DIFRTMP K ^TMP("FIA",$J) S DIFRDDC=0,DIFRTMP=$NA(^TMP("FIA",$J)) M @DIFRTMP=@DIFRPFL F S DIFRDDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC)) Q:DIFRDDC'>0 D .I '$D(^DD(DIFRDDC)) K @DIFRTMP@(DIFRFILE,DIFRDDC) D BLD^DIALOG(9540,DIFRDDC) Q .I '$O(@DIFRTMP@(DIFRFILE,DIFRDDC,0)) D Q ..Q:@DIFRTMP@(DIFRFILE,DIFRDDC)="SUB" ..D SB^DIFROMSS(DIFRDDC,"W",$NA(@DIFRTMP@(DIFRFILE)),"SUB") ..Q .S DIFRFLDC=0 .F S DIFRFLDC=$O(@DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC)) Q:DIFRFLDC'>0 D ..I '$D(^DD(DIFRDDC,DIFRFLDC,0)) K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC) D Q ...N DIFRX S DIFRX(1)=DIFRFLDC,DIFRX(2)=DIFRDDC ...D BLD^DIALOG(9541,.DIFRX) ...Q ..I $P(^DD(DIFRDDC,DIFRFLDC,0),"^",2) S DIFRX=$P(^DD(+$P(^(0),"^",2),.01,0),"^",2) D ...I DIFRX["W" S @DIFRTMP@(DIFRFILE,+$P(^DD(DIFRDDC,DIFRFLDC,0),"^",2))=0 Q ...K @DIFRTMP@(DIFRFILE,DIFRDDC,DIFRFLDC) ...Q ..Q .Q ; M @DIFRTA@(DIFRFILE)=@DIFRTMP@(DIFRFILE) K @DIFRTMP ; I $D(@DIFRTA@(DIFRFILE,DIFRFILE))=1 G F S @DIFRTA@(DIFRFILE,DIFRFILE)=1,DIFRFE=DIFRFILE ;F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 S:$P(^DD(DIFRFE,.01,0),"^",2)'["W" @DIFRTA@(DIFRFILE,DIFRFE,.01)=0 F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D .S @DIFRTA@(DIFRFILE,DIFRFE)=$D(@DIFRTA@(DIFRFILE,DIFRFE))>9 .N DIFRX,DIFRY .S DIFRY=$$UP^DIQGU(DIFRFE,.DIFRX) .Q:'$D(DIFRX) .;K DIFRX($O(DIFRX(""))) <> .M @DIFRTAR@("UP",DIFRFILE,DIFRFE)=DIFRX .Q S DIFRFE=DIFRFILE F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D:'^(DIFRFE)!($D(@DIFRTA@(DIFRFILE,DIFRFE,.01))) .Q:'$D(^DD(DIFRFE,0,"UP")) .N DIFRUP,DIFRFLD .S DIFRUP=^DD(DIFRFE,0,"UP"),DIFRFLD=$O(^DD(DIFRUP,"SB",DIFRFE,0)) .Q:$G(@DIFRTA@(DIFRFILE,DIFRUP))=0!($D(@DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD))) .S @DIFRTA@(DIFRFILE,DIFRUP,DIFRFLD)="" .Q:$D(@DIFRTA@(DIFRFILE,DIFRUP))#2 .S @DIFRTA@(DIFRFILE,DIFRUP)=1 .Q ; G G F S @DIFRTA@(DIFRFILE,DIFRFILE)=0,DIFRFE=0 S:$P(DIFR222,"^",3)'="f" $P(DIFR222,"^",3)="f" E F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D .S DIFRFD=0 .F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 S @DIFRTA@(DIFRFILE,DIFRFD)=0 .Q G S @DIFRTA@(DIFRFILE)=$P(^DIC(DIFRFILE,0),"^") S (DIFR00,@DIFRTA@(DIFRFILE,0))=^DIC(DIFRFILE,0,"GL") S @DIFRTA@(DIFRFILE,0,0)=$P(@(DIFR00_"0)"),"^",2) S @DIFRTA@(DIFRFILE,0,1)=$G(DIFR222) S @DIFRTA@(DIFRFILE,0,10)=$G(DIFR223) S @DIFRTA@(DIFRFILE,0,11)=$G(DIFRDSCR) S @DIFRTA@(DIFRFILE,0,"RLRO")=$$ROOT($P(DIFR222,"^",6)) I $G(DIFRVER)]"" S @DIFRTA@(DIFRFILE,0,"VR")=DIFRVER FE I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR) Q ; ERR501(DIFRFILE,DIFRFLD) ; 501 Errors N DIFRERRX S DIFRERRX("FILE")=DIFRFILE,DIFRERRX(1)=DIFRFLD D BLD^DIALOG(501,.DIFRERRX) Q ROOT(IEN) ;Create root from DIBT(ien ; I $G(IEN)>0,$D(^DIBT(IEN,1))>9 Q "^DIBT("_IEN_",1)" I $G(IEN)]"" S IEN=$O(^DIBT("F"_DIFRFILE,IEN,"")) Q:IEN>0 $$ROOT(IEN) Q "" DIFROMSV DIFROMSV ;SFISC/DCL-DIFROM SERVER UTILITY,PKG REV DATA ;08:40 AM 6 Sep 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q PRD(DIFRFILE,DIFRPRD) ;Package Revision Data for File EN ;FILE,DATA ;Used to install Package Data from Post-Installation Routine Q:$G(DIFRFILE)'>1 Q:'$D(^DD(DIFRFILE)) S ^DD(DIFRFILE,0,"VRRV")=$G(DIFRPRD) Q DIFROMSX DIFROMSX ;SFIRMFO/DCM/TKW-MOVE INDEX FILE ENTRIES ;12:31 PM 31 Oct 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. DDIXOUT(DIFRFILE,DIFRF2,DIFRFDD,DIFRTA) ; retrieve INDEX entries for file ; DIFRFILE=top level file# ; DIFRF2=current file/subfile # ; DIFRFDD=1 if sending full DD ; DIFRTA=Global reference of transport global. N DIFRNAME,DIFRD0,DIFRD1,DIFRF,DIFRFLD,DIOUT,X,DICNT1,DICNT2 S DIFRNAME="",DIOUT=0 F S DIFRNAME=$O(^DD("IX","BB",DIFRF2,DIFRNAME)) Q:DIFRNAME="" D Q:DIOUT . S DIFRD0=$O(^DD("IX","BB",DIFRF2,DIFRNAME,0)) Q:'DIFRD0 . S (DIFRD1,DICNT1,DICNT2)=0 . F S DIFRD1=$O(^DD("IX",DIFRD0,11.1,DIFRD1)) Q:'DIFRD1 D Q:DIOUT . . S X=$G(^DD("IX",DIFRD0,11.1,DIFRD1,0)) . . S DIFRF=$P(X,U,3),DIFRFLD=$P(X,U,4) Q:'DIFRFLD!('DIFRF) . . S DICNT1=DICNT1+1,X=$$FNO^DILIBF(DIFRF) . . I '$D(@DIFRTA@("^DD",X,DIFRF,DIFRFLD)) D Q . . . Q:'DIFRFDD&($G(@DIFRTA@("FIA",X,DIFRF))'=0) . . . D ERR1(DIFRF,DIFRFLD,DIFRNAME,"INDEX") Q . . S DICNT2=DICNT2+1 . . Q . Q:DIOUT I DICNT2=0,'DIFRFDD Q . ;I DICNT1'=DICNT2 D ERR2(DIFRF2,DIFRNAME,"INDEX") Q . M @DIFRTA@("IX",DIFRFILE,DIFRF2,DIFRNAME)=^DD("IX",DIFRD0) . K @DIFRTA@("IX",DIFRFILE,DIFRF2,DIFRNAME,11.1,"AC") . K @DIFRTA@("IX",DIFRFILE,DIFRF2,DIFRNAME,11.1,"B") . K @DIFRTA@("IX",DIFRFILE,DIFRF2,DIFRNAME,11.1,"BB") . Q Q ; DDIXIN(DIFRFILE,DIFRF2,DIFRSA) ; Install INDEX file entries for file DIFRFILE ; DIFRFILE=source file# ; DIFRF2=current file/subfile# ; DIFRSA=name of array containing incoming data. N DIFRER,DIFRIN,DIFRNAME,DIFRD1,DIOUT,DIFRIN1,DIFRF,DIFRFLD,X I '$D(^DD(.11)) S DIFRER("FILE")=.11 D BLD^DIALOG(401,.DIFRER) Q S DIFRIN=$NA(@DIFRSA@("IX",DIFRFILE,DIFRF2)) S DIFRNAME="" F S DIFRNAME=$O(@DIFRIN@(DIFRNAME)) Q:DIFRNAME="" D . S (DIFRD1,DIOUT)=0,DIFRIN1=$NA(@DIFRIN@(DIFRNAME)) . F S DIFRD1=$O(@DIFRIN1@(11.1,DIFRD1)) Q:'DIFRD1 D Q:DIOUT . . S X=$G(@DIFRIN1@(11.1,DIFRD1,0)) . . S DIFRF=$P(X,U,3),DIFRFLD=$P(X,U,4) . . I 'DIFRF!('DIFRFLD) Q . . I '$D(^DD(DIFRF,DIFRFLD,0)) D ERR3(DIFRF,DIFRFLD,DIFRNAME,"INDEX") Q . . I $O(^DD(DIFRF,DIFRFLD,5,0)) D . . . Q:$D(^TMP("DIFROMS2",$J,"TRIG",DIFRFILE,DIFRF,DIFRFLD)) . . . D TRMOD^DICR(DIFRF,DIFRFLD) . . . S ^TMP("DIFROMS2",$J,"TRIG",DIFRFLD,DIFRF,DIFRFLD)="" Q . . Q . Q:DIOUT . N DIEN,DIK,DA,DIC,DO . S DIEN=$O(^DD("IX","BB",DIFRF2,DIFRNAME,0)) . I DIEN D N DINUM S DINUM=DIEN . . S DIK="^DD(""IX"",",DA=DIEN N DIEN D ^DIK Q . S DIC="^DD(""IX"",",DIC(0)="L",DIC("DR")=".02///^S X="_""""_DIFRNAME_"""",X=DIFRF2 D FILE^DICN S DIEN=+Y . I DIEN'>0 D ERR4(DIFRF2,DIFRNAME,"INDEX") Q . M ^DD("IX",DIEN)=@DIFRIN1 . K DIK,DA S DIK="^DD(""IX"",",DA=DIEN D IX1^DIK . Q Q ; ERR1(DIFRF,DIFRFLD,DIFRNAME,DIFRTYPE) ; N DIFRER S DIFRER(1)=DIFRFLD S DIFRER(2)=DIFRF S DIFRER(3)=DIFRNAME,DIFRER(4)=DIFRTYPE D BLD^DIALOG(9543,.DIFRER) S DIOUT=1 Q ERR2(DIFRF2,DIFRNAME,DIFRTYPE) ; N DIFRER S DIFRER(1)=DIFRNAME,DIFRER(2)=DIFRTYPE S DIFRER(3)=DIFRF2 D BLD^DIALOG(9544,.DIFRER) Q ERR3(DIFRF,DIFRFLD,DIFRNAME,DIFRTYPE) ; N DIFRER S DIFRER(1)=DIFRTYPE,DIFRER(2)=DIFRNAME S DIFRER(3)=DIFRFLD S DIFRER(4)=DIFRF D BLD^DIALOG(9545,.DIFRER) S DIOUT=1 Q ERR4(DIFRF2,DIFRNAME,DIFRTYPE) ; N DIFRER S DIFRER(1)=DIFRTYPE,DIFRER(2)=DIFRNAME,DIFRER(3)=DIFRF2 D BLD^DIALOG(9549,.DIFRER) Q ; ;9543 Field |1| of file |2|, part of '|3|' |4| entry, is missing from the transport global... ;9544 Field(s) that are part of |1| |2| entry are missing from the transport global. ;9545 |1| entry |2| not installed. The REFERENCE FIELD |3| in file |4| does not exist on the system. ;9549 |1| "|2|" on file |3| not installed, FILE^DICN call failed. ; DIFROMSY DIFROMSY ;SFIRMFO/DCM/TKW-MOVE KEY FILE ENTRIES ;12:32 PM 31 Oct 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. DDKEYOUT(DIFRFILE,DIFRF2,DIFRTA) ; retrieve KEY entries for file ; DIFRFILE=top level file number ; DIFRF2=current file/subfile number ; DIFRTA=Global reference of transport global N DINODE,DIFRNAME,DIFRDO,DIFRD1,DIFRF,DIFRFLD,DIOUT,X,Y,DICNT1,DICNT2 S DIFRNAME="",DIOUT=0 F S DIFRNAME=$O(^DD("KEY","BB",DIFRF2,DIFRNAME)) Q:DIFRNAME="" D Q:DIOUT . S DIFRD0=$O(^DD("KEY","BB",DIFRF2,DIFRNAME,0)) Q:'DIFRD0 . S (DIFRD1,DICNT1,DICNT2)=0 . F S DIFRD1=$O(^DD("KEY",DIFRD0,2,DIFRD1)) Q:'DIFRD1 D Q:DIOUT . . S X=$G(^DD("KEY",DIFRD0,2,DIFRD1,0)) . . S DIFRF=$P(X,U,2),DIFRFLD=$P(X,U) . . I 'DIFRF!('DIFRFLD) Q . . S DICNT1=DICNT1+1,X=$$FNO^DILIBF(DIFRF) . . I '$D(@DIFRTA@("^DD",X,DIFRF,DIFRFLD)) D Q . . . Q:'DIFRFDD&($G(@DIFRTA@("FIA",X,DIFRF))'=0) . . . D ERR1^DIFROMSX(DIFRF,DIFRFLD,DIFRNAME,"KEY") Q . . S DICNT2=DICNT2+1 . Q:DIOUT I DICNT2=0,'DIFRFDD Q . ;I DICNT1'=DICNT2 D ERR2^DIFROMSX(DIFRF2,DIFRNAME,"KEY") Q . M @DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME)=^DD("KEY",DIFRD0) . S X=$NA(@DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME,2)) . F Y="B","BB","S" K @X@(Y) . K @DIFRTA@("KEY",DIFRFILE,DIFRF2,DIFRNAME,DIFRD0,3.1,"B") . D IXPTR Q Q IXPTR ; export index pointer N DIIXPTR S DIIXPTR=$P(^DD("KEY",DIFRD0,0),U,4) I 'DIIXPTR D ERR1(9546,DIFRF2,DIFRNAME) Q N X,Y S X=$G(^DD("IX",DIIXPTR,0)),Y=$P(X,U,2),X=$P(X,U) I (+$P(X,"E")'=X)!(Y="") D ERR1(9546,DIFRF2,DIFRNAME) Q S @DIFRTA@("KEYPTR",DIFRFILE,DIFRF2,DIFRNAME)=X_"^"_Y Q ; DDKEYIN(DIFRFILE,DIFRF2,DIFRSA) ; ; DIFRFILE=top level file# ; DIFRF2=current file/subfile# ; DIFRSA=global reference of transport global I '$D(^DD(.31)) N DIFRER S DIFRER("FILE")=.31 D BLD^DIALOG(401,.DIFRER) Q N DIFRIN,DIFRNAME,DIFRD1,DIOUT,DIFRIN1,DIFRF,DIFRFLD,DIFRKPTR,X S DIFRIN=$NA(@DIFRSA@("KEY",DIFRFILE,DIFRF2)) S DIFRNAME="" F S DIFRNAME=$O(@DIFRIN@(DIFRNAME)) Q:DIFRNAME="" D . S (DIFRD1,DIOUT)=0,DIFRIN1=$NA(@DIFRIN@(DIFRNAME)) . F S DIFRD1=$O(@DIFRIN1@(2,DIFRD1)) Q:'DIFRD1 D Q:DIOUT . . S X=$G(@DIFRIN1@(2,DIFRD1,0)) . . S DIFRF=$P(X,U,2),DIFRFLD=$P(X,U) . . I 'DIFRF!('DIFRFLD) Q . . I '$D(^DD(DIFRF,DIFRFLD,0)) D ERR3^DIFROMSX(DIFRF,DIFRFLD,DIFRNAME,"KEY") . . Q . Q:DIOUT . S X=$G(@DIFRSA@("KEYPTR",DIFRFILE,DIFRF2,DIFRNAME)) D Q:DIOUT . . I X="" D ERR1(9547,DIFRF2,DIFRNAME) Q . . S DIFRKPTR=$O(^DD("IX","BB",$P(X,U),$P(X,U,2),0)) . . I 'DIFRKPTR D ERR1(9547,DIFRF2,DIFRNAME) Q . . S $P(@DIFRIN1@(0),U,4)=DIFRKPTR Q . N DIEN,DIK,DA,DIC,DO . S DIEN=$O(^DD("KEY","BB",DIFRF2,DIFRNAME,0)) . I DIEN D N DINUM S DINUM=DIEN . . S DIK="^DD(""KEY"",",DA=DIEN N DIEN D ^DIK Q . S DIC="^DD(""KEY"",",DIC(0)="L",DIC("DR")=".02///^S X="_""""_DIFRNAME_"""",X=DIFRF2 D FILE^DICN S DIEN=+Y . I DIEN'>0 D ERR4^DIFROMSX(DIFRF2,DIFRNAME,"KEY") Q . M ^DD("KEY",DIEN)=@DIFRIN1 . K DIK,DA S DIK="^DD(""KEY"",",DA=DIEN D IX1^DIK . Q Q ; ERR1(DIER,DIFRF2,DIFRNAME) ; N DIFRER S DIFRER(1)=DIFRNAME S DIFRER(2)=DIFRF2 D BLD^DIALOG(DIER,.DIFRER) S DIOUT=1 Q ; ;9543 Field |1| of file |2|, part of '|3|' |4| entry, is missing from the transport global... ;9545 |1| entry |2| is not installed. The REFERENCE FIELD |3| in file |4| does not exist on the system. ;9546 KEY '|1|' for file |2| cannot be transported, problem with Uniqueness Index for the KEY. ;9547 Key '|1|' for file |2| not installed. Pointer to Uniqueness Index cannot be resolved. ;9549 |1| "|2|" on file |3| not installed, FILE^DICN call failed. ; DIG DIG ;SFISC/GFT SUBTOTALS & SCATTERGRAM ;31MAY2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; W ! I '$D(^DOSV(0,IO(0),2)) W "NO SUB-SUB TOTALS WERE RUN" Q N POP,IOP,ZTSK S:$D(^%ZTSK) %ZIS="QM" D ^%ZIS Q:POP G QUE:$D(IO("Q")) ; DQ N DXMIN,DYMIN,DXMAX,DYMAX,DXI,N,NA,DYI S NA=$NA(^DOSV(0,IO(0))) S X=$O(@NA@(2,"")),(DXMIN,DXMAX)=X,(DYMIN,DYMAX)=$O(^(X,"")),X="" F S X=$O(@NA@(2,X)) Q:X="" S DXMAX=X,Y=$O(^(X,"")),DY=$O(^(""),-1) S:DYMIN>Y DYMIN=Y S:DY>DYMAX DYMAX=DY I DXMAX-DXMIN*(DYMAX-DYMIN)=0 D STATS(NA) Q ; ;here's the SCATTERGRAM NUMNUM N DIGPG,DIGTYPE,%H,%T,%Y,%D,B,I,L,H,T,DIGC,X,Y,DX,DY,DXS,DYS,DXSC,DYSC D DIGC S H=DYMAX,L=DYMIN,DYS=IOSL-9,N=DYS/6 D S(1) S DYMIN=B,DYSC=I/6,DYMAX=T,DYI=X DYI I T-B/DYI*6'>DYS,DYI'<2 S DYI=DYI\2 G DYI S H=DXMAX,L=DXMIN,DXS=IOM-28,N=DXS/6 D S(2) S DXMIN=B,DXSC=I/6,DXI=X,DXMAX=T,T=X*DXS/(T-B) S H="" LOOP K ^UTILITY($J) S DIGTYPE="N",H=$O(@NA@("F",H)) G END:'H D TOP(H) S (B,DX,DY)="" D G LOOP:X'=U I2 .S (DX,X)=$O(@NA@(2,DX)) I X="" W !?5,"(TOTAL = "_B_")",! G O .I DIGC(2,0)["D" D H^%DTC S X=%H .S X=$J(X-DXMIN/DXSC,0,0) I3 .S (Y,DY)=$O(@NA@(2,DX,DY)) G I2:Y="" I DIGC(1,0)["D" S C=X,X=Y D H^%DTC S Y=%H,X=C .I $D(^(DY,H,"N")) S C=^("N"),Y=$J(Y-DYMIN/DYSC,0,0),B=B+C,^(X)=C+$G(^UTILITY($J,Y,X)) .G I3 O .S X=0 D X W !?12,"." D P K Y S L=0 F B=DYMIN:DYI:DYMAX S Y($J(L,0,0))=$$E(B,1),L=DYI*DYS/(DYMAX-DYMIN)+L .W ".",! F Y=DYS:-1:0 D W ! ..I $D(Y(Y)) W ?12-$L(Y(Y)),Y(Y),"+" ..E W ?12,"|" ..S X="" F S X=$O(^UTILITY($J,Y,X)) Q:X="" S I=^(X) W ?X+13,$S(I>9:"*",I:I,1:"") ..W ?DXS+14 I W "+",Y(Y) Q ..W "|" .W ?13 D P W ! S X=DXI D X W !?22,"X-AXIS: ",$P(DIGC(2),U,3)," Y-AXIS: ",$P(DIGC(1),U,3) .G EOP END W:$E(IOST)'="C"&$Y @IOF K:$D(ZTSK) ^DOSV(0,IO(0)) Q D CLOSE^DIO4 Q ; X F B=DXMIN+X:DXI*2:DXMAX S Y=$$E(B,2) W ?B-DXMIN\DXSC-($L(Y)\2)+13,Y Q ; S(C) I DIGC(C,0)["D" F B="H","L" S X=@B D H^%DTC S @B=%H S B=H-L,X=1 I B>1 F C=1:1 S X=X*10 Q:B'>X E S I=1 Q:'B F C=0:-1 Q:X/10'>B S X=X/10 S B=L-X\X*X F I=B:X/10 Q:I'H S T=I I S I=T-B/X*10 I I>N S X=X*2 G I S X=X/10,I=T-B/N Q ; ; ; STATS(NA,DELIM) ;CROSS-TABS N DIGC,DIGB,DIGPG,DIGCOL,DIGSUB,RUN,DIGTYPE,DIG3,I,LT,L,%T,H,DUOUT D DIGC S DIGPG=1 1 I $D(@NA@(1)) D G Q:$D(DUOUT),END .F H=0:0 S H=$O(@NA@("F",H)),DIGTYPE="S" Q:'H D:$P(^(H),U,4)'["D" S DIGTYPE="N" D Q:$D(DUOUT) ..S Y="",L=0 F I=0:0 S Y=$O(@NA@(1,Y)) Q:Y="" I $D(^(Y,H,DIGTYPE)) S:$L(^(DIGTYPE))>L L=$L(^(DIGTYPE)) S:$L($$E(Y,1))>I I=$L($$E(Y,1)) ..I 'I!'L Q ..D TOP(H) W !! D TAB(4) W $$CAPT(1),! ..S Y="",%T=0 ..F S Y=$O(@NA@(1,Y)) Q:Y="" I $D(^(Y,H,DIGTYPE)) D Q:$D(DUOUT) ...I $Y+2>IOSL D EOP Q:$D(DUOUT) D TOP(H) ...W ! D TAB(4) W $$E(Y,1) D TAB(I+7) S X=@NA@(1,Y,H,DIGTYPE) W $$J(X,L) S %T=%T+X ..W !! D TAB(4) W "TOTAL" D TAB(I+7) W $$J(%T,L) D EOP 2 S DIGB=$NA(@NA@(2)) I $D(@DIGB)>9 D ALL2 G END 3 N A,B,C,D,E,NAT ;We had 3 levels of subtotalling, so we build a NAT matrix of TOTALS S NAT=$NA(^TMP("DIG",$J,0)) K ^TMP("DIG",$J) F A="F","HD","SHD" M ^TMP("DIG",$J,A)=@NA@(A) S A="" F S A=$O(@NA@(3,A)),B="" Q:A="" F S B=$O(@NA@(3,A,B)),C="" Q:B="" F S C=$O(@NA@(3,A,B,C)),D="" Q:C="" F S D=$O(@NA@(3,A,B,C,D)),E="" Q:D="" F S E=$O(@NA@(3,A,B,C,D,E)) Q:E="" D .S ^(E)=^(E)+$G(@NAT@(B,C,D,E)) ;SUM OVER ALL OF THEM F RUN=0:0 S RUN=$O(@NA@("F",RUN)) Q:'RUN F DIGTYPE="S","N" D:$$PAR(NAT,RUN,DIGTYPE) G END:$D(DUOUT) .F X="DIGCOL","DIGSUB","I","L","LT","C" M DIG3(RUN,DIGTYPE,X)=@X S DIG3="" F S DIG3=$O(@NA@(3,DIG3)) Q:DIG3="" S DIGB=$NA(@NA@(3,DIG3)) D ALL2 G END:$D(DUOUT) S NA=$NA(^TMP("DIG",$J)),DIG3="**ALL**",DIGB=NAT D ALL2 ;print grand totals G END ; ALL2 F RUN=0:0 S RUN=$O(@NA@("F",RUN)) Q:'RUN F DIGTYPE="S","N" I $P(@NA@("F",RUN),U,4)'["D"!(DIGTYPE="N") D RUN(RUN,DIGTYPE) Q:$D(DUOUT) ;don't try to sum dates Q ; RUN(RUN,DIGTYPE) N %H,%Y,%D,T,C,X,Y,DX,DXS,DYS,DXSC,DYSC,DIGCOL I $D(DIG3) Q:'$D(DIG3(RUN,DIGTYPE)) F X="DIGSUB","DIGCOL","C","L","LT","I" M @X=DIG3(RUN,DIGTYPE,X) E Q:'$$PAR(DIGB,RUN,DIGTYPE) ;If 3-level, we have already set up PARameters D TOP(RUN),SUBTOP M @DIGB@($C(127)_"EMPTY")=@DIGB@(" EMPTY") K @DIGB@(" EMPTY") S Y="" F S Y=$O(@DIGB@(Y)) Q:Y="" D G Q:$D(DUOUT) ;loop writes one output line .I $Y+2>IOSL D Q:$D(DUOUT) D TOP(RUN),SUBTOP ..D EOP .N T S X="" W !! D TAB(1) W $$E(Y,2) D TAB(I+5) ;write row caption .F N=0:1 S X=$O(DIGCOL(X)) Q:X="" S %T=$G(@DIGB@(Y,X,RUN,DIGTYPE)) W $$J(+%T,L) S T=$G(T)+%T,DX(X)=$G(DX(X))+%T .W $$J(T,LT) S X=" "_$TR($J("",IOM\2)," ","-") ;THE UNDERLINE I '$D(DELIM) W !! D TAB(I+5) F N=N:-1 W $E(X,1,L) I N=1 W $E(X,1,LT) Q W !! D TAB(1) W "TOTALS" D TAB(I+5) S (%T,X)="" F N=0:1 S X=$O(DIGCOL(X)) Q:X="" W $$J(DX(X),L) S %T=%T+DX(X) W $$J(%T,LT) EOP ; W !! I $G(IOST)?1"C".E D .N DIR,X,Y .S DIR(0)="E" D ^DIR Q ; PAR(DIGB,RUN,DIGTYPE) ;DIGB=NAME OF ARRAY Sets up DIGCOL array, and: ;I=width of left column ;L=width of data columns ;LT=width of TOTAL column ;C=number of data columns N Y,DY,DX,%,S K DIGCOL,DIGSUB S Y="",I=0,C=0,L=0 F S Y=$O(@DIGB@(Y)),X="" Q:Y="" S DY=$$E(Y,2) S:$L(DY)>I I=$L(DY) D .F S X=$O(@DIGB@(Y,X)) Q:X="" I $D(^(X,RUN,DIGTYPE)) S:$L(^(DIGTYPE))>L L=$L(^(DIGTYPE)) D:'$D(DIGCOL(X)) ..S C=C+1,DIGCOL(X)="",DX=$$E(X,1),%=0 F Q:DX="" S S=$P(DX," "),DX=$P(DX," ",2,99) I S]"" S %=%+1,DIGSUB(%,X)=S S:$L(S)>L L=$L(S) I 'C Q 0 S X="" F S X=$O(DIGCOL(X)) Q:X="" F Y=$O(DIGSUB(""),-1):-1:2 I $G(DIGSUB(Y,X))?." " S DIGSUB(Y,X)=$G(DIGSUB(Y-1,X)) K DIGSUB(Y-1,X) S Y=L*C+I+13 I Y>IOM,'$D(DELIM) U $P W !,"MARGIN WIDTH OF ",IOM," IS TOO SMALL FOR DISPLAY",!,"USE WIDTH OF AT LEAST ",Y H 1 S DUOUT=1 Q 0 S LT=8 F Y=Y+C+1:C+1:IOM S LT=LT+1,L=L+1 I Y+3DXS Q ; ; QUE ; S ZTSAVE("^DOSV(0,$I,")="" S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIG" D ^%ZTLOAD K ZTSK G END DIH DIH ;SFISC/GFT-HISTOGRAM ; 24JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. NO I $O(^DOSV(0,IO(0),0))'>0 D EN^DIALOG(1520) Q ;**CCO/NI 'NO SUB-COUNTS' K ZTSK S:$D(^%ZTSK) %ZIS="QM" D ^%ZIS G ENDK:POP,QUE:$D(IO("Q")) DQ S J=$I,DN="=$O(^DOSV(0,J," F X=0:1 Q:'$D(^DOSV(0,J,"BY",X+1)) G END:'X S A=^(1),DD=$P(A,U,3) I $D(^DD(+A,+$P(A,U,2),0)) S DD=^(0) S $P(DD,U)=$$LABEL^DIALOGZ(+A,+$P(A,U,2)) S T=$P(DD,U,2),DP=$P(DD,U,3),DF=$S(T["S":1,T["P":2,T["D"!($P(A,U,7)["D"):3,1:0) S DMX=DN_X,DX="",F=X F S DMX=DMX_",D"_F,DX=DX_"S D"_F_"="""" F X=X:0 S D"_F_DMX_")) Q:D"_F_"="""" "_$P("S X=X+1,DS(X)=0,DD(X)=0,DV(X)="_$E("-",$P(A,U,4)["-")_"D"_X_" ",U,F=X),F=F-1 G F:F S DX=DX_"S:$D(^(D1,F,""N"")) DD(X)=DD(X)+^(""N"") S:$D(^(""S"")) DS(X)=DS(X)+^(""S"")" I $E(IOST)="C" S DIFF=1 S F=-1,C="*",DIHIOM=IOM-23,DIHIOSL=IOSL-8 U IO W:$D(DIFF)&($Y) @IOF S DIFF=1 I S @("F"_DN_"""F"",F))") I 'F G END S X=0,T=^(F),DS=1 X DX S DIH=X D MAX G I ; MAX S DMX=0 F N=1:1:DIH S:DD(N)>DMX DMX=DD(N) D:DS=1&DF S DV(N)=$E(DV(N),1,14) ;**CCO/NI THRU NEXT 3 LINES HISTOGRAM CAPTIONS, INCLUDING NICE DATES .I DF=1 S DV(N)=$$SET^DIQ(+A,+$P(A,U,2),DV(N)) Q .I DF=2 S DV(N)=$P(@(U_DP_DV(N)_",0)"),U,1) Q .S DV(N)=$$DATE^DIUTL(DV(N)) S X=1 F S=1:1 S X=X*2 Q:DMX'>X S D1=DMX+X\X*X F S=D1:-X/2 Q:S'>DMX S D1=S S D2=DIHIOM*X/D1 XX S X=X\2,D2=D2\2 I X>4,$L(X)+7DIHIOSL @IOF W !! D W !! Q ..N H ..S H=$$EZBLD^DIALOG($S(DS=1:7089,DS=2:7090,DS=3:7088,1:-1)) ..I $D(^DD(+T,0)) S Y=+$P(T,U,2) I Y-.01,$D(^(Y,0)) S H=H_", "_$$LABEL^DIALOGZ(+T,Y) ..S H(1)=H,H(2)=$P(DD,U),H=$$EZBLD^DIALOG(7081,.H) W ?IOM-$L(H)-2,H SUM Q:$P(T,U,4)["D"!(Y=U) I DS=1 S DS=2 F N=1:1 G:N>DIH MAX S S=DD(N),DD(N)=DS(N),DS(N)=S MEAN I DS=2 S DS=3 F N=1:1 S DD(N)=$S(DS(N):DD(N)/DS(N),1:0) G MAX:N=DIH Q ; END W:($E(IOST)'="C")&($Y) @IOF K:$D(ZTSK) ^DOSV(0,IO) D CLOSE^DIO4 ENDK K ZTSK,DIH,S,A,C,DD,DS,D1,D2,DN,T,DP,F,N,J,POP,DF,X,Y,DX,DMX,DV,DIHIOM,DIHIOSL,DIFF Q ; ; LN W ?15-$L(DV(X))-1,DV(X)," |" F Y=1:1:DD(X)/S W C ;The *s W ! Q ; TR W ?15 F Y=0:1:DIHIOM W $E("-+",Y#D1=0+1) W ! F Y=1:1:DIHIOM I Y#D1=0 S D2=$J(Y*S,0,0) W ?Y+15-($L(D2)\2),D2 I IOST?1"C".E W $C(7) R Y:DTIME Q ; ; QUE ; S ZTSAVE("^DOSV(0,$I,")="" S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,ZTRTN="DQ^DIH" D ^%ZTLOAD K ZTSK G END ; ;7081 = __ BY ___ DII DII ;SFISC/GFT,XAK,TKW-OPTION RDR, INQUIRY ;9JUN2011 V ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D .N VERSION,X D VERSION^DI W !!,X,! I '$G(DUZ),$D(^VA(200,0))#2 D I '$G(DUZ) W $C(7),!,$$EZBLD^DIALOG(7005),! Q ;MUST HAVE DUZ! . N DIC,DTOUT,DUOUT ASK . S DUZ=0,DIC=200,DIC(0)="AEFNQZ",DIC("A")="Identity = ",DIC("S")="I Y'<1&$L($P(^(0),U,3))" . D ^DIC Q:Y'>0 . S DUZ=+Y,DUZ("LANG")=$P($G(^(200)),U,7),DUZ(1)="",DUZ(2)=$O(^VA(200,DUZ,2,0)) S:'$D(DUZ(0)) DUZ(0)=$P(Y(0),"^",4) . S DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8) S:'DUZ(2) DUZ(2)=+$P($G(^("XUS")),U,17) . S:'$G(DUZ("LANG")) DUZ("LANG")=$P($G(^XTV(8989.3,1,"XUS")),U,7) NOKL D DT^DICRW,OS S DIK="^DOPT(""DII""," G F:$D(^DOPT("DII",9)) S ^(0)="OPTION^1.01^" F I=1:1 S X=$E($T(F+I),4,99) Q:X="" S ^DOPT("DII",I,0)=X D IXALL^DIK F S DIC=DIK,DIC(0)="AEQZ" D ^DIC K DIC,DIK G Q:Y<0 S X=$P(Y(0),U,2,99) K Y D @X W !!! D Q G NOKL ;;ENTER OR EDIT FILE ENTRIES^^DIB ;;PRINT FILE ENTRIES^^DIP ;;SEARCH FILE ENTRIES^^DIS ;;MODIFY FILE ATTRIBUTES^^DICATT ;;INQUIRE TO FILE ENTRIES^INQ^DII ;;UTILITY FUNCTIONS^^DIU ;;OTHER OPTIONS^^DII1 ;;DATA DICTIONARY UTILITIES^^DDU ;;TRANSFER ENTRIES^^DIT ; Q D Q^DIB,Q^DICATT2,Q^DIARB K DRK,DIL,DIS,DK,DIACD,DIQ,DX,DQI,DISYS,DHIT,%X,%Y,%,DXS,Q,DIAR K A0,D9,DNP,DCC,DIJ,DP,DM,DQ,DICATT,DIFLD,D0,DIEL,DL,DC,DU,DIP K DH,DIYS,DINS,DIPT,DHD,DCL,DPP,DPQ,DALL,DIRUT,DIROUT,DUOUT,DTOUT Q INQ ; W !! D ^DICRW Q:'$D(DIC) S DI=DIC,DPP(1)=+Y_"^^^@",DK=+Y I $D(DICS) S DICSS=DICS B K ^UTILITY($J),^(U,$J),DIC,DIQ,DISV,DIBT,DICS S DIC=DI,DIC(0)="AEQM",DIK=0 R D ^DIC I Y>0 S DIK=DIK+1,^UTILITY(U,$J,DIK,+Y)="",DIC("A")=$$EZBLD^DIALOG(8199)_" " G R ;**CCO/NI 'ANOTHER ONE:' S G Q^DIP:'DIK!(X=U) G:DIK'>3 O D K DIRUT,DIROUT . N DIK,DI,DICSS,DX D S2^DIBT1 Q G:$D(DTOUT)!($D(DUOUT)) Q^DIP G:X="" O G:Y<0 S F X=1:1:DIK S ^DIBT(+Y,1,+$O(^UTILITY(U,$J,X,0)))="" S ^DIBT(+Y,"QR")=DT_U_DIK O K DIC G Q^DIP:$D(DTOUT) S DIC=DI,%=1 W !,$$EZBLD^DIALOG(8198) D YN^DICN G Q^DIP:%<0 ;**CCO/NI 'STANDARD CAPTIONED OUTPUT?' I '% D BLD^DIALOG(9108),MSG^DIALOG("WH") G O ;**CCO/NI 'ANSWER NO ....' I %=2 S L=1,Q="""",DPP=1,DPP(1,"IX")="^UTILITY(U,$J,"_DI_"^2" S:$D(DICSS) DICS=DICSS G N^DIP1 D C G:$D(DIRUT) Q S IOP="HOME" D ^%ZIS I $D(DICSS) S DICS=DICSS DIQ N S S S=1,$Y=0 F DIK=1:1:DIK S DA=+$O(^UTILITY(U,$J,DIK,0)) W ! D:DIK>1 LF^DIQ Q:'S D G:'S Q S S=S+2 .N DIK D CAPTION^DIQ(DK,DA,DIQ(0)) W !! Q:$D(DTOUT) G B ; P G Q^DI ; OS I $D(^%ZOSF("OS"))#2 S DISYS=+$P(^("OS"),"^",2) Q:DISYS>0 S DISYS=$S($D(^DD("OS"))#2:^("OS"),1:100) Q AUD S DIACD=DIQ(0),DIQ(0)="C",DIQ=DA F DA=0:0 S DA=$O(^DIA(DK,"B",DIQ,DA)) Q:DA'>0 S DIC="^DIA("_DK_",",E="N<0",N=-1,DD=1.1,DIA=DK D GUY^DIQ Q:'S W ! S DIQ(0)=DIACD Q ; C ;called from ^DIP21 N DIR,I,L,Y,X,DITXT D BLD^DIALOG(7004,"","","DIR") S DITXT="" D S DITXT=DITXT_DIR . F I=1:1 Q:$G(DIR(I))="" S DITXT=DITXT_DIR(I) . Q K DIR S DIR(0)="SMB^"_DITXT,DIR("B")=$P($P(DITXT,":",2)," ",1),DIR("A")=$$EZBLD^DIALOG(8002) D ^DIR Q:$D(DIRUT) F I=1:1 S X=$P($P(DITXT,";",I),":") Q:X="" I X=Y S DIQ(0)=$S(I=2:"C",I=3:"R",I=4:"CR",1:"") Q I X'=Y S DIRUT=1 Q A I $D(^DIA(DK)) S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8197),DIR("B")="No",DIR("?")=$$EZBLD^DIALOG(9109) D ^DIR Q:$D(DIRUT) S:Y=1 DIQ(0)=DIQ(0)_"A" ;**CCO/NI 'AUDIT TRAIL' QUERY & HELP Q ;7004 N:No;Y:Yes;R:Record Number;B:Both Computed and Number ;8002 Include COMPUTED fields DII1 DII1 ;SFISC/XAK-OTHER OPTIONS ;7/25/96 14:15 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. 0 S DIC="^DOPT(""DII1""," G OPT:$D(^DOPT("DII1",9)) S ^(0)="OTHER OPTION^1.01" K ^("B") F X=1:1:9 S ^DOPT("DII1",X,0)=$P($T(@X),";;",2) S DIK=DIC D IXALL^DIK OPT ; S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0 ; EN ; D @DI W !! Q K %,DIC,DIK,DI,DA,I,J,X,Y Q ; 1 ;;FILEGRAMS G ^DIFGO ; 2 ;;ARCHIVING G NOKL^DIAR ; 3 ;;AUDITING G ^DIAU ; 4 ;;SCREENMAN G ^DDSOPT ; 5 ;;STATISTICS G ^DIX ; 6 ;;EXTRACT DATA TO FILEMAN FILE G ^DIAX ; 7 ;;DATA EXPORT TO FOREIGN FORMAT G NOKL^DDXP ; 8 ;;IMPORT DATA G EN^DDMPU ; 9 ;;BROWSER G ^DDBR DIINI001 DIINI001 ; ; 28-MAR-2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"KEY",43,0) ;;=DIEXTRACT ;;^UTILITY(U,$J,"KEY",43,1,0) ;;=^^3^3^2930106^ ;;^UTILITY(U,$J,"KEY",43,1,1,0) ;;= ;;^UTILITY(U,$J,"KEY",43,1,2,0) ;;=This key is needed to access the menu for extracting data to a VA FileMan ;;^UTILITY(U,$J,"KEY",43,1,3,0) ;;=file. ;;^UTILITY(U,$J,"KEY",44,0) ;;=DDXP-DEFINE ;;^UTILITY(U,$J,"KEY",44,1,0) ;;=^^3^3^2930108^^ ;;^UTILITY(U,$J,"KEY",44,1,1,0) ;;=Holders of this key can use the Define Foreign File Format option. That ;;^UTILITY(U,$J,"KEY",44,1,2,0) ;;=option defines foreign formats, modifies existing formats that have not ;;^UTILITY(U,$J,"KEY",44,1,3,0) ;;=been used to create an export template, and clones formats. ;;^UTILITY(U,$J,"OPT",1328,0) ;;=DIEDIT^Enter or Edit File Entries^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1328,1,0) ;;=^^2^2^2890316^^^^ ;;^UTILITY(U,$J,"OPT",1328,1,1,0) ;;=This option is used to enter new entries in a file or edit existing ones. ;;^UTILITY(U,$J,"OPT",1328,1,2,0) ;;=You specify the file and fields within the file to edit. ;;^UTILITY(U,$J,"OPT",1328,20) ;;=D ^DIB ;;^UTILITY(U,$J,"OPT",1328,99) ;;=52905,54998 ;;^UTILITY(U,$J,"OPT",1328,"U") ;;=ENTER OR EDIT FILE ENTRIES ;;^UTILITY(U,$J,"OPT",1329,0) ;;=DIPRINT^Print File Entries^^A^^^^^^^y^^n^1^^ ;;^UTILITY(U,$J,"OPT",1329,1,0) ;;=^19.06^3^3^3000215^^^^ ;;^UTILITY(U,$J,"OPT",1329,1,1,0) ;;=This option is used to print a report from a file, where a number of ;;^UTILITY(U,$J,"OPT",1329,1,2,0) ;;=entries are to be listed in a columnar format. Each column can be ;;^UTILITY(U,$J,"OPT",1329,1,3,0) ;;=individually controlled for format, tabulation, justification, etc. ;;^UTILITY(U,$J,"OPT",1329,20) ;;=D ^DIP ;;^UTILITY(U,$J,"OPT",1329,99.1) ;;=55061,47656 ;;^UTILITY(U,$J,"OPT",1329,"U") ;;=PRINT FILE ENTRIES ;;^UTILITY(U,$J,"OPT",1330,0) ;;=DISEARCH^Search File Entries^^A^^^^^^^y^^n^1^^ ;;^UTILITY(U,$J,"OPT",1330,1,0) ;;=^^3^3^2930728^^^^ ;;^UTILITY(U,$J,"OPT",1330,1,1,0) ;;=This option is used to print a report in which entries are to be selected ;;^UTILITY(U,$J,"OPT",1330,1,2,0) ;;=according to a pre-determined set of criteria. After the search criteria ;;^UTILITY(U,$J,"OPT",1330,1,3,0) ;;=is met, a standard report will be generated. ;;^UTILITY(U,$J,"OPT",1330,20) ;;=D ^DIS ;;^UTILITY(U,$J,"OPT",1330,"U") ;;=SEARCH FILE ENTRIES ;;^UTILITY(U,$J,"OPT",1331,0) ;;=DIMODIFY^Modify File Attributes^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1331,1,0) ;;=^^2^2^2890316^^^ ;;^UTILITY(U,$J,"OPT",1331,1,1,0) ;;=This option is used to modify the structure of a file or the ;;^UTILITY(U,$J,"OPT",1331,1,2,0) ;;=characteristics of its fields. ;;^UTILITY(U,$J,"OPT",1331,20) ;;=D ^DICATT ;;^UTILITY(U,$J,"OPT",1331,"U") ;;=MODIFY FILE ATTRIBUTES ;;^UTILITY(U,$J,"OPT",1332,0) ;;=DIINQUIRE^Inquire to File Entries^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1332,1,0) ;;=3^^4^4^2890316^^ ;;^UTILITY(U,$J,"OPT",1332,1,1,0) ;;=This option is used to display all the data for a group of specified ;;^UTILITY(U,$J,"OPT",1332,1,2,0) ;;=entries in a file. This is useful for a quick look at a small number ;;^UTILITY(U,$J,"OPT",1332,1,3,0) ;;=of entries. Use the Print File Entries option for larger numbers ;;^UTILITY(U,$J,"OPT",1332,1,4,0) ;;=of entries. ;;^UTILITY(U,$J,"OPT",1332,20) ;;=D INQ^DII ;;^UTILITY(U,$J,"OPT",1332,"U") ;;=INQUIRE TO FILE ENTRIES ;;^UTILITY(U,$J,"OPT",1333,0) ;;=DIUTILITY^Utility Functions^^M^^^^^^^^^n^^ ;;^UTILITY(U,$J,"OPT",1333,1,0) ;;=^^2^2^2981020^^^^ ;;^UTILITY(U,$J,"OPT",1333,1,1,0) ;;=This option is a menu of VA FileMan utilities used to maintain the more ;;^UTILITY(U,$J,"OPT",1333,1,2,0) ;;=technical aspects of files. ;;^UTILITY(U,$J,"OPT",1333,10,0) ;;=^19.01PI^11^11 ;;^UTILITY(U,$J,"OPT",1333,10,1,0) ;;=1344^^6 ;;^UTILITY(U,$J,"OPT",1333,10,1,"^") ;;=DIEDFILE ;;^UTILITY(U,$J,"OPT",1333,10,2,0) ;;=1340^^2 ;;^UTILITY(U,$J,"OPT",1333,10,2,"^") ;;=DIXREF ;;^UTILITY(U,$J,"OPT",1333,10,3,0) ;;=1343^^5 ;;^UTILITY(U,$J,"OPT",1333,10,3,"^") ;;=DIITRAN ;;^UTILITY(U,$J,"OPT",1333,10,4,0) ;;=1341^^3 ;;^UTILITY(U,$J,"OPT",1333,10,4,"^") ;;=DIIDENT ;;^UTILITY(U,$J,"OPT",1333,10,5,0) ;;=1342^^4 ;;^UTILITY(U,$J,"OPT",1333,10,5,"^") ;;=DIRDEX ;;^UTILITY(U,$J,"OPT",1333,10,6,0) ;;=1345^^7 ;;^UTILITY(U,$J,"OPT",1333,10,6,"^") ;;=DIOTRAN ;;^UTILITY(U,$J,"OPT",1333,10,7,0) ;;=1346^^8 ;;^UTILITY(U,$J,"OPT",1333,10,7,"^") ;;=DITEMP ;;^UTILITY(U,$J,"OPT",1333,10,8,0) ;;=1347^^9 ;;^UTILITY(U,$J,"OPT",1333,10,8,"^") ;;=DIUNEDIT ;;^UTILITY(U,$J,"OPT",1333,10,9,0) ;;=1339^^1 ;;^UTILITY(U,$J,"OPT",1333,10,9,"^") ;;=DIVERIFY ;;^UTILITY(U,$J,"OPT",1333,10,10,0) ;;=1369^^10 ;;^UTILITY(U,$J,"OPT",1333,10,10,"^") ;;=DIFIELD CHECK ;;^UTILITY(U,$J,"OPT",1333,10,11,0) ;;=8767^^11 ;;^UTILITY(U,$J,"OPT",1333,10,11,"^") ;;=DIKEY ;;^UTILITY(U,$J,"OPT",1333,20) ;;= ;;^UTILITY(U,$J,"OPT",1333,99) ;;=62819,35307 ;;^UTILITY(U,$J,"OPT",1333,"U") ;;=UTILITY FUNCTIONS ;;^UTILITY(U,$J,"OPT",1334,0) ;;=DISTATISTICS^Statistics^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1334,1,0) ;;=^^3^3^2890316^^^ ;;^UTILITY(U,$J,"OPT",1334,1,1,0) ;;=After generating output from the Print File Entries or Search File Entries ;;^UTILITY(U,$J,"OPT",1334,1,2,0) ;;=options, call upon the Statistics option to produce your choice of ;;^UTILITY(U,$J,"OPT",1334,1,3,0) ;;=seven types of statistical tallies. ;;^UTILITY(U,$J,"OPT",1334,20) ;;=D ^DIX ;;^UTILITY(U,$J,"OPT",1334,"U") ;;=STATISTICS ;;^UTILITY(U,$J,"OPT",1335,0) ;;=DILIST^List File Attributes^^A^^^^^^^y^^n^1^^ ;;^UTILITY(U,$J,"OPT",1335,1,0) ;;=^^3^3^2890316^^^^ ;;^UTILITY(U,$J,"OPT",1335,1,1,0) ;;=This option is used to print data dictionary listings for a given file. ;;^UTILITY(U,$J,"OPT",1335,1,2,0) ;;=This listing is useful for programmers, analysts, and others interested ;;^UTILITY(U,$J,"OPT",1335,1,3,0) ;;=in data base structures. ;;^UTILITY(U,$J,"OPT",1335,20) ;;=D ^DID ;;^UTILITY(U,$J,"OPT",1335,99.1) ;;=54447,33461 ;;^UTILITY(U,$J,"OPT",1335,"U") ;;=LIST FILE ATTRIBUTES ;;^UTILITY(U,$J,"OPT",1336,0) ;;=DITRANSFER^Transfer Entries^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1336,1,0) ;;=^^2^2^2890316^^^^ ;;^UTILITY(U,$J,"OPT",1336,1,1,0) ;;=This option is used to transfer entries from one file to another or to ;;^UTILITY(U,$J,"OPT",1336,1,2,0) ;;=merge data from one entry to another in the same file. ;;^UTILITY(U,$J,"OPT",1336,20) ;;=D ^DIT ;;^UTILITY(U,$J,"OPT",1336,"U") ;;=TRANSFER ENTRIES ;;^UTILITY(U,$J,"OPT",1337,0) ;;=DIUSER^VA FileMan^^M^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1337,1,0) ;;=^^2^2^2910205^^^^ ;;^UTILITY(U,$J,"OPT",1337,1,1,0) ;;=This option branches to the VA FileMan main menu, which allows you ;;^UTILITY(U,$J,"OPT",1337,1,2,0) ;;=to enter, edit, report, inquire, and maintain data dictionaries. ;;^UTILITY(U,$J,"OPT",1337,10,0) ;;=^19.01PI^11^9 ;;^UTILITY(U,$J,"OPT",1337,10,1,0) ;;=1328^^1 ;;^UTILITY(U,$J,"OPT",1337,10,1,"^") ;;=DIEDIT ;;^UTILITY(U,$J,"OPT",1337,10,2,0) ;;=1332^^5 ;;^UTILITY(U,$J,"OPT",1337,10,2,"^") ;;=DIINQUIRE ;;^UTILITY(U,$J,"OPT",1337,10,4,0) ;;=1331^^4 ;;^UTILITY(U,$J,"OPT",1337,10,4,"^") ;;=DIMODIFY ;;^UTILITY(U,$J,"OPT",1337,10,5,0) ;;=1329^^2 ;;^UTILITY(U,$J,"OPT",1337,10,5,"^") ;;=DIPRINT ;;^UTILITY(U,$J,"OPT",1337,10,6,0) ;;=1330^^3 ;;^UTILITY(U,$J,"OPT",1337,10,6,"^") ;;=DISEARCH ;;^UTILITY(U,$J,"OPT",1337,10,8,0) ;;=1336^^9 ;;^UTILITY(U,$J,"OPT",1337,10,8,"^") ;;=DITRANSFER ;;^UTILITY(U,$J,"OPT",1337,10,9,0) ;;=1333^^6 ;;^UTILITY(U,$J,"OPT",1337,10,9,"^") ;;=DIUTILITY ;;^UTILITY(U,$J,"OPT",1337,10,10,0) ;;=1359^^10 ;;^UTILITY(U,$J,"OPT",1337,10,10,"^") ;;=DIOTHER ;;^UTILITY(U,$J,"OPT",1337,10,11,0) ;;=1373^^8 ;;^UTILITY(U,$J,"OPT",1337,10,11,"^") ;;=DI DDU ;;^UTILITY(U,$J,"OPT",1337,20) ;;=W !!?10,"VA FileMan Version "_^DD("VERSION") ;;^UTILITY(U,$J,"OPT",1337,99) ;;=62819,35307 ;;^UTILITY(U,$J,"OPT",1337,99.1) ;;=62627,35095 ;;^UTILITY(U,$J,"OPT",1337,1613) ;;= ;;^UTILITY(U,$J,"OPT",1337,"U") ;;=VA FILEMAN ;;^UTILITY(U,$J,"OPT",1338,0) ;;=DI DDMAP^Map Pointer Relations^^R^^^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1338,1,0) ;;=^^3^3^2910706^ ;;^UTILITY(U,$J,"OPT",1338,1,1,0) ;;=This option prints a map of the pointer relations between a group of ;;^UTILITY(U,$J,"OPT",1338,1,2,0) ;;=files. The file selection is from the package file or entered ;;^UTILITY(U,$J,"OPT",1338,1,3,0) ;;=individually. ;;^UTILITY(U,$J,"OPT",1338,25) ;;=DDMAP ;;^UTILITY(U,$J,"OPT",1338,136) ;;= ;;^UTILITY(U,$J,"OPT",1338,"U") ;;=MAP POINTER RELATIONS ;;^UTILITY(U,$J,"OPT",1339,0) ;;=DIVERIFY^Verify Fields^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1339,1,0) ;;=^^4^4^2890316^^^ ;;^UTILITY(U,$J,"OPT",1339,1,1,0) ;;=This option is used to double check the data that exists in a field ;;^UTILITY(U,$J,"OPT",1339,1,2,0) ;;=to see that it matches the Data Dictionary specifications. The user ;;^UTILITY(U,$J,"OPT",1339,1,3,0) ;;=is allowed to store the discrepancies in a search template so that they ;;^UTILITY(U,$J,"OPT",1339,1,4,0) ;;=can easily be retrieved for examination and correction. ;;^UTILITY(U,$J,"OPT",1339,20) ;;=S DI=1 G EN^DIU ;;^UTILITY(U,$J,"OPT",1339,"U") ;;=VERIFY FIELDS ;;^UTILITY(U,$J,"OPT",1340,0) ;;=DIXREF^Cross-Reference A Field^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1340,1,0) ;;=^^5^5^2980908^^ ;;^UTILITY(U,$J,"OPT",1340,1,1,0) ;;=The Cross-Reference a Field sub-option of the Utility Functions option ;;^UTILITY(U,$J,"OPT",1340,1,2,0) ;;=allows you to identify a field or sub-field for cross-referencing or ;;^UTILITY(U,$J,"OPT",1340,1,3,0) ;;=for removing cross-referencing from an identified field. ;;^UTILITY(U,$J,"OPT",1340,1,4,0) ;;=VA FileMan currently has seven types of cross-references -- Regular, ;;^UTILITY(U,$J,"OPT",1340,1,5,0) ;;=KWIC, Mnemonic, MUMPS, Soundex, Trigger and Bulletin. ;;^UTILITY(U,$J,"OPT",1340,20) ;;=S DI=2 G EN^DIU ;;^UTILITY(U,$J,"OPT",1340,"U") ;;=CROSS-REFERENCE A FIELD ;;^UTILITY(U,$J,"OPT",1341,0) ;;=DIIDENT^Identifier^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1341,1,0) ;;=^^4^4^2890316^ ;;^UTILITY(U,$J,"OPT",1341,1,1,0) ;;=Use the Identifier sub-option of the Utility Functions option to associate ;;^UTILITY(U,$J,"OPT",1341,1,2,0) ;;=a field with the .01 (or NAME) field of a file. The field designated as ;;^UTILITY(U,$J,"OPT",1341,1,3,0) ;;=an identifier can be displayed along with the selected entry to help ;;^UTILITY(U,$J,"OPT",1341,1,4,0) ;;=a user positively identify the entry. ;;^UTILITY(U,$J,"OPT",1341,20) ;;=S DI=3 G EN^DIU ;;^UTILITY(U,$J,"OPT",1341,"U") ;;=IDENTIFIER ;;^UTILITY(U,$J,"OPT",1342,0) ;;=DIRDEX^Re-Index File^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1342,1,0) ;;=^^4^4^2890316^ ;;^UTILITY(U,$J,"OPT",1342,1,1,0) ;;=The Re-index a File sub-option of the Utility Functions option allows ;;^UTILITY(U,$J,"OPT",1342,1,2,0) ;;=you to re-index a file. This VA FileMan feature is especially helpful ;;^UTILITY(U,$J,"OPT",1342,1,3,0) ;;=when you create a new cross reference on a field that already contains ;;^UTILITY(U,$J,"OPT",1342,1,4,0) ;;=data. ;;^UTILITY(U,$J,"OPT",1342,20) ;;=S DI=4 G EN^DIU ;;^UTILITY(U,$J,"OPT",1342,"U") ;;=RE-INDEX FILE ;;^UTILITY(U,$J,"OPT",1343,0) ;;=DIITRAN^Input Transform (Syntax)^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1343,1,0) ;;=^^4^4^2901212^^^ ;;^UTILITY(U,$J,"OPT",1343,1,1,0) ;;=The Input Transform sub-option of the Utility Functions option allows ;;^UTILITY(U,$J,"OPT",1343,1,2,0) ;;=you to enter an executable string of MUMPS code which is used to check ;;^UTILITY(U,$J,"OPT",1343,1,3,0) ;;=the validity of user input and will then convert the input into an ;;^UTILITY(U,$J,"OPT",1343,1,4,0) ;;=internal form for storage. ;;^UTILITY(U,$J,"OPT",1343,20) ;;=Q:DUZ(0)'="@" S DI=5 G EN^DIU ;;^UTILITY(U,$J,"OPT",1343,"U") ;;=INPUT TRANSFORM (SYNTAX) ;;^UTILITY(U,$J,"OPT",1344,0) ;;=DIEDFILE^Edit File^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1344,1,0) ;;=^^3^3^2890316^^ ;;^UTILITY(U,$J,"OPT",1344,1,1,0) ;;=This option allows the user to document and control a file. The user ;;^UTILITY(U,$J,"OPT",1344,1,2,0) ;;=may describe the purpose of the file, assign it security, indicate ;;^UTILITY(U,$J,"OPT",1344,1,3,0) ;;=application groups which use the file, and change the name of the file. ;;^UTILITY(U,$J,"OPT",1344,20) ;;=S DI=6 G EN^DIU ;;^UTILITY(U,$J,"OPT",1344,"U") ;;=EDIT FILE ;;^UTILITY(U,$J,"OPT",1345,0) ;;=DIOTRAN^Output Transform^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1345,1,0) ;;=^^3^3^2890316^ ;;^UTILITY(U,$J,"OPT",1345,1,1,0) ;;=The Output Transform sub-option of the Utility Functions option allows ;;^UTILITY(U,$J,"OPT",1345,1,2,0) ;;=you to enter an executable string of MUMPS code which converts internally ;;^UTILITY(U,$J,"OPT",1345,1,3,0) ;;=stored data into a readable display. ;;^UTILITY(U,$J,"OPT",1345,20) ;;=S DI=7 G EN^DIU ;;^UTILITY(U,$J,"OPT",1345,"U") ;;=OUTPUT TRANSFORM ;;^UTILITY(U,$J,"OPT",1346,0) ;;=DITEMP^Template Edit^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1346,1,0) ;;=^^4^4^2890316^ ;;^UTILITY(U,$J,"OPT",1346,1,1,0) ;;=The Template Edit sub-option of the Utility Functions option allows you ;;^UTILITY(U,$J,"OPT",1346,1,2,0) ;;=to enter a description of any sort, print or input templates in a selected ;;^UTILITY(U,$J,"OPT",1346,1,3,0) ;;=file. These descriptions will be printed when you request a Templates ;;^UTILITY(U,$J,"OPT",1346,1,4,0) ;;=Only data dictionary listing. ;;^UTILITY(U,$J,"OPT",1346,20) ;;=S DI=8 G EN^DIU ;;^UTILITY(U,$J,"OPT",1346,"U") ;;=TEMPLATE EDIT ;;^UTILITY(U,$J,"OPT",1347,0) ;;=DIUNEDIT^Uneditable Data^^A^^^^^^^^^n^1^^ ;;^UTILITY(U,$J,"OPT",1347,1,0) ;;=^^4^4^2890316^ ;;^UTILITY(U,$J,"OPT",1347,1,1,0) ;;=The Uneditable Data sub-option of the Utility Functions option allows you ;;^UTILITY(U,$J,"OPT",1347,1,2,0) ;;=to specify a particular field that CANNOT be edited or deleted by a user. ;;^UTILITY(U,$J,"OPT",1347,1,3,0) ;;=If an uneditable data field is edited, VA FileMan will display the field ;;^UTILITY(U,$J,"OPT",1347,1,4,0) ;;=value along with one of the famous 'No Editing' messages. DIINI002 DIINI002 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"OPT",1347,20) ;;=S DI=9 G EN^DIU ;;^UTILITY(U,$J,"OPT",1347,"U") ;;=UNEDITABLE DATA ;;^UTILITY(U,$J,"OPT",1348,0) ;;=DI SET MUMPS OS^Set Type of Mumps Operating System^^R^^^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1348,1,0) ;;=^^3^3^2880712^ ;;^UTILITY(U,$J,"OPT",1348,1,1,0) ;;=This option allows the user to set the Type of Mumps Operating System. ;;^UTILITY(U,$J,"OPT",1348,1,2,0) ;;=VA FileMan uses this to perform operating system specific functions ;;^UTILITY(U,$J,"OPT",1348,1,3,0) ;;=such as determining routine existence or filing routines. ;;^UTILITY(U,$J,"OPT",1348,25) ;;=OS^DINIT ;;^UTILITY(U,$J,"OPT",1348,"U") ;;=SET TYPE OF MUMPS OPERATING SY ;;^UTILITY(U,$J,"OPT",1349,0) ;;=DI MGMT MENU^VA FileMan Management^^M^^XUMGR^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1349,10,0) ;;=^19.01PI^7^7 ;;^UTILITY(U,$J,"OPT",1349,10,1,0) ;;=1348^^6 ;;^UTILITY(U,$J,"OPT",1349,10,1,"^") ;;=DI SET MUMPS OS ;;^UTILITY(U,$J,"OPT",1349,10,2,0) ;;=1350^^5 ;;^UTILITY(U,$J,"OPT",1349,10,2,"^") ;;=DI REINITIALIZE ;;^UTILITY(U,$J,"OPT",1349,10,3,0) ;;=1353^^1 ;;^UTILITY(U,$J,"OPT",1349,10,3,"^") ;;=DI DD COMPILE ;;^UTILITY(U,$J,"OPT",1349,10,4,0) ;;=1351^^3 ;;^UTILITY(U,$J,"OPT",1349,10,4,"^") ;;=DI PRINT COMPILE ;;^UTILITY(U,$J,"OPT",1349,10,5,0) ;;=1352^^2 ;;^UTILITY(U,$J,"OPT",1349,10,5,"^") ;;=DI INPUT COMPILE ;;^UTILITY(U,$J,"OPT",1349,10,6,0) ;;=1371^^7 ;;^UTILITY(U,$J,"OPT",1349,10,6,"^") ;;=DIWF ;;^UTILITY(U,$J,"OPT",1349,10,7,0) ;;=1392^^4 ;;^UTILITY(U,$J,"OPT",1349,10,7,"^") ;;=DI SORT COMPILE ;;^UTILITY(U,$J,"OPT",1349,99) ;;=62819,35307 ;;^UTILITY(U,$J,"OPT",1349,99.1) ;;=55799,10811 ;;^UTILITY(U,$J,"OPT",1349,"U") ;;=VA FILEMAN MANAGEMENT ;;^UTILITY(U,$J,"OPT",1350,0) ;;=DI REINITIALIZE^Re-Initialize VA FileMan^^R^^^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1350,25) ;;=DINIT ;;^UTILITY(U,$J,"OPT",1350,"U") ;;=RE-INITIALIZE VA FILEMAN ;;^UTILITY(U,$J,"OPT",1351,0) ;;=DI PRINT COMPILE^Print Template Compile/Uncompile^^R^^^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1351,1,0) ;;=^^1^1^2930715^^ ;;^UTILITY(U,$J,"OPT",1351,1,1,0) ;;=This option allows the user to compile or uncompile a print template. ;;^UTILITY(U,$J,"OPT",1351,25) ;;=EN1^DIPZ ;;^UTILITY(U,$J,"OPT",1351,"U") ;;=PRINT TEMPLATE COMPILE/UNCOMPI ;;^UTILITY(U,$J,"OPT",1352,0) ;;=DI INPUT COMPILE^Input Template Compile/Uncompile^^A^^^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1352,1,0) ;;=^^1^1^2930715^^^^ ;;^UTILITY(U,$J,"OPT",1352,1,1,0) ;;=This option allows the user to compile or uncompile an Input Template. ;;^UTILITY(U,$J,"OPT",1352,20) ;;=D EN1^DIEZ K DNM ;;^UTILITY(U,$J,"OPT",1352,"U") ;;=INPUT TEMPLATE COMPILE/UNCOMPI ;;^UTILITY(U,$J,"OPT",1353,0) ;;=DI DD COMPILE^Data Dictionary Cross-reference Compile/Uncompile^^R^^^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1353,1,0) ;;=^^3^3^2930715^^^^ ;;^UTILITY(U,$J,"OPT",1353,1,1,0) ;;=This option allows the user to compile or uncompile a Data Dictionary's ;;^UTILITY(U,$J,"OPT",1353,1,2,0) ;;=cross-references into routines which are run whenever an entry ;;^UTILITY(U,$J,"OPT",1353,1,3,0) ;;=is indexed or deleted. ;;^UTILITY(U,$J,"OPT",1353,25) ;;=EN1^DIKZ ;;^UTILITY(U,$J,"OPT",1353,"U") ;;=DATA DICTIONARY CROSS-REFERENC ;;^UTILITY(U,$J,"OPT",1354,0) ;;=DIAUDIT^Audit Menu^^M^^XUAUDITING^^^^^^VA FILEMAN^^ ;;^UTILITY(U,$J,"OPT",1354,1,0) ;;=^^2^2^3130126^ ;;^UTILITY(U,$J,"OPT",1354,1,1,0) ;;=This menu contains the options that show which files and fields are being ;;^UTILITY(U,$J,"OPT",1354,1,2,0) ;;=audited as well as the options that purge audit trails. ;;^UTILITY(U,$J,"OPT",1354,10,0) ;;=^19.01IP^7^7 ;;^UTILITY(U,$J,"OPT",1354,10,1,0) ;;=1355^^1 ;;^UTILITY(U,$J,"OPT",1354,10,1,"^") ;;=DIAUDITED FIELDS ;;^UTILITY(U,$J,"OPT",1354,10,3,0) ;;=1357^^3 ;;^UTILITY(U,$J,"OPT",1354,10,3,"^") ;;=DIAUDIT PURGE DATA ;;^UTILITY(U,$J,"OPT",1354,10,4,0) ;;=1358^^5 ;;^UTILITY(U,$J,"OPT",1354,10,4,"^") ;;=DIAUDIT PURGE DD ;;^UTILITY(U,$J,"OPT",1354,10,5,0) ;;=1370^^2 ;;^UTILITY(U,$J,"OPT",1354,10,5,"^") ;;=DIAUDIT TURN ON/OFF ;;^UTILITY(U,$J,"OPT",1354,10,6,0) ;;=11396^^4 ;;^UTILITY(U,$J,"OPT",1354,10,6,"^") ;;=DIAUDIT SHOW DD AUDIT TRAIL ;;^UTILITY(U,$J,"OPT",1354,10,7,0) ;;=11388^^6 ;;^UTILITY(U,$J,"OPT",1354,10,7,"^") ;;=DIAUDIT MONITOR USER ;;^UTILITY(U,$J,"OPT",1354,99) ;;=62849,43060 ;;^UTILITY(U,$J,"OPT",1354,"U") ;;=AUDIT MENU ;;^UTILITY(U,$J,"OPT",1355,0) ;;=DIAUDITED FIELDS^List Fields Being Audited^^R^^^^^^^^VA FILEMAN^^ ;;^UTILITY(U,$J,"OPT",1355,1,0) ;;=^^2^2^3130126^ ;;^UTILITY(U,$J,"OPT",1355,1,1,0) ;;=This options lists all the fields that are being audited. One can see all ;;^UTILITY(U,$J,"OPT",1355,1,2,0) ;;=the fields or just those in a particular file range. ;;^UTILITY(U,$J,"OPT",1355,25) ;;=1^DIAU ;;^UTILITY(U,$J,"OPT",1355,"U") ;;=LIST FIELDS BEING AUDITED ;;^UTILITY(U,$J,"OPT",1357,0) ;;=DIAUDIT PURGE DATA^Data Audit Trail Purge^^R^^^^^^^^VA FILEMAN^^ ;;^UTILITY(U,$J,"OPT",1357,1,0) ;;=^^4^4^3130126^ ;;^UTILITY(U,$J,"OPT",1357,1,1,0) ;;=This option purges all or part of the data-audit trail for a particular ;;^UTILITY(U,$J,"OPT",1357,1,2,0) ;;=file. Either all of the data audits may be purged or part of the data ;;^UTILITY(U,$J,"OPT",1357,1,3,0) ;;=audits may be deleted based on a field in the audit file, e.g., date, ;;^UTILITY(U,$J,"OPT",1357,1,4,0) ;;=user, field. ;;^UTILITY(U,$J,"OPT",1357,25) ;;=3^DIAU ;;^UTILITY(U,$J,"OPT",1357,99.1) ;;=56123,39787 ;;^UTILITY(U,$J,"OPT",1357,"U") ;;=DATA AUDIT TRAIL PURGE ;;^UTILITY(U,$J,"OPT",1358,0) ;;=DIAUDIT PURGE DD^DD Audit Trail Purge^^R^^^^^^^^VA FILEMAN^^ ;;^UTILITY(U,$J,"OPT",1358,1,0) ;;=^^3^3^3130126^ ;;^UTILITY(U,$J,"OPT",1358,1,1,0) ;;=This option purges all or part of the DD audit trail for a particular ;;^UTILITY(U,$J,"OPT",1358,1,2,0) ;;=file. Either all of the DD audits may be purged or part of it may be ;;^UTILITY(U,$J,"OPT",1358,1,3,0) ;;=deleted based on a field in the audit file, e.g., date, user, field. ;;^UTILITY(U,$J,"OPT",1358,25) ;;=5^DIAU ;;^UTILITY(U,$J,"OPT",1358,"U") ;;=DD AUDIT TRAIL PURGE ;;^UTILITY(U,$J,"OPT",1359,0) ;;=DIOTHER^Other Options^^M^^^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1359,1,0) ;;=^^3^3^2960724^^^^ ;;^UTILITY(U,$J,"OPT",1359,1,1,0) ;;=This menu contains a series of menus which lead to enhancements in current ;;^UTILITY(U,$J,"OPT",1359,1,2,0) ;;=and coming versions. These include auditing, filegrams, and FileMan ;;^UTILITY(U,$J,"OPT",1359,1,3,0) ;;=management. ;;^UTILITY(U,$J,"OPT",1359,10,0) ;;=^19.01PI^9^9 ;;^UTILITY(U,$J,"OPT",1359,10,1,0) ;;=1349^^5 ;;^UTILITY(U,$J,"OPT",1359,10,1,"^") ;;=DI MGMT MENU ;;^UTILITY(U,$J,"OPT",1359,10,2,0) ;;=1354^^2 ;;^UTILITY(U,$J,"OPT",1359,10,2,"^") ;;=DIAUDIT ;;^UTILITY(U,$J,"OPT",1359,10,3,0) ;;=1334^^4 ;;^UTILITY(U,$J,"OPT",1359,10,3,"^") ;;=DISTATISTICS ;;^UTILITY(U,$J,"OPT",1359,10,4,0) ;;=1368^^1 ;;^UTILITY(U,$J,"OPT",1359,10,4,"^") ;;=DIFG ;;^UTILITY(U,$J,"OPT",1359,10,5,0) ;;=1361^^3 ;;^UTILITY(U,$J,"OPT",1359,10,5,"^") ;;=DDS SCREEN MENU ;;^UTILITY(U,$J,"OPT",1359,10,6,0) ;;=1380^^6 ;;^UTILITY(U,$J,"OPT",1359,10,6,"^") ;;=DDXP EXPORT MENU ;;^UTILITY(U,$J,"OPT",1359,10,7,0) ;;=1381^^7 ;;^UTILITY(U,$J,"OPT",1359,10,7,"^") ;;=DIAX EXTRACT MENU ;;^UTILITY(U,$J,"OPT",1359,10,8,0) ;;=1393^^9 ;;^UTILITY(U,$J,"OPT",1359,10,8,"^") ;;=DDBROWSER ;;^UTILITY(U,$J,"OPT",1359,10,9,0) ;;=7716^^8 ;;^UTILITY(U,$J,"OPT",1359,10,9,"^") ;;=DDMP IMPORT ;;^UTILITY(U,$J,"OPT",1359,99) ;;=62849,43060 ;;^UTILITY(U,$J,"OPT",1359,"U") ;;=OTHER OPTIONS ;;^UTILITY(U,$J,"OPT",1360,0) ;;=DDS EDIT/CREATE A FORM^Edit/Create a Form^^R^^^^^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1360,1,0) ;;=^^2^2^2940630^ ;;^UTILITY(U,$J,"OPT",1360,1,1,0) ;;=An option for editing and creating ScreenMan Forms. This option calls the ;;^UTILITY(U,$J,"OPT",1360,1,2,0) ;;=Form Editor. ;;^UTILITY(U,$J,"OPT",1360,20) ;;= ;;^UTILITY(U,$J,"OPT",1360,25) ;;=DDGF ;;^UTILITY(U,$J,"OPT",1360,99) ;;=54872,31063 ;;^UTILITY(U,$J,"OPT",1360,"U") ;;=EDIT/CREATE A FORM ;;^UTILITY(U,$J,"OPT",1361,0) ;;=DDS SCREEN MENU^ScreenMan^^M^^XUSCREENMAN^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1361,10,0) ;;=^19.01PI^4^4 ;;^UTILITY(U,$J,"OPT",1361,10,1,0) ;;=1360^^1^Enter/Edit Screen Definition ;;^UTILITY(U,$J,"OPT",1361,10,1,"^") ;;=DDS EDIT/CREATE A FORM ;;^UTILITY(U,$J,"OPT",1361,10,2,0) ;;=1374^^2 ;;^UTILITY(U,$J,"OPT",1361,10,2,"^") ;;=DDS RUN A FORM ;;^UTILITY(U,$J,"OPT",1361,10,3,0) ;;=1394^^3 ;;^UTILITY(U,$J,"OPT",1361,10,3,"^") ;;=DDS DELETE A FORM ;;^UTILITY(U,$J,"OPT",1361,10,4,0) ;;=1395^^4 ;;^UTILITY(U,$J,"OPT",1361,10,4,"^") ;;=DDS PURGE UNUSED BLOCKS ;;^UTILITY(U,$J,"OPT",1361,99) ;;=62819,35304 ;;^UTILITY(U,$J,"OPT",1361,"U") ;;=SCREENMAN ;;^UTILITY(U,$J,"OPT",1362,0) ;;=DIFG CREATE^Create/Edit Filegram Template^^A^^XUFILEGRAM^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1362,1,0) ;;=^^4^4^2900124^ ;;^UTILITY(U,$J,"OPT",1362,1,1,0) ;;=Use this option to create a filegram template or edit an existing ;;^UTILITY(U,$J,"OPT",1362,1,2,0) ;;=filegram template. This option is the first step in developing a ;;^UTILITY(U,$J,"OPT",1362,1,3,0) ;;=filegram and is very important since there won't be filegrams without ;;^UTILITY(U,$J,"OPT",1362,1,4,0) ;;=this template. ;;^UTILITY(U,$J,"OPT",1362,20) ;;=S DI=1 D EN^DIFGO ;;^UTILITY(U,$J,"OPT",1362,"U") ;;=CREATE/EDIT FILEGRAM TEMPLATE ;;^UTILITY(U,$J,"OPT",1363,0) ;;=DIFG DISPLAY^Display Filegram Template^^A^^XUFILEGRAM^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1363,1,0) ;;=^^2^2^2900124^ ;;^UTILITY(U,$J,"OPT",1363,1,1,0) ;;=Use this option to display the filegram template in a two-column ;;^UTILITY(U,$J,"OPT",1363,1,2,0) ;;=format (similar to FileMan's Inquire to File Entries option). ;;^UTILITY(U,$J,"OPT",1363,20) ;;=S DI=2 D EN^DIFGO ;;^UTILITY(U,$J,"OPT",1363,"U") ;;=DISPLAY FILEGRAM TEMPLATE ;;^UTILITY(U,$J,"OPT",1364,0) ;;=DIFG GENERATE^Generate Filegram^^A^^XUFILEGRAM^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1364,1,0) ;;=^^3^3^2900124^ ;;^UTILITY(U,$J,"OPT",1364,1,1,0) ;;=Use this option to generate a filegram into a MailMan message after ;;^UTILITY(U,$J,"OPT",1364,1,2,0) ;;=selecting the file, filegram template and an entry. It's a good idea ;;^UTILITY(U,$J,"OPT",1364,1,3,0) ;;=to know that information before using this option. ;;^UTILITY(U,$J,"OPT",1364,20) ;;=S DI=3 D EN^DIFGO ;;^UTILITY(U,$J,"OPT",1364,"U") ;;=GENERATE FILEGRAM ;;^UTILITY(U,$J,"OPT",1365,0) ;;=DIFG VIEW^View Filegram^^A^^^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1365,1,0) ;;=^^1^1^2900124^ ;;^UTILITY(U,$J,"OPT",1365,1,1,0) ;;=Use this option to view the filegram in filegram format. ;;^UTILITY(U,$J,"OPT",1365,20) ;;=S DI=4 D EN^DIFGO ;;^UTILITY(U,$J,"OPT",1365,"U") ;;=VIEW FILEGRAM ;;^UTILITY(U,$J,"OPT",1366,0) ;;=DIFG SPECIFIERS^Specifiers^^A^^XUFILEGRAM^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1366,1,0) ;;=^^6^6^2900124^ ;;^UTILITY(U,$J,"OPT",1366,1,1,0) ;;=Use this option to identify a particular field in the file as a ;;^UTILITY(U,$J,"OPT",1366,1,2,0) ;;=reference point for FileMan to use when installing the filegram. ;;^UTILITY(U,$J,"OPT",1366,1,3,0) ;;= ;;^UTILITY(U,$J,"OPT",1366,1,4,0) ;;=Specifiers can be compared to FileMan's identifier, unlike identifiers ;;^UTILITY(U,$J,"OPT",1366,1,5,0) ;;=which are used for interaction purposes...specifiers are used for ;;^UTILITY(U,$J,"OPT",1366,1,6,0) ;;=transaction purposes. ;;^UTILITY(U,$J,"OPT",1366,20) ;;=S DI=5 D EN^DIFGO ;;^UTILITY(U,$J,"OPT",1366,"U") ;;=SPECIFIERS ;;^UTILITY(U,$J,"OPT",1367,0) ;;=DIFG INSTALL^Install/Verify Filegram^^A^^XUFILEGRAM^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1367,1,0) ;;=^^2^2^2900124^^ ;;^UTILITY(U,$J,"OPT",1367,1,1,0) ;;=Use this option to install the filegram in a FileMan file ;;^UTILITY(U,$J,"OPT",1367,1,2,0) ;;=from a MailMan message format. A message of verification should return. ;;^UTILITY(U,$J,"OPT",1367,20) ;;=S DI=6 D EN^DIFGO ;;^UTILITY(U,$J,"OPT",1367,"U") ;;=INSTALL/VERIFY FILEGRAM ;;^UTILITY(U,$J,"OPT",1368,0) ;;=DIFG^Filegrams^^M^^XUFILEGRAM^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1368,1,0) ;;=^^1^1^2900124^^^ ;;^UTILITY(U,$J,"OPT",1368,1,1,0) ;;=This is a menu of the Filegram options. ;;^UTILITY(U,$J,"OPT",1368,10,0) ;;=^19.01PI^6^6 ;;^UTILITY(U,$J,"OPT",1368,10,1,0) ;;=1362^^1 ;;^UTILITY(U,$J,"OPT",1368,10,1,"^") ;;=DIFG CREATE ;;^UTILITY(U,$J,"OPT",1368,10,2,0) ;;=1363^^2 ;;^UTILITY(U,$J,"OPT",1368,10,2,"^") ;;=DIFG DISPLAY ;;^UTILITY(U,$J,"OPT",1368,10,3,0) ;;=1364^^3 ;;^UTILITY(U,$J,"OPT",1368,10,3,"^") ;;=DIFG GENERATE ;;^UTILITY(U,$J,"OPT",1368,10,4,0) ;;=1365^^4 ;;^UTILITY(U,$J,"OPT",1368,10,4,"^") ;;=DIFG VIEW ;;^UTILITY(U,$J,"OPT",1368,10,5,0) ;;=1366^^5 ;;^UTILITY(U,$J,"OPT",1368,10,5,"^") ;;=DIFG SPECIFIERS ;;^UTILITY(U,$J,"OPT",1368,10,6,0) ;;=1367^^6 ;;^UTILITY(U,$J,"OPT",1368,10,6,"^") ;;=DIFG INSTALL ;;^UTILITY(U,$J,"OPT",1368,99) ;;=62819,35306 ;;^UTILITY(U,$J,"OPT",1368,99.1) ;;=54674,36753 ;;^UTILITY(U,$J,"OPT",1368,"U") ;;=FILEGRAMS ;;^UTILITY(U,$J,"OPT",1369,0) ;;=DIFIELD CHECK^Mandatory/Required Field Check^^A^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",1369,1,0) ;;=^^1^1^2901205^ ;;^UTILITY(U,$J,"OPT",1369,1,1,0) ;;=Kernel option to emulate the VA FileMan option to check fields for required data. ;;^UTILITY(U,$J,"OPT",1369,20) ;;=S DI=10 G EN^DIU ;;^UTILITY(U,$J,"OPT",1369,"U") ;;=MANDATORY/REQUIRED FIELD CHECK ;;^UTILITY(U,$J,"OPT",1370,0) ;;=DIAUDIT TURN ON/OFF^Turn Data Audit On/Off^^R^^^^^^^^VA FILEMAN ;;^UTILITY(U,$J,"OPT",1370,1,0) ;;=^^4^4^3130126^ ;;^UTILITY(U,$J,"OPT",1370,1,1,0) ;;=This option lets the user start or stop an audit on a particular data ;;^UTILITY(U,$J,"OPT",1370,1,2,0) ;;=field. The user must have audit access to the file to turn an audit on or ;;^UTILITY(U,$J,"OPT",1370,1,3,0) ;;=off. No other attributes in the field definition can be affected by this ;;^UTILITY(U,$J,"OPT",1370,1,4,0) ;;=option. ;;^UTILITY(U,$J,"OPT",1370,25) ;;=2^DIAU ;;^UTILITY(U,$J,"OPT",1370,"U") ;;=TURN DATA AUDIT ON/OFF ;;^UTILITY(U,$J,"OPT",1371,0) ;;=DIWF^Forms Print^^R^^^^^^^^ DIINI003 DIINI003 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"OPT",1371,1,0) ;;=^^7^7^2901206^ ;;^UTILITY(U,$J,"OPT",1371,1,1,0) ;;=This VA FileMan routine asks first for a 'document' file, which must be ;;^UTILITY(U,$J,"OPT",1371,1,2,0) ;;=a file that contains a word processing field at the first level. It then ;;^UTILITY(U,$J,"OPT",1371,1,3,0) ;;=asks the user to choose an entry in that file for which the word ;;^UTILITY(U,$J,"OPT",1371,1,4,0) ;;=processing field has some text on file. It then uses that text as a ;;^UTILITY(U,$J,"OPT",1371,1,5,0) ;;='print template' for a file. If the chosen document entry has a pointer ;;^UTILITY(U,$J,"OPT",1371,1,6,0) ;;=to a file, that file is automatically the one from which the printing ;;^UTILITY(U,$J,"OPT",1371,1,7,0) ;;=is done. ;;^UTILITY(U,$J,"OPT",1371,25) ;;=DIWF ;;^UTILITY(U,$J,"OPT",1371,"U") ;;=FORMS PRINT ;;^UTILITY(U,$J,"OPT",1372,0) ;;=DI DDUCHK^Check/Fix DD Structure^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1372,1,0) ;;=^^4^4^2930125^ ;;^UTILITY(U,$J,"OPT",1372,1,1,0) ;;=This option looks at the internal structure of files and subfiles ;;^UTILITY(U,$J,"OPT",1372,1,2,0) ;;=and determines if there are inconsistencies or conflicts between the ;;^UTILITY(U,$J,"OPT",1372,1,3,0) ;;=information in the data dictionary and the structure of the file's global ;;^UTILITY(U,$J,"OPT",1372,1,4,0) ;;=nodes. This option will note them and fix or delete the incorrect nodes. ;;^UTILITY(U,$J,"OPT",1372,25) ;;=DDUCHK ;;^UTILITY(U,$J,"OPT",1372,"U") ;;=CHECK/FIX DD STRUCTURE ;;^UTILITY(U,$J,"OPT",1373,0) ;;=DI DDU^Data Dictionary Utilities^^M^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1373,10,0) ;;=^19.01PI^3^3 ;;^UTILITY(U,$J,"OPT",1373,10,1,0) ;;=1335^^1 ;;^UTILITY(U,$J,"OPT",1373,10,1,"^") ;;=DILIST ;;^UTILITY(U,$J,"OPT",1373,10,2,0) ;;=1338^^2 ;;^UTILITY(U,$J,"OPT",1373,10,2,"^") ;;=DI DDMAP ;;^UTILITY(U,$J,"OPT",1373,10,3,0) ;;=1372^^3 ;;^UTILITY(U,$J,"OPT",1373,10,3,"^") ;;=DI DDUCHK ;;^UTILITY(U,$J,"OPT",1373,99) ;;=62819,35306 ;;^UTILITY(U,$J,"OPT",1373,"U") ;;=DATA DICTIONARY UTILITIES ;;^UTILITY(U,$J,"OPT",1374,0) ;;=DDS RUN A FORM^Run a Form^^A^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",1374,1,0) ;;=^^1^1^2940701^^ ;;^UTILITY(U,$J,"OPT",1374,1,1,0) ;;=Option to run a form. ;;^UTILITY(U,$J,"OPT",1374,20) ;;=D ^DDSRUN ;;^UTILITY(U,$J,"OPT",1374,99.1) ;;=56123,39787 ;;^UTILITY(U,$J,"OPT",1374,"U") ;;=RUN A FORM ;;^UTILITY(U,$J,"OPT",1375,0) ;;=DIFG-SRV-HISTORY^Server to Load a Message into the FG History File^^S^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1375,1,0) ;;=^^2^2^2920420^ ;;^UTILITY(U,$J,"OPT",1375,1,1,0) ;;=This option is a SERVER that will take a message and add it to the ;;^UTILITY(U,$J,"OPT",1375,1,2,0) ;;=Filegram History file so that it can be installed. ;;^UTILITY(U,$J,"OPT",1375,3.91,0) ;;=^19.391^^0 ;;^UTILITY(U,$J,"OPT",1375,25) ;;=HIST^DIFGSRV ;;^UTILITY(U,$J,"OPT",1375,220) ;;=^R^^N^N^N ;;^UTILITY(U,$J,"OPT",1375,"U") ;;=SERVER TO LOAD A MESSAGE INTO ;;^UTILITY(U,$J,"OPT",1376,0) ;;=DDXP DEFINE FORMAT^Define Foreign File Format^^A^^DDXP-DEFINE^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",1376,1,0) ;;=^^5^5^2930108^ ;;^UTILITY(U,$J,"OPT",1376,1,1,0) ;;=Use this option to define formats. Formats are entries in the Foreign ;;^UTILITY(U,$J,"OPT",1376,1,2,0) ;;=Format file. They are used to control the exporting of data to a ;;^UTILITY(U,$J,"OPT",1376,1,3,0) ;;=non-MUMPS application. You can alter an existing format only before it has ;;^UTILITY(U,$J,"OPT",1376,1,4,0) ;;=been used to create an Export template. After it has been used, you can ;;^UTILITY(U,$J,"OPT",1376,1,5,0) ;;=clone a format. This option is locked with the DDXP-DEFINE key. ;;^UTILITY(U,$J,"OPT",1376,20) ;;=D 1^DDXP ;;^UTILITY(U,$J,"OPT",1376,"U") ;;=DEFINE FOREIGN FILE FORMAT ;;^UTILITY(U,$J,"OPT",1377,0) ;;=DDXP SELECT EXPORT FIELDS^Select Fields for Export^^A^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",1377,1,0) ;;=^^1^1^2921207^^ ;;^UTILITY(U,$J,"OPT",1377,1,1,0) ;;=Use this option to choose fields to be exported. ;;^UTILITY(U,$J,"OPT",1377,20) ;;=D 2^DDXP ;;^UTILITY(U,$J,"OPT",1377,"U") ;;=SELECT FIELDS FOR EXPORT ;;^UTILITY(U,$J,"OPT",1378,0) ;;=DDXP CREATE EXPORT TEMPLATE^Create Export Template^^A^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",1378,1,0) ;;=^^2^2^2940519^^^ ;;^UTILITY(U,$J,"OPT",1378,1,1,0) ;;=This option creates an Export template by applying the specifications in a ;;^UTILITY(U,$J,"OPT",1378,1,2,0) ;;=Foreign Format with the fields in a Selected Fields for Export template. ;;^UTILITY(U,$J,"OPT",1378,20) ;;=D 3^DDXP ;;^UTILITY(U,$J,"OPT",1378,"U") ;;=CREATE EXPORT TEMPLATE ;;^UTILITY(U,$J,"OPT",1379,0) ;;=DDXP EXPORT DATA^Export Data^^A^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",1379,1,0) ;;=^^4^4^2921207^^ ;;^UTILITY(U,$J,"OPT",1379,1,1,0) ;;=This option sends data to a specified device for export to a foreign ;;^UTILITY(U,$J,"OPT",1379,1,2,0) ;;=application. You have the opportunity to choose entries for export with ;;^UTILITY(U,$J,"OPT",1379,1,3,0) ;;=VA FileMan's Search dialogue. You use an Export template to control the ;;^UTILITY(U,$J,"OPT",1379,1,4,0) ;;=export. ;;^UTILITY(U,$J,"OPT",1379,20) ;;=D 4^DDXP ;;^UTILITY(U,$J,"OPT",1379,"U") ;;=EXPORT DATA ;;^UTILITY(U,$J,"OPT",1380,0) ;;=DDXP EXPORT MENU^Data Export to Foreign Format^^M^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1380,1,0) ;;=^^1^1^2960722^^ ;;^UTILITY(U,$J,"OPT",1380,1,1,0) ;;=Submenu for the Export tool. ;;^UTILITY(U,$J,"OPT",1380,10,0) ;;=^19.01PI^5^5 ;;^UTILITY(U,$J,"OPT",1380,10,1,0) ;;=1376^^1 ;;^UTILITY(U,$J,"OPT",1380,10,1,"^") ;;=DDXP DEFINE FORMAT ;;^UTILITY(U,$J,"OPT",1380,10,2,0) ;;=1377^^2 ;;^UTILITY(U,$J,"OPT",1380,10,2,"^") ;;=DDXP SELECT EXPORT FIELDS ;;^UTILITY(U,$J,"OPT",1380,10,3,0) ;;=1378^^3 ;;^UTILITY(U,$J,"OPT",1380,10,3,"^") ;;=DDXP CREATE EXPORT TEMPLATE ;;^UTILITY(U,$J,"OPT",1380,10,4,0) ;;=1379^^4 ;;^UTILITY(U,$J,"OPT",1380,10,4,"^") ;;=DDXP EXPORT DATA ;;^UTILITY(U,$J,"OPT",1380,10,5,0) ;;=1391^^5 ;;^UTILITY(U,$J,"OPT",1380,10,5,"^") ;;=DDXP FORMAT DOCUMENTATION ;;^UTILITY(U,$J,"OPT",1380,99) ;;=62819,35304 ;;^UTILITY(U,$J,"OPT",1380,"U") ;;=DATA EXPORT TO FOREIGN FORMAT ;;^UTILITY(U,$J,"OPT",1381,0) ;;=DIAX EXTRACT MENU^Extract Data To Fileman File^^M^^DIEXTRACT^^^^^^^^^1^^ ;;^UTILITY(U,$J,"OPT",1381,1,0) ;;=^^2^2^2921222^^^^ ;;^UTILITY(U,$J,"OPT",1381,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1381,1,2,0) ;;=This is a menu of the tool for extracting data to Fileman file. ;;^UTILITY(U,$J,"OPT",1381,10,0) ;;=^19.01PI^9^9 ;;^UTILITY(U,$J,"OPT",1381,10,1,0) ;;=1382^^1 ;;^UTILITY(U,$J,"OPT",1381,10,1,"^") ;;=DIAX SELECT ;;^UTILITY(U,$J,"OPT",1381,10,2,0) ;;=1383^^2 ;;^UTILITY(U,$J,"OPT",1381,10,2,"^") ;;=DIAX ADD/DELETE ;;^UTILITY(U,$J,"OPT",1381,10,3,0) ;;=1384^^3 ;;^UTILITY(U,$J,"OPT",1381,10,3,"^") ;;=DIAX PRINT ;;^UTILITY(U,$J,"OPT",1381,10,4,0) ;;=1385^^4 ;;^UTILITY(U,$J,"OPT",1381,10,4,"^") ;;=DIAX MODIFY ;;^UTILITY(U,$J,"OPT",1381,10,5,0) ;;=1386^^5 ;;^UTILITY(U,$J,"OPT",1381,10,5,"^") ;;=DIAX CREATE ;;^UTILITY(U,$J,"OPT",1381,10,6,0) ;;=1387^^6 ;;^UTILITY(U,$J,"OPT",1381,10,6,"^") ;;=DIAX UPDATE ;;^UTILITY(U,$J,"OPT",1381,10,7,0) ;;=1388^^7 ;;^UTILITY(U,$J,"OPT",1381,10,7,"^") ;;=DIAX PURGE ;;^UTILITY(U,$J,"OPT",1381,10,8,0) ;;=1389^^7 ;;^UTILITY(U,$J,"OPT",1381,10,8,"^") ;;=DIAX CANCEL ;;^UTILITY(U,$J,"OPT",1381,10,9,0) ;;=1390^^8 ;;^UTILITY(U,$J,"OPT",1381,10,9,"^") ;;=DIAX VALIDATE ;;^UTILITY(U,$J,"OPT",1381,15) ;;=K DIAX ;;^UTILITY(U,$J,"OPT",1381,99) ;;=62819,35305 ;;^UTILITY(U,$J,"OPT",1381,"U") ;;=EXTRACT DATA TO FILEMAN FILE ;;^UTILITY(U,$J,"OPT",1382,0) ;;=DIAX SELECT^Select Entries to Extract^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1382,1,0) ;;=^^5^5^2921222^ ;;^UTILITY(U,$J,"OPT",1382,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1382,1,2,0) ;;=Use this option to specify the criteria that would select Fileman entries ;;^UTILITY(U,$J,"OPT",1382,1,3,0) ;;=to extract. This is the first step in developing an extract activity and ;;^UTILITY(U,$J,"OPT",1382,1,4,0) ;;=is important since there cannot be any extract process without the search ;;^UTILITY(U,$J,"OPT",1382,1,5,0) ;;=template created in this option. ;;^UTILITY(U,$J,"OPT",1382,20) ;;=S DI=1 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1382,"U") ;;=SELECT ENTRIES TO EXTRACT ;;^UTILITY(U,$J,"OPT",1383,0) ;;=DIAX ADD/DELETE^Add/Delete Selected Entries^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1383,1,0) ;;=^^3^3^2921222^ ;;^UTILITY(U,$J,"OPT",1383,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1383,1,2,0) ;;=Use this option to edit the list of selected entries to extract by adding ;;^UTILITY(U,$J,"OPT",1383,1,3,0) ;;=needed entries or by deleting undesired ones. ;;^UTILITY(U,$J,"OPT",1383,20) ;;=S DI=2 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1383,"U") ;;=ADD/DELETE SELECTED ENTRIES ;;^UTILITY(U,$J,"OPT",1384,0) ;;=DIAX PRINT^Print Selected Entries^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1384,1,0) ;;=^^3^3^2921222^ ;;^UTILITY(U,$J,"OPT",1384,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1384,1,2,0) ;;=Use this option to display the list of entries selected for extract. This ;;^UTILITY(U,$J,"OPT",1384,1,3,0) ;;=option uses the standard VA Fileman interface for printing. ;;^UTILITY(U,$J,"OPT",1384,20) ;;=S DI=3 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1384,"U") ;;=PRINT SELECTED ENTRIES ;;^UTILITY(U,$J,"OPT",1385,0) ;;=DIAX MODIFY^Modify Destination File^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1385,1,0) ;;=^^3^3^2921222^ ;;^UTILITY(U,$J,"OPT",1385,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1385,1,2,0) ;;=Use this option to create a destination file that will hold the data ;;^UTILITY(U,$J,"OPT",1385,1,3,0) ;;=extracted from the source entries. ;;^UTILITY(U,$J,"OPT",1385,20) ;;=S DI=4 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1385,"U") ;;=MODIFY DESTINATION FILE ;;^UTILITY(U,$J,"OPT",1386,0) ;;=DIAX CREATE^Create Extract Template^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1386,1,0) ;;=^^4^4^2930104^ ;;^UTILITY(U,$J,"OPT",1386,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1386,1,2,0) ;;=Use this option to identify the fields to be extracted from the source ;;^UTILITY(U,$J,"OPT",1386,1,3,0) ;;=file and the fields in the destination file where the extracted data will ;;^UTILITY(U,$J,"OPT",1386,1,4,0) ;;=be stored. ;;^UTILITY(U,$J,"OPT",1386,20) ;;=S DI=5 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1386,"U") ;;=CREATE EXTRACT TEMPLATE ;;^UTILITY(U,$J,"OPT",1387,0) ;;=DIAX UPDATE^Update Destination File^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1387,1,0) ;;=^^3^3^2921222^ ;;^UTILITY(U,$J,"OPT",1387,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1387,1,2,0) ;;=Use this option to extract data from the source file and move it to the ;;^UTILITY(U,$J,"OPT",1387,1,3,0) ;;=destination file. ;;^UTILITY(U,$J,"OPT",1387,20) ;;=S DI=6 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1387,"U") ;;=UPDATE DESTINATION FILE ;;^UTILITY(U,$J,"OPT",1388,0) ;;=DIAX PURGE^Purge Extracted Entries^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1388,1,0) ;;=^^2^2^2921222^ ;;^UTILITY(U,$J,"OPT",1388,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1388,1,2,0) ;;=Use this option to delete the extracted data from the primary file. ;;^UTILITY(U,$J,"OPT",1388,20) ;;=S DI=7 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1388,"U") ;;=PURGE EXTRACTED ENTRIES ;;^UTILITY(U,$J,"OPT",1389,0) ;;=DIAX CANCEL^Cancel Extract Selection^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1389,1,0) ;;=^^3^3^2921222^ ;;^UTILITY(U,$J,"OPT",1389,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1389,1,2,0) ;;=Use this option to cancel an extract activity any time before the selected ;;^UTILITY(U,$J,"OPT",1389,1,3,0) ;;=entries in the primary file are purged. ;;^UTILITY(U,$J,"OPT",1389,20) ;;=S DI=8 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1389,"U") ;;=CANCEL EXTRACT SELECTION ;;^UTILITY(U,$J,"OPT",1390,0) ;;=DIAX VALIDATE^Validate Extract Template^^A^^DIEXTRACT^^^^^^^^1^^^ ;;^UTILITY(U,$J,"OPT",1390,1,0) ;;=^^3^3^2930104^ ;;^UTILITY(U,$J,"OPT",1390,1,1,0) ;;= ;;^UTILITY(U,$J,"OPT",1390,1,2,0) ;;=Use this option to verify the compatibility between fields to be extracted ;;^UTILITY(U,$J,"OPT",1390,1,3,0) ;;=and their corresponding destination fields in the destination file. ;;^UTILITY(U,$J,"OPT",1390,20) ;;=S DI=9 D EN^DIAX ;;^UTILITY(U,$J,"OPT",1390,"U") ;;=VALIDATE EXTRACT TEMPLATE ;;^UTILITY(U,$J,"OPT",1391,0) ;;=DDXP FORMAT DOCUMENTATION^Print Format Documentation^^A^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",1391,1,0) ;;=^^2^2^2921207^^ ;;^UTILITY(U,$J,"OPT",1391,1,1,0) ;;=Use this option ot print documentation for existing entries in the Foreign ;;^UTILITY(U,$J,"OPT",1391,1,2,0) ;;=Format file. ;;^UTILITY(U,$J,"OPT",1391,20) ;;=D 5^DDXP ;;^UTILITY(U,$J,"OPT",1391,"U") ;;=PRINT FORMAT DOCUMENTATION ;;^UTILITY(U,$J,"OPT",1392,0) ;;=DI SORT COMPILE^Sort Template Compile/Uncompile^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1392,1,0) ;;=^^3^3^2930715^^ ;;^UTILITY(U,$J,"OPT",1392,1,1,0) ;;=This option allows the user to mark a Sort Template compiled or uncompiled. ;;^UTILITY(U,$J,"OPT",1392,1,2,0) ;;=The actual routine compilation occurs when the template is used during ;;^UTILITY(U,$J,"OPT",1392,1,3,0) ;;=FileMan Sort/Print. ;;^UTILITY(U,$J,"OPT",1392,25) ;;=EN1^DIOZ ;;^UTILITY(U,$J,"OPT",1392,"U") ;;=SORT TEMPLATE COMPILE/UNCOMPIL ;;^UTILITY(U,$J,"OPT",1393,0) ;;=DDBROWSER^Browser^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1393,1,0) ;;=^^3^3^2940519^ ;;^UTILITY(U,$J,"OPT",1393,1,1,0) ;;=Prompts user to select file, word processing field and entry. ;;^UTILITY(U,$J,"OPT",1393,1,2,0) ;;=The text is then displayed to the screen, allowing the user to ;;^UTILITY(U,$J,"OPT",1393,1,3,0) ;;=navigate through the document. ;;^UTILITY(U,$J,"OPT",1393,25) ;;=DDBR ;;^UTILITY(U,$J,"OPT",1393,99.1) ;;=56123,39787 ;;^UTILITY(U,$J,"OPT",1393,"U") ;;=BROWSER ;;^UTILITY(U,$J,"OPT",1394,0) ;;=DDS DELETE A FORM^Delete a Form^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1394,1,0) ;;=^^1^1^2940630^^ ;;^UTILITY(U,$J,"OPT",1394,1,1,0) ;;=An option to delete a form. ;;^UTILITY(U,$J,"OPT",1394,25) ;;=DDSDFRM ;;^UTILITY(U,$J,"OPT",1394,99.1) ;;=56123,39787 DIINI004 DIINI004 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"OPT",1394,"U") ;;=DELETE A FORM ;;^UTILITY(U,$J,"OPT",1395,0) ;;=DDS PURGE UNUSED BLOCKS^Purge Unused Blocks^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",1395,1,0) ;;=^^3^3^2940630^ ;;^UTILITY(U,$J,"OPT",1395,1,1,0) ;;=An option to delete blocks that aren't used on any forms. This option ;;^UTILITY(U,$J,"OPT",1395,1,2,0) ;;=prompts for file, and searches the Block File for all blocks that are ;;^UTILITY(U,$J,"OPT",1395,1,3,0) ;;=associated with that file and that aren't used on any forms. ;;^UTILITY(U,$J,"OPT",1395,25) ;;=DDSDBLK ;;^UTILITY(U,$J,"OPT",1395,99.1) ;;=56123,39787 ;;^UTILITY(U,$J,"OPT",1395,"U") ;;=PURGE UNUSED BLOCKS ;;^UTILITY(U,$J,"OPT",7716,0) ;;=DDMP IMPORT^Import Data^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",7716,1,0) ;;=^^2^2^2960724^^^^ ;;^UTILITY(U,$J,"OPT",7716,1,1,0) ;;=This option gathers specification from the user for the import of data from ;;^UTILITY(U,$J,"OPT",7716,1,2,0) ;;=a host ascii file. The import is done and a report generated. ;;^UTILITY(U,$J,"OPT",7716,25) ;;=EN^DDMPU ;;^UTILITY(U,$J,"OPT",7716,"U") ;;=IMPORT DATA ;;^UTILITY(U,$J,"OPT",8012,0) ;;=DMSQ PROJECT^Regenerate SQLI Projection^^R^^XUPROGMODE^^^^^^VA FILEMAN^^1^1 ;;^UTILITY(U,$J,"OPT",8012,1,0) ;;=^^17^17^2971026^^^^ ;;^UTILITY(U,$J,"OPT",8012,1,1,0) ;;=Regenerates the SQLI projection of VA FileMan data dictionaries. The ;;^UTILITY(U,$J,"OPT",8012,1,2,0) ;;=regeneration process: ;;^UTILITY(U,$J,"OPT",8012,1,3,0) ;;= ;;^UTILITY(U,$J,"OPT",8012,1,4,0) ;;= 1. Purges existing information in SQLI data files. ;;^UTILITY(U,$J,"OPT",8012,1,5,0) ;;= 2. Projects the data dictionaries for all VA FileMan files. ;;^UTILITY(U,$J,"OPT",8012,1,6,0) ;;= ;;^UTILITY(U,$J,"OPT",8012,1,7,0) ;;=Before running this option, the SQLI_KEY_WORD file should be populated ;;^UTILITY(U,$J,"OPT",8012,1,8,0) ;;=with all SQL, ODBC, and vendor-specific keywords that should not be used ;;^UTILITY(U,$J,"OPT",8012,1,9,0) ;;=in SQLI entity naming. ;;^UTILITY(U,$J,"OPT",8012,1,10,0) ;;= ;;^UTILITY(U,$J,"OPT",8012,1,11,0) ;;=This option requires programmer mode as well as the progmode key. ;;^UTILITY(U,$J,"OPT",8012,1,12,0) ;;= ;;^UTILITY(U,$J,"OPT",8012,1,13,0) ;;=This option may also be used as a skeleton for one that you may want ;;^UTILITY(U,$J,"OPT",8012,1,14,0) ;;=to create locally. Your local option could include the vendor's ;;^UTILITY(U,$J,"OPT",8012,1,15,0) ;;=keyword call in the Entry Action and the vendor's mapping call in the ;;^UTILITY(U,$J,"OPT",8012,1,16,0) ;;=Exit Action. A status variable could be used to confirm that the ;;^UTILITY(U,$J,"OPT",8012,1,17,0) ;;=SQLI projection completes before the vendor mapping is initiated. ;;^UTILITY(U,$J,"OPT",8012,15) ;;=;vendor's mapper call could go here ;;^UTILITY(U,$J,"OPT",8012,20) ;;=;vendor's keyword call could go here ;;^UTILITY(U,$J,"OPT",8012,25) ;;=SETUP^DMSQ ;;^UTILITY(U,$J,"OPT",8012,200.9) ;;=y ;;^UTILITY(U,$J,"OPT",8012,"U") ;;=REGENERATE SQLI PROJECTION ;;^UTILITY(U,$J,"OPT",8013,0) ;;=DMSQ MENU^SQLI (VA FileMan)^^M^^^^^^^^VA FILEMAN ;;^UTILITY(U,$J,"OPT",8013,1,0) ;;=^^1^1^2970806^^^^ ;;^UTILITY(U,$J,"OPT",8013,1,1,0) ;;=This is the main menu for all VA FileMan SQLI (SQL Interface) options. ;;^UTILITY(U,$J,"OPT",8013,10,0) ;;=^19.01PI^8^7 ;;^UTILITY(U,$J,"OPT",8013,10,1,0) ;;=8012^RUN^10 ;;^UTILITY(U,$J,"OPT",8013,10,1,"^") ;;=DMSQ PROJECT ;;^UTILITY(U,$J,"OPT",8013,10,2,0) ;;=8014^X^30 ;;^UTILITY(U,$J,"OPT",8013,10,2,"^") ;;=DMSQ PURGE ;;^UTILITY(U,$J,"OPT",8013,10,4,0) ;;=8015^ERR^20 ;;^UTILITY(U,$J,"OPT",8013,10,4,"^") ;;=DMSQ PRINT ERRORS ;;^UTILITY(U,$J,"OPT",8013,10,5,0) ;;=8016^CNTS^50 ;;^UTILITY(U,$J,"OPT",8013,10,5,"^") ;;=DMSQ PS MENU ;;^UTILITY(U,$J,"OPT",8013,10,6,0) ;;=8034^DD^40 ;;^UTILITY(U,$J,"OPT",8013,10,6,"^") ;;=DMSQ TS MENU ;;^UTILITY(U,$J,"OPT",8013,10,7,0) ;;=8035^GRP^60 ;;^UTILITY(U,$J,"OPT",8013,10,7,"^") ;;=DMSQ SUGGEST TABLE GROUPINGS ;;^UTILITY(U,$J,"OPT",8013,10,8,0) ;;=8037^WHY^15 ;;^UTILITY(U,$J,"OPT",8013,10,8,"^") ;;=DMSQ DIAGNOSTICS ;;^UTILITY(U,$J,"OPT",8013,99) ;;=62819,35307 ;;^UTILITY(U,$J,"OPT",8013,99.1) ;;=57215,42037 ;;^UTILITY(U,$J,"OPT",8013,"U") ;;=SQLI (VA FILEMAN) ;;^UTILITY(U,$J,"OPT",8014,0) ;;=DMSQ PURGE^Purge SQLI Data^^R^^XUPROGMODE^^^^^^VA FILEMAN ;;^UTILITY(U,$J,"OPT",8014,1,0) ;;=^^23^23^2970806^^^^ ;;^UTILITY(U,$J,"OPT",8014,1,1,0) ;;=This option purges the SQLI projection of VA FileMan data dictionaries. ;;^UTILITY(U,$J,"OPT",8014,1,2,0) ;;=Use this option if you have previously projected your VA FileMan data ;;^UTILITY(U,$J,"OPT",8014,1,3,0) ;;=dictionaries for use by an M-to-SQL product, but no longer wish to. All ;;^UTILITY(U,$J,"OPT",8014,1,4,0) ;;=data in the following files are purged: ;;^UTILITY(U,$J,"OPT",8014,1,5,0) ;;= ;;^UTILITY(U,$J,"OPT",8014,1,6,0) ;;= SQLI_COLUMN ;;^UTILITY(U,$J,"OPT",8014,1,7,0) ;;= SQLI_DATA_TYPE ;;^UTILITY(U,$J,"OPT",8014,1,8,0) ;;= SQLI_DOMAIN ;;^UTILITY(U,$J,"OPT",8014,1,9,0) ;;= SQLI_ERROR_LOG ;;^UTILITY(U,$J,"OPT",8014,1,10,0) ;;= SQLI_ERROR_TEXT ;;^UTILITY(U,$J,"OPT",8014,1,11,0) ;;= SQLI_FOREIGN_KEY ;;^UTILITY(U,$J,"OPT",8014,1,12,0) ;;= SQLI_KEY_FORMAT ;;^UTILITY(U,$J,"OPT",8014,1,13,0) ;;= SQLI_OUTPUT_FORMAT ;;^UTILITY(U,$J,"OPT",8014,1,14,0) ;;= SQLI_PRIMARY_KEY ;;^UTILITY(U,$J,"OPT",8014,1,15,0) ;;= SQLI_SCHEMA ;;^UTILITY(U,$J,"OPT",8014,1,16,0) ;;= SQLI_TABLE ;;^UTILITY(U,$J,"OPT",8014,1,17,0) ;;= SQLI_TABLE_ELEMENT ;;^UTILITY(U,$J,"OPT",8014,1,18,0) ;;= ;;^UTILITY(U,$J,"OPT",8014,1,19,0) ;;=Data is not purged from the following SQLI file, however: ;;^UTILITY(U,$J,"OPT",8014,1,20,0) ;;= ;;^UTILITY(U,$J,"OPT",8014,1,21,0) ;;= SQLI_KEY_WORD ;;^UTILITY(U,$J,"OPT",8014,1,22,0) ;;= ;;^UTILITY(U,$J,"OPT",8014,1,23,0) ;;=This option requires programmer mode as well as the progmode key. ;;^UTILITY(U,$J,"OPT",8014,25) ;;=PURGE^DMSQ ;;^UTILITY(U,$J,"OPT",8014,99) ;;=57167,30963 ;;^UTILITY(U,$J,"OPT",8014,"U") ;;=PURGE SQLI DATA ;;^UTILITY(U,$J,"OPT",8015,0) ;;=DMSQ PRINT ERRORS^Print Errors from Last Projection^^R^^^^^^^^VA FILEMAN ;;^UTILITY(U,$J,"OPT",8015,1,0) ;;=^^2^2^2970718^^ ;;^UTILITY(U,$J,"OPT",8015,1,1,0) ;;=Lists errors, sorted by category, generated by the most recent SQLI ;;^UTILITY(U,$J,"OPT",8015,1,2,0) ;;=projection run. ;;^UTILITY(U,$J,"OPT",8015,25) ;;=MAIN^DMSQE ;;^UTILITY(U,$J,"OPT",8015,"U") ;;=PRINT ERRORS FROM LAST PROJECT ;;^UTILITY(U,$J,"OPT",8016,0) ;;=DMSQ PS MENU^Site Statistics Reports^^M^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8016,1,0) ;;=^^2^2^2970805^ ;;^UTILITY(U,$J,"OPT",8016,1,1,0) ;;=This is a menu of reports that show counts of tables and columns for ;;^UTILITY(U,$J,"OPT",8016,1,2,0) ;;=this site (where SQLI is installed). ;;^UTILITY(U,$J,"OPT",8016,10,0) ;;=^19.01PI^9^9 ;;^UTILITY(U,$J,"OPT",8016,10,1,0) ;;=8017^TBL^10 ;;^UTILITY(U,$J,"OPT",8016,10,1,"^") ;;=DMSQ PS TOTAL TABLES ;;^UTILITY(U,$J,"OPT",8016,10,2,0) ;;=8018^1C^20 ;;^UTILITY(U,$J,"OPT",8016,10,2,"^") ;;=DMSQ PS TOTAL COLUMNS ;;^UTILITY(U,$J,"OPT",8016,10,3,0) ;;=8019^INDX^30 ;;^UTILITY(U,$J,"OPT",8016,10,3,"^") ;;=DMSQ PS TOTAL INDEXES ;;^UTILITY(U,$J,"OPT",8016,10,4,0) ;;=8020^ELEM^40 ;;^UTILITY(U,$J,"OPT",8016,10,4,"^") ;;=DMSQ PS TOTAL TABLE ELEMENTS ;;^UTILITY(U,$J,"OPT",8016,10,5,0) ;;=8021^2C^50 ;;^UTILITY(U,$J,"OPT",8016,10,5,"^") ;;=DMSQ PS TOTAL TABLE COLS ;;^UTILITY(U,$J,"OPT",8016,10,6,0) ;;=8022^3C^60 ;;^UTILITY(U,$J,"OPT",8016,10,6,"^") ;;=DMSQ PS TOTAL TABLE COLS A ;;^UTILITY(U,$J,"OPT",8016,10,7,0) ;;=8024^FLDS^80 ;;^UTILITY(U,$J,"OPT",8016,10,7,"^") ;;=DMSQ PS COLUMNS REG NOID ;;^UTILITY(U,$J,"OPT",8016,10,8,0) ;;=8023^4C^70 ;;^UTILITY(U,$J,"OPT",8016,10,8,"^") ;;=DMSQ PS TOTAL COLUMNS REG ;;^UTILITY(U,$J,"OPT",8016,10,9,0) ;;=8036^DOM^90 ;;^UTILITY(U,$J,"OPT",8016,10,9,"^") ;;=DMSQ PS COLUMNS BY DOMAIN ;;^UTILITY(U,$J,"OPT",8016,99) ;;=62819,35307 ;;^UTILITY(U,$J,"OPT",8016,"U") ;;=SITE STATISTICS REPORTS ;;^UTILITY(U,$J,"OPT",8017,0) ;;=DMSQ PS TOTAL TABLES^Table Total (Excluding Index Tables)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8017,1,0) ;;=^^4^4^2970805^^ ;;^UTILITY(U,$J,"OPT",8017,1,1,0) ;;=This report comes back with one number, the total number of tables, not ;;^UTILITY(U,$J,"OPT",8017,1,2,0) ;;=counting ones based on indexes. This corresponds with the number of ;;^UTILITY(U,$J,"OPT",8017,1,3,0) ;;=files and subfiles, with word-processing fields also projected as separate ;;^UTILITY(U,$J,"OPT",8017,1,4,0) ;;=tables (just as subfiles). ;;^UTILITY(U,$J,"OPT",8017,25) ;;=EN1^DMSQP1 ;;^UTILITY(U,$J,"OPT",8017,"U") ;;=TABLE TOTAL (EXCLUDING INDEX T ;;^UTILITY(U,$J,"OPT",8018,0) ;;=DMSQ PS TOTAL COLUMNS^Column Total (All Tables)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8018,1,0) ;;=^^3^3^2970805^^ ;;^UTILITY(U,$J,"OPT",8018,1,1,0) ;;=This report calculates one number, the total number of columns in the ;;^UTILITY(U,$J,"OPT",8018,1,2,0) ;;=SQLI Column file. This includes columns from tables based on indexes ;;^UTILITY(U,$J,"OPT",8018,1,3,0) ;;=as well as columns automatically created internal record numbers. ;;^UTILITY(U,$J,"OPT",8018,25) ;;=EN2^DMSQP1 ;;^UTILITY(U,$J,"OPT",8018,"U") ;;=COLUMN TOTAL (ALL TABLES) ;;^UTILITY(U,$J,"OPT",8019,0) ;;=DMSQ PS TOTAL INDEXES^Index Table Total^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8019,1,0) ;;=^^3^3^2970805^^ ;;^UTILITY(U,$J,"OPT",8019,1,1,0) ;;=This report shows one number, the total number of tables that are ;;^UTILITY(U,$J,"OPT",8019,1,2,0) ;;=built from indexes. (All regular cross-references, either for files ;;^UTILITY(U,$J,"OPT",8019,1,3,0) ;;=or subfiles, are projected as tables.) ;;^UTILITY(U,$J,"OPT",8019,25) ;;=EN3^DMSQP1 ;;^UTILITY(U,$J,"OPT",8019,"U") ;;=INDEX TABLE TOTAL ;;^UTILITY(U,$J,"OPT",8020,0) ;;=DMSQ PS TOTAL TABLE ELEMENTS^Table Element Totals, By Type^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8020,1,0) ;;=^^3^3^2970805^^ ;;^UTILITY(U,$J,"OPT",8020,1,1,0) ;;=This report shows the total number of table elements along with ;;^UTILITY(U,$J,"OPT",8020,1,2,0) ;;=subtotals for the three types: columns, foreign keys, and primary ;;^UTILITY(U,$J,"OPT",8020,1,3,0) ;;=keys. ;;^UTILITY(U,$J,"OPT",8020,25) ;;=EN4^DMSQP1 ;;^UTILITY(U,$J,"OPT",8020,"U") ;;=TABLE ELEMENT TOTALS, BY TYPE ;;^UTILITY(U,$J,"OPT",8021,0) ;;=DMSQ PS TOTAL TABLE COLS^Column Totals, by Table^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8021,1,0) ;;=^^3^3^2970805^^ ;;^UTILITY(U,$J,"OPT",8021,1,1,0) ;;=This is a long listing of all tables along with a count of the number ;;^UTILITY(U,$J,"OPT",8021,1,2,0) ;;=of columns in each one. It is sorted by the file/subfile number ;;^UTILITY(U,$J,"OPT",8021,1,3,0) ;;=associated with the table. ;;^UTILITY(U,$J,"OPT",8021,25) ;;=EN5^DMSQP1 ;;^UTILITY(U,$J,"OPT",8021,"U") ;;=COLUMN TOTALS, BY TABLE ;;^UTILITY(U,$J,"OPT",8022,0) ;;=DMSQ PS TOTAL TABLE COLS A^Column Totals, by Table (Ordered by # of Columns)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8022,1,0) ;;=^^3^3^2970805^^ ;;^UTILITY(U,$J,"OPT",8022,1,1,0) ;;=This is a listing of tables by column count. It shows the table with ;;^UTILITY(U,$J,"OPT",8022,1,2,0) ;;=the most columns first, so you can easily see which tables have the ;;^UTILITY(U,$J,"OPT",8022,1,3,0) ;;=most columns. ;;^UTILITY(U,$J,"OPT",8022,25) ;;=EN6^DMSQP1 ;;^UTILITY(U,$J,"OPT",8022,"U") ;;=COLUMN TOTALS, BY TABLE (ORDER ;;^UTILITY(U,$J,"OPT",8023,0) ;;=DMSQ PS TOTAL COLUMNS REG^Columns in Regular Tables Total^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8023,1,0) ;;=^^2^2^2970805^^ ;;^UTILITY(U,$J,"OPT",8023,1,1,0) ;;=This report shows one number, the number of columns based on regular ;;^UTILITY(U,$J,"OPT",8023,1,2,0) ;;=tables. It excludes columns based on tables created from indexes. ;;^UTILITY(U,$J,"OPT",8023,25) ;;=EN7^DMSQP1 ;;^UTILITY(U,$J,"OPT",8023,"U") ;;=COLUMNS IN REGULAR TABLES TOTA ;;^UTILITY(U,$J,"OPT",8024,0) ;;=DMSQ PS COLUMNS REG NOID^Columns in Regular Tables, Excluding ID Columns^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8024,1,0) ;;=^^7^7^2970805^^ ;;^UTILITY(U,$J,"OPT",8024,1,1,0) ;;=This report shows one number, the number of columns that correspond ;;^UTILITY(U,$J,"OPT",8024,1,2,0) ;;=with regular fields in files. It excludes columns based on tables ;;^UTILITY(U,$J,"OPT",8024,1,3,0) ;;=created from indexes. It also excludes the automatically created ;;^UTILITY(U,$J,"OPT",8024,1,4,0) ;;=columns based on the internal entry numbers of files and subfiles. ;;^UTILITY(U,$J,"OPT",8024,1,5,0) ;;= ;;^UTILITY(U,$J,"OPT",8024,1,6,0) ;;=It is the number of fields in the FileMan database, assuming all files ;;^UTILITY(U,$J,"OPT",8024,1,7,0) ;;=have been projected as tables. ;;^UTILITY(U,$J,"OPT",8024,25) ;;=EN8^DMSQP1 ;;^UTILITY(U,$J,"OPT",8024,"U") ;;=COLUMNS IN REGULAR TABLES, EXC ;;^UTILITY(U,$J,"OPT",8025,0) ;;=DMSQ TS PTR PARENT BRIEF^List Pointer and Parent Links (Brief)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8025,1,0) ;;=^^4^4^2970805^^ ;;^UTILITY(U,$J,"OPT",8025,1,1,0) ;;=This lists pointed-to files given a file number. The pointed-to files ;;^UTILITY(U,$J,"OPT",8025,1,2,0) ;;=may either be connected via a regular pointer or via a subfile link to ;;^UTILITY(U,$J,"OPT",8025,1,3,0) ;;=a parent file. The list of file numbers may then be used in other ;;^UTILITY(U,$J,"OPT",8025,1,4,0) ;;=options to find out more about the table build from that number. ;;^UTILITY(U,$J,"OPT",8025,25) ;;=EN2^DMSQP2 ;;^UTILITY(U,$J,"OPT",8025,"U") ;;=LIST POINTER AND PARENT LINKS ;;^UTILITY(U,$J,"OPT",8026,0) ;;=DMSQ TS PTR PARENT FULL^List Pointer and Parent Links (Full)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8026,1,0) ;;=^^4^4^2970805^^ ;;^UTILITY(U,$J,"OPT",8026,1,1,0) ;;=This option shows the pointer and subfile links that reach outward from ;;^UTILITY(U,$J,"OPT",8026,1,2,0) ;;=a selected table. Regular pointers (foreign keys or FKs) as well as ;;^UTILITY(U,$J,"OPT",8026,1,3,0) ;;=subfile links out and up to parent files (parent foreign keys or PFKs) ;;^UTILITY(U,$J,"OPT",8026,1,4,0) ;;=are shown. ;;^UTILITY(U,$J,"OPT",8026,25) ;;=EN2^DMSQP DIINI005 DIINI005 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"OPT",8026,"U") ;;=LIST POINTER AND PARENT LINKS ;;^UTILITY(U,$J,"OPT",8027,0) ;;=DMSQ TS SUBFILE BRIEF^List Subfile Links (Brief)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8027,1,0) ;;=^^3^3^2970805^^ ;;^UTILITY(U,$J,"OPT",8027,1,1,0) ;;=This lists subfiles of a selected file number. The subfile numbers are ;;^UTILITY(U,$J,"OPT",8027,1,2,0) ;;=also shown. These number can then be used in other options to find out ;;^UTILITY(U,$J,"OPT",8027,1,3,0) ;;=what foreign keys are in the tables built from these subfiles. ;;^UTILITY(U,$J,"OPT",8027,25) ;;=EN1^DMSQP2 ;;^UTILITY(U,$J,"OPT",8027,"U") ;;=LIST SUBFILE LINKS (BRIEF) ;;^UTILITY(U,$J,"OPT",8028,0) ;;=DMSQ TS PTR SUBFILE FULL^List Incoming Pointer/Subfile Links (Full)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8028,1,0) ;;=^^4^4^2970805^^ ;;^UTILITY(U,$J,"OPT",8028,1,1,0) ;;=This option shows the foreign key names of incoming links, either from ;;^UTILITY(U,$J,"OPT",8028,1,2,0) ;;=pointers or subfile links. It also shows the table that has the link. ;;^UTILITY(U,$J,"OPT",8028,1,3,0) ;;=So, for the selected table, a list of links that exist in other tables ;;^UTILITY(U,$J,"OPT",8028,1,4,0) ;;=can be determined. ;;^UTILITY(U,$J,"OPT",8028,25) ;;=EN1^DMSQP ;;^UTILITY(U,$J,"OPT",8028,"U") ;;=LIST INCOMING POINTER/SUBFILE ;;^UTILITY(U,$J,"OPT",8029,0) ;;=DMSQ TS FIELDS FULL^Field Listing by File (Full)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8029,1,0) ;;=^^14^14^2970805^^ ;;^UTILITY(U,$J,"OPT",8029,1,1,0) ;;=This can be used to see how the fields of a file or subfile were ;;^UTILITY(U,$J,"OPT",8029,1,2,0) ;;=projected as columns in a table. It only shows regular columns. It ;;^UTILITY(U,$J,"OPT",8029,1,3,0) ;;=doesn't include any Table_ID columns, ones automatically created ;;^UTILITY(U,$J,"OPT",8029,1,4,0) ;;=based on the internal entry numbers of the files and subfiles. It also ;;^UTILITY(U,$J,"OPT",8029,1,5,0) ;;=doesn't show foreign keys, links that are automatically created when ;;^UTILITY(U,$J,"OPT",8029,1,6,0) ;;=there's a pointer or subfile connection. (Other options can be used to ;;^UTILITY(U,$J,"OPT",8029,1,7,0) ;;=discover the names of foreign keys.) ;;^UTILITY(U,$J,"OPT",8029,1,8,0) ;;= ;;^UTILITY(U,$J,"OPT",8029,1,9,0) ;;=Don't be surprised when the list of fields seems short. Remember that ;;^UTILITY(U,$J,"OPT",8029,1,10,0) ;;=if there are any subfiles associated with the file name that you entered, ;;^UTILITY(U,$J,"OPT",8029,1,11,0) ;;=there will be separate tables for them. Use the option that shows ;;^UTILITY(U,$J,"OPT",8029,1,12,0) ;;=subfiles to get the numbers to use with this option. That will let you ;;^UTILITY(U,$J,"OPT",8029,1,13,0) ;;=find all the columns associated with the files in a given file and its ;;^UTILITY(U,$J,"OPT",8029,1,14,0) ;;=subfiles. ;;^UTILITY(U,$J,"OPT",8029,25) ;;=EN^DMSQP2 ;;^UTILITY(U,$J,"OPT",8029,"U") ;;=FIELD LISTING BY FILE (FULL) ;;^UTILITY(U,$J,"OPT",8030,0) ;;=DMSQ TS FIELDS BRIEF^Field Listing by File (Brief)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8030,1,0) ;;=^^17^17^2970805^^ ;;^UTILITY(U,$J,"OPT",8030,1,1,0) ;;=This option is like a brief data dictionary listing. Along with the ;;^UTILITY(U,$J,"OPT",8030,1,2,0) ;;=file and field names are the corresponding table and column names. It ;;^UTILITY(U,$J,"OPT",8030,1,3,0) ;;=also shows the field's type, like word-processing or set-of-codes. If ;;^UTILITY(U,$J,"OPT",8030,1,4,0) ;;=the field is a pointer, the pointed-to file/subfile number is shown. If ;;^UTILITY(U,$J,"OPT",8030,1,5,0) ;;=the field is within a subfile, the number of the parent file is shown. ;;^UTILITY(U,$J,"OPT",8030,1,6,0) ;;= ;;^UTILITY(U,$J,"OPT",8030,1,7,0) ;;=In this way, all files and fields can be displayed at one level, without ;;^UTILITY(U,$J,"OPT",8030,1,8,0) ;;=the indentation needed with the usual hierarchical display format. But ;;^UTILITY(U,$J,"OPT",8030,1,9,0) ;;=to find out how files are linked, you may need to follow a long chain ;;^UTILITY(U,$J,"OPT",8030,1,10,0) ;;=from one link to the next. ;;^UTILITY(U,$J,"OPT",8030,1,11,0) ;;= ;;^UTILITY(U,$J,"OPT",8030,1,12,0) ;;=The fields global location is also listed. The $PIECE syntax is used ;;^UTILITY(U,$J,"OPT",8030,1,13,0) ;;=when the field is from a particular piece of a global node. The $EXTRACT ;;^UTILITY(U,$J,"OPT",8030,1,14,0) ;;=format is used when, like for MUMPS-type fields, the location is an ;;^UTILITY(U,$J,"OPT",8030,1,15,0) ;;=extracted portion of the entire node, say from character 1 to 245. For ;;^UTILITY(U,$J,"OPT",8030,1,16,0) ;;=computed fields, of course, there isn't a global location since these are ;;^UTILITY(U,$J,"OPT",8030,1,17,0) ;;=virtual fields that only perform calculations. ;;^UTILITY(U,$J,"OPT",8030,25) ;;=EN^DMSQP5 ;;^UTILITY(U,$J,"OPT",8030,"U") ;;=FIELD LISTING BY FILE (BRIEF) ;;^UTILITY(U,$J,"OPT",8031,0) ;;=DMSQ TS NAMES^Table Name Listing (VA FileMan vs. SQLI)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8031,1,0) ;;=^^4^4^2970805^^ ;;^UTILITY(U,$J,"OPT",8031,1,1,0) ;;=This option lists file/subfile names along with their corresponding ;;^UTILITY(U,$J,"OPT",8031,1,2,0) ;;=table names. The list is sorted by file number and prompts for a ;;^UTILITY(U,$J,"OPT",8031,1,3,0) ;;=range. To see the table names for the files and subfiles of 9.4, the ;;^UTILITY(U,$J,"OPT",8031,1,4,0) ;;=Package file, for example, you could start from 9.4 and go to 9.5. ;;^UTILITY(U,$J,"OPT",8031,25) ;;=EN3^DMSQP2 ;;^UTILITY(U,$J,"OPT",8031,"U") ;;=TABLE NAME LISTING (VA FILEMAN ;;^UTILITY(U,$J,"OPT",8032,0) ;;=DMSQ TS PTR STATS^Pointer Statistics by Individual Table^^R^^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",8032,1,0) ;;=^^6^6^2971019^^^^ ;;^UTILITY(U,$J,"OPT",8032,1,1,0) ;;=This option can be used just to see the total number of various kinds ;;^UTILITY(U,$J,"OPT",8032,1,2,0) ;;=of links for a given table. You can then use these totals to confirm ;;^UTILITY(U,$J,"OPT",8032,1,3,0) ;;=that you have found all the actual foreign key links (FKs and PFKs) ;;^UTILITY(U,$J,"OPT",8032,1,4,0) ;;=by using other options. (The FKs are regular pointers, or foreign ;;^UTILITY(U,$J,"OPT",8032,1,5,0) ;;=keys. The PFKs are subfile links to parent files, or parent foreign ;;^UTILITY(U,$J,"OPT",8032,1,6,0) ;;=keys.) ;;^UTILITY(U,$J,"OPT",8032,15) ;;=S XQMM("N")="" ;;^UTILITY(U,$J,"OPT",8032,25) ;;=EN^DMSQP3 ;;^UTILITY(U,$J,"OPT",8032,"U") ;;=POINTER STATISTICS BY INDIVIDU ;;^UTILITY(U,$J,"OPT",8033,0) ;;=DMSQ TS PTR STATS SUMMARY^Pointer Statistics (Summary)^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8033,1,0) ;;=^^13^13^2970805^^ ;;^UTILITY(U,$J,"OPT",8033,1,1,0) ;;=This report is about all tables and can take a little while to run. If ;;^UTILITY(U,$J,"OPT",8033,1,2,0) ;;=you are interested in finding out how many table links there are among ;;^UTILITY(U,$J,"OPT",8033,1,3,0) ;;=all tables on your system, this option will tell you. It divides up ;;^UTILITY(U,$J,"OPT",8033,1,4,0) ;;=the different types of links with a separate report for each. ;;^UTILITY(U,$J,"OPT",8033,1,5,0) ;;= ;;^UTILITY(U,$J,"OPT",8033,1,6,0) ;;=The five reports that are joined with this option show the number of ;;^UTILITY(U,$J,"OPT",8033,1,7,0) ;;=tables with self-referential pointers, upward links from subfiles, ;;^UTILITY(U,$J,"OPT",8033,1,8,0) ;;=links coming in from subfiles below, pointers going outward, and ;;^UTILITY(U,$J,"OPT",8033,1,9,0) ;;=pointers coming inward. ;;^UTILITY(U,$J,"OPT",8033,1,10,0) ;;= ;;^UTILITY(U,$J,"OPT",8033,1,11,0) ;;=You have a choice of seeing just the total counts or details. Details ;;^UTILITY(U,$J,"OPT",8033,1,12,0) ;;=include table names, so you can find out which ones have the most ;;^UTILITY(U,$J,"OPT",8033,1,13,0) ;;=pointers of a certain type, etc. ;;^UTILITY(U,$J,"OPT",8033,25) ;;=EN1^DMSQP3 ;;^UTILITY(U,$J,"OPT",8033,"U") ;;=POINTER STATISTICS (SUMMARY) ;;^UTILITY(U,$J,"OPT",8034,0) ;;=DMSQ TS MENU^Table Statistics Reports^^M^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8034,1,0) ;;=^^5^5^2970805^^^^ ;;^UTILITY(U,$J,"OPT",8034,1,1,0) ;;=For a given file number, this shows column names in the current table ;;^UTILITY(U,$J,"OPT",8034,1,2,0) ;;=that point to other tables. The column may be based on a regular ;;^UTILITY(U,$J,"OPT",8034,1,3,0) ;;=pointer or on a subfile link to a parent table. (Regular pointers are ;;^UTILITY(U,$J,"OPT",8034,1,4,0) ;;=indicated as FK, foreign keys. Subfile links to parents are identified ;;^UTILITY(U,$J,"OPT",8034,1,5,0) ;;=with PFK, parent foreign keys.) ;;^UTILITY(U,$J,"OPT",8034,10,0) ;;=^19.01PI^9^9 ;;^UTILITY(U,$J,"OPT",8034,10,1,0) ;;=8030^DD1^10 ;;^UTILITY(U,$J,"OPT",8034,10,1,"^") ;;=DMSQ TS FIELDS BRIEF ;;^UTILITY(U,$J,"OPT",8034,10,2,0) ;;=8029^DD2^11 ;;^UTILITY(U,$J,"OPT",8034,10,2,"^") ;;=DMSQ TS FIELDS FULL ;;^UTILITY(U,$J,"OPT",8034,10,3,0) ;;=8031^NAME^50 ;;^UTILITY(U,$J,"OPT",8034,10,3,"^") ;;=DMSQ TS NAMES ;;^UTILITY(U,$J,"OPT",8034,10,4,0) ;;=8025^OUT1^30 ;;^UTILITY(U,$J,"OPT",8034,10,4,"^") ;;=DMSQ TS PTR PARENT BRIEF ;;^UTILITY(U,$J,"OPT",8034,10,5,0) ;;=8026^OUT2^31 ;;^UTILITY(U,$J,"OPT",8034,10,5,"^") ;;=DMSQ TS PTR PARENT FULL ;;^UTILITY(U,$J,"OPT",8034,10,6,0) ;;=8032^CNT1^40 ;;^UTILITY(U,$J,"OPT",8034,10,6,"^") ;;=DMSQ TS PTR STATS ;;^UTILITY(U,$J,"OPT",8034,10,7,0) ;;=8033^CNT2^41 ;;^UTILITY(U,$J,"OPT",8034,10,7,"^") ;;=DMSQ TS PTR STATS SUMMARY ;;^UTILITY(U,$J,"OPT",8034,10,8,0) ;;=8027^IN1^20 ;;^UTILITY(U,$J,"OPT",8034,10,8,"^") ;;=DMSQ TS SUBFILE BRIEF ;;^UTILITY(U,$J,"OPT",8034,10,9,0) ;;=8028^IN2^21 ;;^UTILITY(U,$J,"OPT",8034,10,9,"^") ;;=DMSQ TS PTR SUBFILE FULL ;;^UTILITY(U,$J,"OPT",8034,99) ;;=62819,35308 ;;^UTILITY(U,$J,"OPT",8034,"U") ;;=TABLE STATISTICS REPORTS ;;^UTILITY(U,$J,"OPT",8035,0) ;;=DMSQ SUGGEST TABLE GROUPINGS^Suggest Table Groupings^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8035,1,0) ;;=^^40^40^2971021^^^^ ;;^UTILITY(U,$J,"OPT",8035,1,1,0) ;;=This option can take a few minutes to run. Use it when you have some ;;^UTILITY(U,$J,"OPT",8035,1,2,0) ;;=extra time to explore the sharing relationships among files. With it, ;;^UTILITY(U,$J,"OPT",8035,1,3,0) ;;=though, you can find out which tables are often referenced by others. ;;^UTILITY(U,$J,"OPT",8035,1,4,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,5,0) ;;=You will be prompted for a cutoff point. This is used to subset the ;;^UTILITY(U,$J,"OPT",8035,1,6,0) ;;=resulting groups. If you use a high cutoff, like 150, you will get back ;;^UTILITY(U,$J,"OPT",8035,1,7,0) ;;=a fairly short shared table list, including only those files that have ;;^UTILITY(U,$J,"OPT",8035,1,8,0) ;;=more interconnections that the cutoff, like New Person and Patient. ;;^UTILITY(U,$J,"OPT",8035,1,9,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,10,0) ;;=A cutoff around five might give the most useful subdivisions. That ;;^UTILITY(U,$J,"OPT",8035,1,11,0) ;;=might put 200-300 tables in the shared group, leaving all the other ;;^UTILITY(U,$J,"OPT",8035,1,12,0) ;;=tables in fairly small mutually exclusive groups of 30 or so. This ;;^UTILITY(U,$J,"OPT",8035,1,13,0) ;;=approach ends up with a large number of small tables, though, like around ;;^UTILITY(U,$J,"OPT",8035,1,14,0) ;;=700 or more. ;;^UTILITY(U,$J,"OPT",8035,1,15,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,16,0) ;;=The purpose of this utility is to give you an idea about how to group ;;^UTILITY(U,$J,"OPT",8035,1,17,0) ;;=tables when assigning access to users by profile. If you already had a ;;^UTILITY(U,$J,"OPT",8035,1,18,0) ;;=user profile with access to a set of interrelated tables, you could use ;;^UTILITY(U,$J,"OPT",8035,1,19,0) ;;=the profile for other users who were interested in the same tables. ;;^UTILITY(U,$J,"OPT",8035,1,20,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,21,0) ;;=Note that this utility doesn't list tables without any connection to ;;^UTILITY(U,$J,"OPT",8035,1,22,0) ;;=others (a relatively small set, however!). Also note that the table that ;;^UTILITY(U,$J,"OPT",8035,1,23,0) ;;=has the most sharing activity compared with other members of the group ;;^UTILITY(U,$J,"OPT",8035,1,24,0) ;;=is used to identify the group in this option's printout. ;;^UTILITY(U,$J,"OPT",8035,1,25,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,26,0) ;;=After entering a cutoff, you are prompted for a table of special ;;^UTILITY(U,$J,"OPT",8035,1,27,0) ;;=interest. If you want to see where a particular table ends up in the ;;^UTILITY(U,$J,"OPT",8035,1,28,0) ;;=final analysis, enter it here. As a result, after the shared tables ;;^UTILITY(U,$J,"OPT",8035,1,29,0) ;;=are listed, you will get a special report showing your table and its ;;^UTILITY(U,$J,"OPT",8035,1,30,0) ;;=group. After that, all the groups are listed. ;;^UTILITY(U,$J,"OPT",8035,1,31,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,32,0) ;;=Running this option with several cutoff points might show the following: ;;^UTILITY(U,$J,"OPT",8035,1,33,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,34,0) ;;= Cutoff Total Shared Number of other Groups Member totals ;;^UTILITY(U,$J,"OPT",8035,1,35,0) ;;= ----------------------------------------------------------------- ;;^UTILITY(U,$J,"OPT",8035,1,36,0) ;;= 50 11 227 3391,32... ;;^UTILITY(U,$J,"OPT",8035,1,37,0) ;;= 10 122 534 275,140,112... ;;^UTILITY(U,$J,"OPT",8035,1,38,0) ;;= 5 284 718 34,33,32,32,26... ;;^UTILITY(U,$J,"OPT",8035,1,39,0) ;;= ;;^UTILITY(U,$J,"OPT",8035,1,40,0) ;;=There isn't any right way; just experiment as you wish! ;;^UTILITY(U,$J,"OPT",8035,25) ;;=EN^DMSQP6 ;;^UTILITY(U,$J,"OPT",8035,"U") ;;=SUGGEST TABLE GROUPINGS ;;^UTILITY(U,$J,"OPT",8036,0) ;;=DMSQ PS COLUMNS BY DOMAIN^Columns by Domain^^R^^^^^^^^ ;;^UTILITY(U,$J,"OPT",8036,1,0) ;;=^^19^19^2970806^^ ;;^UTILITY(U,$J,"OPT",8036,1,1,0) ;;=This report counts the number of columns in each domain category, so ;;^UTILITY(U,$J,"OPT",8036,1,2,0) ;;=you can see how many are pointers, dates, or numbers. It only looks at ;;^UTILITY(U,$J,"OPT",8036,1,3,0) ;;=columns from regular (non-index) tables and excludes the automatically DIINI006 DIINI006 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"OPT",8036,1,4,0) ;;=generated Table_ID columns built from internal entry numbers. ;;^UTILITY(U,$J,"OPT",8036,1,5,0) ;;= ;;^UTILITY(U,$J,"OPT",8036,1,6,0) ;;=Here is an example of percentages from a sample account: ;;^UTILITY(U,$J,"OPT",8036,1,7,0) ;;= ;;^UTILITY(U,$J,"OPT",8036,1,8,0) ;;= Ingeger 7499 22.2% ;;^UTILITY(U,$J,"OPT",8036,1,9,0) ;;= Character 10972 32.5% ;;^UTILITY(U,$J,"OPT",8036,1,10,0) ;;= Pointer 4730 14.0% ;;^UTILITY(U,$J,"OPT",8036,1,11,0) ;;= Set-of-Codes 4575 13.5% ;;^UTILITY(U,$J,"OPT",8036,1,12,0) ;;= Number 2429 7.2% ;;^UTILITY(U,$J,"OPT",8036,1,13,0) ;;= Moment 1272 3.8% ;;^UTILITY(U,$J,"OPT",8036,1,14,0) ;;= Date 1393 4.1% ;;^UTILITY(U,$J,"OPT",8036,1,15,0) ;;= Word-processing 687 2.0% ;;^UTILITY(U,$J,"OPT",8036,1,16,0) ;;= MUMPS 180 .5% ;;^UTILITY(U,$J,"OPT",8036,1,17,0) ;;= Variable pointer 58 .2% ;;^UTILITY(U,$J,"OPT",8036,1,18,0) ;;= ;;^UTILITY(U,$J,"OPT",8036,1,19,0) ;;= TOTAL 33795 ;;^UTILITY(U,$J,"OPT",8036,25) ;;=EN9^DMSQP1 ;;^UTILITY(U,$J,"OPT",8036,"U") ;;=COLUMNS BY DOMAIN ;;^UTILITY(U,$J,"OPT",8037,0) ;;=DMSQ DIAGNOSTICS^Find Out SQLI Status^^R^^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",8037,1,0) ;;=^^10^10^2971026^ ;;^UTILITY(U,$J,"OPT",8037,1,1,0) ;;=This option prints a current status report of the SQLI projection ;;^UTILITY(U,$J,"OPT",8037,1,2,0) ;;=process. It indicates when the projection was last run and whether ;;^UTILITY(U,$J,"OPT",8037,1,3,0) ;;=it successfully ran to completion. If problems were encountered and ;;^UTILITY(U,$J,"OPT",8037,1,4,0) ;;=the process stopped, it tries to identify where and list the file ;;^UTILITY(U,$J,"OPT",8037,1,5,0) ;;=or field that might have caused the problem. ;;^UTILITY(U,$J,"OPT",8037,1,6,0) ;;= ;;^UTILITY(U,$J,"OPT",8037,1,7,0) ;;=It is intended as the first step in diagnosing problems (hard errors) ;;^UTILITY(U,$J,"OPT",8037,1,8,0) ;;=that may occur when running the SQLI projection. The SQLI Site Manual ;;^UTILITY(U,$J,"OPT",8037,1,9,0) ;;=outlines additional steps (see the Trouble-Shooting section) including ;;^UTILITY(U,$J,"OPT",8037,1,10,0) ;;=using the RUNONE^DMSQ utility with potential problem files. ;;^UTILITY(U,$J,"OPT",8037,15) ;;=S XQMM("N")="" ;;^UTILITY(U,$J,"OPT",8037,25) ;;=EN^DMSQT ;;^UTILITY(U,$J,"OPT",8037,"U") ;;=FIND OUT SQLI STATUS ;;^UTILITY(U,$J,"OPT",8767,0) ;;=DIKEY^Key Definition^^A^^^^^^^^^^1 ;;^UTILITY(U,$J,"OPT",8767,1,0) ;;=^^3^3^2981020^^ ;;^UTILITY(U,$J,"OPT",8767,1,1,0) ;;=The Key Definition sub-option of the Utility Functions option allows you ;;^UTILITY(U,$J,"OPT",8767,1,2,0) ;;=to create, edit, or delete a Key on a file or subfile. A Key is a group of ;;^UTILITY(U,$J,"OPT",8767,1,3,0) ;;=one or more fields that uniquely identifies a record in a file or subfile. ;;^UTILITY(U,$J,"OPT",8767,20) ;;=S DI=11 D EN^DIU ;;^UTILITY(U,$J,"OPT",8767,"U") ;;=KEY DEFINITION ;;^UTILITY(U,$J,"OPT",11388,0) ;;=DIAUDIT MONITOR USER^Monitor a User^^R^^^^^^^y^VA FILEMAN ;;^UTILITY(U,$J,"OPT",11388,1,0) ;;=^^2^2^3130126^ ;;^UTILITY(U,$J,"OPT",11388,1,1,0) ;;=This option allows tracking of a given user's access to entries in a given ;;^UTILITY(U,$J,"OPT",11388,1,2,0) ;;=(audited) file. Display starts with a selected access date. ;;^UTILITY(U,$J,"OPT",11388,25) ;;=6^DIAU ;;^UTILITY(U,$J,"OPT",11388,"U") ;;=MONITOR A USER ;;^UTILITY(U,$J,"OPT",11392,0) ;;=DMU PRINT FROM 1009.7^DMU PRINT FROM 1009.7^^P^^^^^^^^ ;;^UTILITY(U,$J,"OPT",11392,60) ;;=DMU(1009.7, ;;^UTILITY(U,$J,"OPT",11392,62) ;;=0 ;;^UTILITY(U,$J,"OPT",11392,63) ;;=[DMU PRINT TEMPLATE 1009.7] ;;^UTILITY(U,$J,"OPT",11392,64) ;;= ;;^UTILITY(U,$J,"OPT",11392,65) ;;= ;;^UTILITY(U,$J,"OPT",11392,66) ;;= ;;^UTILITY(U,$J,"OPT",11392,"U") ;;=DMU PRINT FROM 1009.7 ;;^UTILITY(U,$J,"OPT",11393,0) ;;=DMU SORT/PRINT FROM 1009.7^DMU SORT/PRINT FROM 1009.7^^P^^^^^^^^ ;;^UTILITY(U,$J,"OPT",11393,60) ;;=DMU(1009.7, ;;^UTILITY(U,$J,"OPT",11393,62) ;;=0 ;;^UTILITY(U,$J,"OPT",11393,63) ;;=[DMU PRINT TEMPLATE 1009.7] ;;^UTILITY(U,$J,"OPT",11393,64) ;;=[DMU SORT TEMPLATE 1009.7] ;;^UTILITY(U,$J,"OPT",11393,65) ;;= ;;^UTILITY(U,$J,"OPT",11393,66) ;;= ;;^UTILITY(U,$J,"OPT",11393,"U") ;;=DMU SORT/PRINT FROM 1009.7 ;;^UTILITY(U,$J,"OPT",11394,0) ;;=DMU EDIT 1009.7 BOTH FIELDS^DMU EDIT 1009.7 BOTH FIELDS^^E^^^^^^^^ ;;^UTILITY(U,$J,"OPT",11394,30) ;;=DMU(1009.7, ;;^UTILITY(U,$J,"OPT",11394,31) ;;=AEMQL ;;^UTILITY(U,$J,"OPT",11394,50) ;;=DMU(1009.7, ;;^UTILITY(U,$J,"OPT",11394,51) ;;=[DMU EDIT 1009.7] ;;^UTILITY(U,$J,"OPT",11394,"U") ;;=DMU EDIT 1009.7 BOTH FIELDS ;;^UTILITY(U,$J,"OPT",11395,0) ;;=DMU EDIT 1009.7 WITHOUT LAYGO^DMU EDIT 1009.7 WITHOUT LAYGO^^E^^^^^^^^ ;;^UTILITY(U,$J,"OPT",11395,30) ;;=DMU(1009.7, ;;^UTILITY(U,$J,"OPT",11395,31) ;;=AEMQ ;;^UTILITY(U,$J,"OPT",11395,50) ;;=DMU(1009.7, ;;^UTILITY(U,$J,"OPT",11395,51) ;;=[DMU EDIT 1009.7] ;;^UTILITY(U,$J,"OPT",11395,"U") ;;=DMU EDIT 1009.7 WITHOUT LAYGO ;;^UTILITY(U,$J,"OPT",11396,0) ;;=DIAUDIT SHOW DD AUDIT TRAIL^Show DD Audit Trail^^R^^^^^^^^VA FILEMAN ;;^UTILITY(U,$J,"OPT",11396,1,0) ;;=^^1^1^3130126^ ;;^UTILITY(U,$J,"OPT",11396,1,1,0) ;;=This option shows all Data Dictionary changes since a certain date. ;;^UTILITY(U,$J,"OPT",11396,25) ;;=4^DIAU ;;^UTILITY(U,$J,"OPT",11396,"U") ;;=SHOW DD AUDIT TRAIL ;;^UTILITY(U,$J,"REM",139,0) ;;=DDR GETS ENTRY DATA^GETSC^DDR2^2^R ;;^UTILITY(U,$J,"REM",139,1,0) ;;=^^1^1^2951024^^^^ ;;^UTILITY(U,$J,"REM",139,1,1,0) ;;=Calls database server at GETS^DIQ. ;;^UTILITY(U,$J,"REM",139,2,0) ;;=^8994.02A^1^1 ;;^UTILITY(U,$J,"REM",139,2,1,0) ;;=GETS ATTRIBUTES^2^512^1 ;;^UTILITY(U,$J,"REM",139,2,"B","GETS ATTRIBUTES",1) ;;= ;;^UTILITY(U,$J,"REM",140,0) ;;=DDR LISTER^LISTC^DDR^4^R^^^1 ;;^UTILITY(U,$J,"REM",140,2,0) ;;=^8994.02A^1^1 ;;^UTILITY(U,$J,"REM",140,2,1,0) ;;=LIST ATTRIBUTES^2^512^1 ;;^UTILITY(U,$J,"REM",140,2,"B","LIST ATTRIBUTES",1) ;;= ;;^UTILITY(U,$J,"REM",141,0) ;;=DDR FILER^FILEC^DDR3^2^R ;;^UTILITY(U,$J,"REM",141,1,0) ;;=^^1^1^2950508^^ ;;^UTILITY(U,$J,"REM",141,1,1,0) ;;=Generic call to file edits into FM file. ;;^UTILITY(U,$J,"REM",141,2,0) ;;=^8994.02A^2^2 ;;^UTILITY(U,$J,"REM",141,2,1,0) ;;=EDIT RESULTS^2^512^1 ;;^UTILITY(U,$J,"REM",141,2,1,1,0) ;;=^^1^1^2950124^ ;;^UTILITY(U,$J,"REM",141,2,1,1,1,0) ;;=Results of editing to be placed in FDA array by broker. ;;^UTILITY(U,$J,"REM",141,2,2,0) ;;=EDIT MODE^1^3^1 ;;^UTILITY(U,$J,"REM",141,2,2,1,0) ;;=^^1^1^2950508^^ ;;^UTILITY(U,$J,"REM",141,2,2,1,1,0) ;;=Is processing in edit or add data mode. ;;^UTILITY(U,$J,"REM",141,2,"B","EDIT MODE",2) ;;= ;;^UTILITY(U,$J,"REM",141,2,"B","EDIT RESULTS",1) ;;= ;;^UTILITY(U,$J,"REM",141,3,0) ;;=^^2^2^2950508^^ ;;^UTILITY(U,$J,"REM",141,3,1,0) ;;=If file update is successful, then a 1 is returned. A 0 is returned if ;;^UTILITY(U,$J,"REM",141,3,2,0) ;;=unsuccessful. ;;^UTILITY(U,$J,"REM",142,0) ;;=DDR VALIDATOR^VALC^DDR3^2^R ;;^UTILITY(U,$J,"REM",142,1,0) ;;=^^3^3^2970121^^^ ;;^UTILITY(U,$J,"REM",142,1,1,0) ;;=This function allows the application to validate user input to ;;^UTILITY(U,$J,"REM",142,1,2,0) ;;=a field before filing data. The call uses the database server VAL^DIE ;;^UTILITY(U,$J,"REM",142,1,3,0) ;;=call. ;;^UTILITY(U,$J,"REM",142,2,0) ;;=^8994.02A^2^1 ;;^UTILITY(U,$J,"REM",142,2,2,0) ;;=PARAMETERS^2^512^1 ;;^UTILITY(U,$J,"REM",142,2,2,1,0) ;;=^^4^4^2970121^^^ ;;^UTILITY(U,$J,"REM",142,2,2,1,1,0) ;;=This array contains the following parameters necessary to call VAL^DIE: ;;^UTILITY(U,$J,"REM",142,2,2,1,2,0) ;;= - "FILE" - file number ;;^UTILITY(U,$J,"REM",142,2,2,1,3,0) ;;= - "IENS" - internal entry numbers ;;^UTILITY(U,$J,"REM",142,2,2,1,4,0) ;;= - "VALUE" - user input value ;;^UTILITY(U,$J,"REM",142,2,2,1,5,0) ;;= - "VALUE" - user input value ;;^UTILITY(U,$J,"REM",142,2,"B","PARAMETERS",2) ;;= ;;^UTILITY(U,$J,"REM",142,3,0) ;;=^^2^2^2970121^^^ ;;^UTILITY(U,$J,"REM",142,3,1,0) ;;=This call passes back information in the [data] section and ;;^UTILITY(U,$J,"REM",142,3,2,0) ;;=the [errors] section. ;;^UTILITY(U,$J,"REM",143,0) ;;=DDR DELETE ENTRY^DIKC^DDR1^1^R ;;^UTILITY(U,$J,"REM",143,1,0) ;;=^^1^1^2970912^^^^ ;;^UTILITY(U,$J,"REM",143,1,1,0) ;;=This function deletes an entry in a FileMan file using ^DIK. ;;^UTILITY(U,$J,"REM",143,2,0) ;;=^8994.02A^1^1 ;;^UTILITY(U,$J,"REM",143,2,1,0) ;;=PARAMETERS^2^512^1 ;;^UTILITY(U,$J,"REM",143,2,1,1,0) ;;=^^3^3^2970814^^ ;;^UTILITY(U,$J,"REM",143,2,1,1,1,0) ;;=This array contains the following parameters necessary to call ^DIK. ;;^UTILITY(U,$J,"REM",143,2,1,1,2,0) ;;= "ROOT" global root of file or subfile ;;^UTILITY(U,$J,"REM",143,2,1,1,3,0) ;;= "IEN" internal entry number of record to be deleted in IENS format ;;^UTILITY(U,$J,"REM",143,2,"B","PARAMETERS",1) ;;= ;;^UTILITY(U,$J,"REM",143,3,0) ;;=^^1^1^2970108^ ;;^UTILITY(U,$J,"REM",143,3,1,0) ;;=This parameter returns 1 if record was deleted else it returns 0. ;;^UTILITY(U,$J,"REM",144,0) ;;=DDR LOCK/UNLOCK NODE^LOCKC^DDR1^1^R ;;^UTILITY(U,$J,"REM",144,1,0) ;;=^^3^3^2970110^^^ ;;^UTILITY(U,$J,"REM",144,1,1,0) ;;=This function will lock or unlock an M global node. Also, ;;^UTILITY(U,$J,"REM",144,1,2,0) ;;=this function allows the calling application to specify the ;;^UTILITY(U,$J,"REM",144,1,3,0) ;;=timeout (in seconds) for a 'lock' command. ;;^UTILITY(U,$J,"REM",144,2,0) ;;=^8994.02A^1^1 ;;^UTILITY(U,$J,"REM",144,2,1,0) ;;=PARAMETERS^2^512 ;;^UTILITY(U,$J,"REM",144,2,1,1,0) ;;=^^7^7^2970110^ ;;^UTILITY(U,$J,"REM",144,2,1,1,1,0) ;;=This array contains the following parameter necessary for ;;^UTILITY(U,$J,"REM",144,2,1,1,2,0) ;;=a Lock command: ;;^UTILITY(U,$J,"REM",144,2,1,1,3,0) ;;=|TAB|- NODE - the global node that needs to be locked/unlocked ;;^UTILITY(U,$J,"REM",144,2,1,1,4,0) ;;=|TAB|- LOCKMODE - the operation to be done, Lock or Unlock ;;^UTILITY(U,$J,"REM",144,2,1,1,5,0) ;;=|TAB|- TIMEOUT - integer representing the number of seconds during which ;;^UTILITY(U,$J,"REM",144,2,1,1,6,0) ;;=the system attempts to lock or unlock a node before returning control to ;;^UTILITY(U,$J,"REM",144,2,1,1,7,0) ;;=the program . ;;^UTILITY(U,$J,"REM",144,2,"B","PARAMETERS",1) ;;= ;;^UTILITY(U,$J,"REM",144,3,0) ;;=^^2^2^2970110^^ ;;^UTILITY(U,$J,"REM",144,3,1,0) ;;=This parameter returns 1 if the lock or unlock command is successful, ;;^UTILITY(U,$J,"REM",144,3,2,0) ;;=otherwise a 0 is returned. ;;^UTILITY(U,$J,"REM",145,0) ;;=DDR FIND1^FIND1C^DDR2^2^R^ ;;^UTILITY(U,$J,"REM",145,1,0) ;;=^^2^2^2970121^ ;;^UTILITY(U,$J,"REM",145,1,1,0) ;;=This function returns the internal entry number of a record using ;;^UTILITY(U,$J,"REM",145,1,2,0) ;;=$$FIND1^DIC. ;;^UTILITY(U,$J,"REM",145,2,0) ;;=^8994.02A^1^1 ;;^UTILITY(U,$J,"REM",145,2,1,0) ;;=PARAMETERS^2^512^1 ;;^UTILITY(U,$J,"REM",145,2,1,1,0) ;;=^^15^15^2970121^ ;;^UTILITY(U,$J,"REM",145,2,1,1,1,0) ;;=This array contains the following parameters necessary to call ;;^UTILITY(U,$J,"REM",145,2,1,1,2,0) ;;=$$FIND1^DIC. ;;^UTILITY(U,$J,"REM",145,2,1,1,3,0) ;;= ;;^UTILITY(U,$J,"REM",145,2,1,1,4,0) ;;= "FILE" the file or subfile number to search ;;^UTILITY(U,$J,"REM",145,2,1,1,5,0) ;;= "IENS" the IENS that identifies the subfile if FILE is a subfile number ;;^UTILITY(U,$J,"REM",145,2,1,1,6,0) ;;= "FLAGS" possible values include: ;;^UTILITY(U,$J,"REM",145,2,1,1,7,0) ;;= A allow pure numeric input to always be tried as an IEN ;;^UTILITY(U,$J,"REM",145,2,1,1,8,0) ;;= M multiple index allowed ;;^UTILITY(U,$J,"REM",145,2,1,1,9,0) ;;= O only find an exact match if possible ;;^UTILITY(U,$J,"REM",145,2,1,1,10,0) ;;= Q quick lookup ;;^UTILITY(U,$J,"REM",145,2,1,1,11,0) ;;= X exact match only ;;^UTILITY(U,$J,"REM",145,2,1,1,12,0) ;;= R record the ien in ^DISV via RECALL^DILFD ;;^UTILITY(U,$J,"REM",145,2,1,1,13,0) ;;= "VALUE" the lookup value ;;^UTILITY(U,$J,"REM",145,2,1,1,14,0) ;;= "XREF" the indexes that would be searched for a match ;;^UTILITY(U,$J,"REM",145,2,1,1,15,0) ;;= "SCREEN" screen to apply to the record found ;;^UTILITY(U,$J,"REM",145,2,"B","PARAMETERS",1) ;;= ;;^UTILITY(U,$J,"REM",145,3,0) ;;=^^5^5^2970121^ ;;^UTILITY(U,$J,"REM",145,3,1,0) ;;=This parameter returns a valid internal record number if a match ;;^UTILITY(U,$J,"REM",145,3,2,0) ;;=is found, a 0 if no match was found or a -1 if an error occurred. ;;^UTILITY(U,$J,"REM",145,3,3,0) ;;= ;;^UTILITY(U,$J,"REM",145,3,4,0) ;;=(For now, this is 'single value'. It will return the error array ;;^UTILITY(U,$J,"REM",145,3,5,0) ;;=later.) ;;^UTILITY(U,$J,"REM",146,0) ;;=DDR GET DD HELP^GETHLPC^DDR2^2^R ;;^UTILITY(U,$J,"REM",147,0) ;;=DDR FINDER^FINDC^DDR0^4^R^^^1 ;;^UTILITY(U,$J,"REM",147,2,0) ;;=^8994.02A^1^1 ;;^UTILITY(U,$J,"REM",147,2,1,0) ;;=FIND ATTRIBUTES^2^512 ;;^UTILITY(U,$J,"REM",147,2,"B","FIND ATTRIBUTES",1) ;;= ;;^UTILITY(U,$J,"REM",353,0) ;;=DDR KEY VALIDATOR^KEYVAL^DDR3^2^P ;;^UTILITY(U,$J,"REM",353,1,0) ;;=^^2^2^2960221^ ;;^UTILITY(U,$J,"REM",353,1,1,0) ;;=Validates that values passed in do not violate key integrity. Underlying ;;^UTILITY(U,$J,"REM",353,1,2,0) ;;=DBS call is KEYVAL^DIE. ;;^UTILITY(U,$J,"REM",353,2,0) ;;=^8994.02A^1^1 ;;^UTILITY(U,$J,"REM",353,2,1,0) ;;=VALUES TO VALIDATE^2^512^1 ;;^UTILITY(U,$J,"REM",353,2,1,1,0) ;;=^^3^3^2960221^ ;;^UTILITY(U,$J,"REM",353,2,1,1,1,0) ;;=Array of data used to create FDA for KEYVAL^DIE call. Alternating lines ;;^UTILITY(U,$J,"REM",353,2,1,1,2,0) ;;=contain file#^IENS^field# and value associated with preceding file, record, ;;^UTILITY(U,$J,"REM",353,2,1,1,3,0) ;;=and field. ;;^UTILITY(U,$J,"REM",353,2,"B","VALUES TO VALIDATE",1) ;;= ;;^UTILITY(U,$J,"REM",353,3,0) ;;=^^3^3^2960430^^ ;;^UTILITY(U,$J,"REM",353,3,1,0) ;;=If values pass validation, 1 is returned in first node of array. If DIINI007 DIINI007 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y Q Q ;;^UTILITY(U,$J,"REM",353,3,2,0) ;;=validation fails, 0 is returned in first node followed by error ;;^UTILITY(U,$J,"REM",353,3,3,0) ;;=information. DIINIS DIINIS ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. PAC(PKG,VER) ; called from package init (DIFROM7 created this routine) ; PKG = $T(IXF) of the INIT routine. ; VER is an array that is contained in DIFROM from the INIT routine ; N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("DIINIS",$J) ; ; Site tracking updates only occur if run in a VA production primary domain ; account. I $G(^XMB("NETNAME"))'[".VA.GOV" Q Q:'$D(^%ZOSF("UCI")) Q:'$D(^%ZOSF("PROD")) X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q ; S SERVER="S.A5CSTS@FORUM.VA.GOV" S PACKAGE=$P($P(PKG,";",3),U) S SITE=$G(^XMB("NETNAME")) S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown" D ; check if ok to use kernel functions .S X="XLFDT" X ^%ZOSF("TEST") I $T D Q ..S NOW=$$HTFM^XLFDT($H) ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3) ..S START=$$FMTE^XLFDT(START) ..S DATE=NOW\1 ..S NOW=$$FMTE^XLFDT(NOW) .D NOW^%DTC S NOW=%,DATE=X .S RUN="" ; don't bother to compute .S Y=START D DD^%DT S START=Y .S Y=NOW D DD^%DT S NOW=Y ; ; Message for server S ^TMP("DIINIS",$J,1,0)="PACKAGE INSTALL" S ^TMP("DIINIS",$J,2,0)="SITE: "_SITE S ^TMP("DIINIS",$J,3,0)="PACKAGE: "_PACKAGE S ^TMP("DIINIS",$J,4,0)="VERSION: "_VER S ^TMP("DIINIS",$J,5,0)="Start time: "_START S ^TMP("DIINIS",$J,6,0)="Completion time: "_NOW S ^TMP("DIINIS",$J,7,0)="Run time: "_RUN S ^TMP("DIINIS",$J,8,0)="DATE: "_DATE ; ; Data is sent to server on FORUM - S.A5CSTS S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""DIINIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION" D ^XMD K ^TMP("DIINIS",$J) Q DIINIT DIINIT ; ; 28-MAR-2013 ; 3/28/13 10:58am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT S DIOVRD=1,U="^",DIFQ=0,DIFROM="22.2" W !,"This version (#22.2) of 'DIINIT' was created on 28-MAR-2013" W !?9,"(at V22P2.FILEMAN.MUMPS.ORG, by VA FILEMAN 22.2V2)",! I $D(^DD("VERSION")),^("VERSION")'<22.2 G GO ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT I ^DD("VERSION")<22.2 W !,"but I need version 22.2 of the VA FileMan!" G Q GO ; EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM S DIFQ=0 K DIRUT,DTOUT,DUOUT F DIFRIR=1:1:1 S DIFRRTN="^DIINIT"_$E("5",DIFRIR) D @DIFRRTN W:0 !,"I AM GOING TO SET UP THE FOLLOWING FILE:" F I=1:2:0 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I) S DIFROM="22.2" D PKG:'$D(DIFROM(0)),^DIINIT1 G Q:'$D(DIFQ) S DIK(0)="AB" F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N) K DIFQR D ^DIINIT2,^DIINIT3 L S DUZ=DIDUZ W:0 !,$C(7),"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE" I DIFROM F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%) I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN I DIFROM,$D(^%ZTSK) S X="DIINIS" X ^%ZOSF("TEST") D:$T PAC^DIINIS($T(IXF),.DIFROM) S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0 D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U) S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "." Q R G REP^DIINIT2 ; 1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 S DIFQ(N)=$P(DIF(I),";",7)'="n" I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 Q Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 ; PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC Q ; IXF ;;VA FILEMAN^DI;1 DIINIT1 DIINIT1 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; LOADS AND INDEXES DD'S ; K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q F X="KEY","OPT","REM" D W Q:'$D(DIFQ) Q:'$D(DIFQ) S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q D ^DIINITPR D NOW^%DTC S DIFROM("INI")=% I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0 S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD S DN="^DIINI" F R=1:1:7 D @(DN_$$B36(R)) W "." F S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0 K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0 K ^(D) D IX KEYSNIX ; Keys and new style indexes installer ; new in FM V22.2 N DIFRSA S DIFRSA=$NA(^UTILITY("KX",$J)) ; Tran global for Keys and Indexes N DIFRFILE S DIFRFILE=0 ; Loop through files F S DIFRFILE=$O(@DIFRSA@("IX",DIFRFILE)) Q:'DIFRFILE D . K ^TMP("DIFROMS2",$J,"TRIG") . N DIFRD S DIFRD=0 . F S DIFRD=$O(@DIFRSA@("IX",DIFRFILE,DIFRD)) Q:'DIFRD D DDIXIN^DIFROMSX(DIFRFILE,DIFRD,DIFRSA) ; install New Style Indexes . K ^TMP("DIFROMS2",$J,"TRIG") . S DIFRD=0 . F S DIFRD=$O(@DIFRSA@("KEY",DIFRFILE,DIFRD)) Q:'DIFRD D DDKEYIN^DIFROMSY(DIFRFILE,DIFRD,DIFRSA) ; install keys K @DIFRSA ; kill off tran global ; VEN/SMH v22.2: Below I added a K D1 because it leaks from the call causing the key matching algo to fail. DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 K D1 Q:'$D(^(D0,0)) S Z=^(0) D I^DITR K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA ; W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0)) S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W S:%=2 DIFQ(X)=0 K:%<0 DIFQ Q ; OPT ;OPTION RTN ;ROUTINE DOCUMENTATION NOTE FUN ;FUNCTION BUL ;BULLETIN KEY ;SECURITY KEY HEL ;HELP FRAME DIP ;PRINT TEMPLATE DIE ;INPUT TEMPLATE DIB ;SORT TEMPLATE DIS ;FORM REM ;REMOTE PROCEDURE ; SBF ;FILE AND SUB FILE NUMBERS IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK) S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK Q B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1) N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) DIINIT2 DIINIT2 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD Q ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0 S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR S DIK=DIC HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R="" W !,"'"_R_"' Help Frame filed." S DA=^(R) F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99) S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0) I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I IX D IX1^DIK G HELP ; U I $D(DIRUT) S DIFQ=1 W ! Q REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT) I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q S DIR("A")="Shall I replace your file with mine" S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y S DIU(0)="E",DIR("A")="Do you want to keep the Data" S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"D" S DIR("A")="Do you want to keep the Templates" S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T" S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q DIINIT3 DIINIT3 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0)) S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X="" W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins." I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=% OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^DIINIT4 NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J) I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD S DIC=.5,DLAYGO=0,N="FUN" D ADD I $P($G(^DIC(8994,0)),U)="REMOTE PROCEDURE" S (DIC,DLAYGO)=8994,N="REM" D ADD S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ K ^UTILITY("DIFROM",$J) Q DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII E S DISYS=^DD("OS") Q:'$D(^DD("OS",DISYS,"ZS")) S DIFR1="" DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1="" F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z") G DZ1 ; OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=% S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0)) S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C") F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP ; ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A Q Q A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0)) K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^") I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%) I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D .W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!" .Q I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1) I N="DIST(.403," D BLK S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT I N="DIST(.403," D .N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA) .I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q .W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled" .Q Q BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1 K A0,A1,A2,J,L Q B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X) .Q S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D .N X S X=0 .F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X) .Q S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK") Q KAD(D0) N D1,X S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1) Q DIINIT4 DIINIT4 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_"," S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1) D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4) I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=% D OR S DA(1)=1 D IX1^DIK Q OR S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X="" F S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J Q OR1 N X F S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J Q ADDP N I,J,N,R,DA,DLAYGO,DO S %="" S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1 S %=+Y Q DIINIT5 DIINIT5 ; ; 28-MAR-2013 ; 3/28/13 10:57am ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:0 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1 Q IXF ;;VA FILEMAN^DI DIINITPR DIINITPR ; VEN/SMH - Fileman 22.2 Post-Init; 31-JAN-2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; W !!,"Executing the Pre-Init for Fileman 22.2",!! ; ; We will postpone this to 22.3 and move it over to DINIT. ; Kill data dictionary audit nodes as they are no longer used in FM 22.2 ; W "Deleting the now no longer used ^DD(FN,0,""DDA"") nodes",! ; N I F I=-1:0 S I=$O(^DD(I)) Q:+I'=I K ^DD(I,0,"DDA") ; ; Remove old now not used DIAUDIT DD menu option ; Unfortunately, Fileman doesn't have an API to do this. We have to ; sneak into KIDS. W "Deleting the DIAUDIT DD menu option, no longer used in FM 22.2",! N OPTIEN S OPTIEN=$O(^DIC(19,"B","DIAUDIT DD","")) ; Get Option IEN QUIT:OPTIEN="" K ^TMP($J,"XPDEL") ; Kill data container S ^TMP($J,"XPDEL",OPTIEN)="" ; Put the options to delete D OPTDEL^XPDIA ; KIDS private API. QUIT DIIS DIIS ;SFISC/GFT-DELETE THIS LINE AND SAVE AS '%ZIS' IF YOU DON'T HAVE A '%ZIS' ROUTINE ;27OCT2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; %ZIS ; I $D(IOP)#2 S IO=$I G PARAMS S IO=$I ;READ "DEVICE: ",IO ;INSERT DEVICE SELECTION HERE PARAMS S IOM=80,IOSL=24,IOF="#",IOPAR="",POP=0,ION=$P(IO,";"),IOT="TRM" S IO(0)=$P,IOBS="$C(8)" ; ; DIISS uses the variable IOST to determine what to set the screen ; handling variables to. (See routine DIISS.) DIISS currently ; looks for values of IOST equal to C-VT220 and C-VT320. If it ; equals anything else, the IO variables default to the codes for ; C-VT100 terminals. ; ; The variable IOXY contains the code to position the cursor at ; column position DX and row position DY. Unmodified, this ; routine sets IOXY to the code for VT100, VT220, and VT320 ; terminals. ; S IOST="C-VT100" S IOXY="W $C(27,91)_(DY+1)_$C(59)_(DX+1)_$C(72)" Q ; ; ; REWIND(IO2,IOT,IOPAR) ;Rewind Device Q 0 ; HOME ;called from DDFIX,DDMP2,DDSCLONE,DIAR,DIARR,DIARR5,DIARX,DIFGO S IO=$I G PARAMS DIISC DIISC ;GFT/GFT - SAVE AS '%ZISC' IF YOU DON'T HAVE A '%ZISC' ROUTINE;27OCT2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;; %ZISC ; I IO'=$P D .C IO DIISS DIISS ;SFISC/MKO-SAVE AS %ZISS IF STANDALONE FILEMAN ;01:39 PM 21 Dec 1994 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. %ZISS ;SFISC/MKO-RETURN SCREEN HANDLING IO VARIABLES ; ; ; This routine is for standalone FileMan sites that want to use ; FileMan's screen-oriented utilities. It must be saved as %ZISS ; in the manager account. There are four entry points: ; ; ENDR - returns the IO variables required for screen handling ; KILL - kills the IO variables set by ENDR ; GSET - returns the IO variables required to draw lines ; GKILL - kills the IO variables set by GSET ; ; The input variable to all of these entry points is ; ; IOST - the terminal type name (e.g., C-VT100) ; ; The terminal types supported by this routine are C-VT100, ; C-VT220, and C-VT320. To support another terminal ; type, modify the highlighted line in subroutine GETT, and create ; new subroutines that sets the IO variables appropriately. ; ; Also note that %ZIS must return in IOXY the code to position the ; cursor at column DX and row DY. ; GETT ;Based on value of IOST, returns DITT with values: ; 1 = C-VT100 (default) ; 2 = C-VT220 or C-VT320 ; 3 = C-DATATREE S U="^",DIIOST=$TR(IOST," ","") ; ;****** ;** To recognize other terminal types, modify the following line of ;** code and add new subroutines (e.g., 4 and G4 for C-QUME) that ;** set the IO variables equal to the codes for that terminal type. ;****** ; S DITT=$S("^C-VT220^C-VT320^"[(U_DIIOST_U):2,DIIOST="C-DATATREE":3,1:1) ;***** K DIIOST Q ENDR ;Set screen handler IO variables N DITT D GETT,@DITT Q GSET ;Set graphics variables N DITT D GETT,@("G"_DITT) Q KILL ;Kill screen handler IO variables K IOCUU,IOCUD,IOCUF,IOCUB,IOPF1,IOPF2,IOPF3,IOPF4 K IOFIND,IOINSERT,IOREMOVE,IOSELECT,IOPREVSC,IONEXTSC,IOHELP,IODO K IOKPAM,IOKPNM K IOKP0,IOKP1,IOKP2,IOKP3,IOKP4,IOKP5,IOKP6,IOKP7,IOKP8,IOKP9 K IOMINUS,IOCOMMA,IOPERIOD,IOENTER K IOEDALL,IOEDEOP,IOELEOL,IOELALL K IOINHI,IOINLOW,IOINORM,IORVON,IORVOFF,IOUON,IOUOFF,IOSGR0 K IORI,IOSTBM,IOIL,IODL,IOICH,IODCH K IOIRM1,IOIRM0,IOAWM0,IOAWM1 Q GKILL ;Kill graphics variables K IOG0,IOG1,IOBLC,IOBRC,IOTLC,IOTRC,IOHL,IOVL,IOLT,IOTT,IORT,IOBT,IOMT Q 1 ;VT100 codes S IOCUU=$C(27)_"[A" S IOCUD=$C(27)_"[B" S IOCUF=$C(27)_"[C" S IOCUB=$C(27)_"[D" S IOPF1=$C(27)_"OP" S IOPF2=$C(27)_"OQ" S IOPF3=$C(27)_"OR" S IOPF4=$C(27)_"OS" S IOFIND=$C(27)_"[1~" S IOINSERT=$C(27)_"[2~" S IOREMOVE=$C(27)_"[3~" S IOSELECT=$C(27)_"[4~" S IOPREVSC=$C(27)_"[5~" S IONEXTSC=$C(27)_"[6~" S IOHELP=$C(27)_"[28~" S IODO=$C(27)_"[29~" S IOKP0=$C(27)_"Op" S IOKP1=$C(27)_"Oq" S IOKP2=$C(27)_"Or" S IOKP3=$C(27)_"Os" S IOKP4=$C(27)_"Ot" S IOKP5=$C(27)_"Ou" S IOKP6=$C(27)_"Ov" S IOKP7=$C(27)_"Ow" S IOKP8=$C(27)_"Ox" S IOKP9=$C(27)_"Oy" S IOMINUS=$C(27)_"Om" S IOCOMMA=$C(27)_"Ol" S IOPERIOD=$C(27)_"On" S IOENTER=$C(27)_"OM" S IOEDEOP=$C(27)_"[J" S IOEDALL=$C(27)_"[2J" S IOELEOL=$C(27)_"[K" S IOELALL=$C(27)_"[2K" S IOAWM0=$C(27)_"[?7l" S IOAWM1=$C(27)_"[?7h" S IOINHI=$C(27)_"[1m" S IOINLOW=$C(27)_"[m" S IOINORM=$C(27)_"[m" S IOUON=$C(27)_"[4m" S IOUOFF=$C(27)_"[m" S IORVON=$C(27)_"[7m" S IORVOFF=$C(27)_"[m" S IOSGR0=$C(27)_"[m" S IORI=$C(27)_"M" S IOSTBM="$C(27,91)_+IOTM_"";""_+IOBM_""r""" S IOIL=$C(27)_"[L" S IODL=$C(27)_"[M" S IOICH=$C(27)_"[@" S IODCH=$C(27)_"[P" S IOIRM1=$C(27)_"[4h" S IOIRM0=$C(27)_"[4l" S IOKPAM=$C(27)_"=" S IOKPNM=$C(27)_">" Q G1 ;VT100 line drawing codes S IOG0=$C(27)_"(B" S IOG1=$C(27)_"(0" S IOBLC="m" S IOBRC="j" S IOTLC="l" S IOTRC="k" S IOHL="q" S IOVL="x" S IOLT="t" S IOTT="w" S IORT="u" S IOBT="v" S IOMT="n" Q 2 ;VT220 and VT320 codes ;The codes are the same as VT100 except for a few D 1 S IOINLOW=$C(27)_"[22m" S IOUOFF=$C(27)_"[24m" S IORVOFF=$C(27)_"[27m" Q G2 ;VT220 and VT320 line drawing codes ;The codes are the same as those for VT100s D G1 Q 3 ;C-DATATREE codes S IOXY="W /C(DX,DY)" S IOCUU=$C(1) S IOCUD=$C(11) S IOCUF=$C(18) S IOCUB=$C(14) S IOPF1=$C(21) S IOPF2=$C(22) S IOPF3=$C(23) S IOPF4=$C(24) S IOEDALL=$C(12) S IOEDEOP=$C(255)_"EF" S IOELEOL=$C(255)_"EL" S IOELALL="" S IOAWM0="" S IOAWM1="" S IOINHI=$C(255)_"AB" S IOINLOW=$C(255)_"AA" S IOUON=$C(255)_"AC" S IOUOFF=$C(255)_"AA" S IORVON=$C(255)_"AE" S IORVOFF=$C(255)_"AA" S IOINORM=$C(255)_"AA" S IOSGR0=$C(255)_"AA" S IORI="" S IOSTBM="" S IOIL="" S IODL="" S IOICH="" S IODCH="" S IOIRM1="" S IOIRM0="" Q G3 ;C-DATATREE line drawing codes S IOG0="" S IOG1="" S IOBLC=$C(192) S IOBRC=$C(217) S IOTLC=$C(218) S IOTRC=$C(191) S IOHL=$C(196) S IOVL=$C(179) S IOLT=$C(195) S IOTT=$C(194) S IORT=$C(180) S IOBT=$C(193) S IOMT=$C(197) Q DIK DIK ;SFISC/GFT,YJK,XAK-GATHER A FILE'S XREFS TO EXECUTE ;1NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q:"(,"'[$E($RE(DIK)) Q:'$G(DA) Q:'$D(@(DIK_"DA)")) Q:$P($G(^DD($$GLO^DILIBF(DIK),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM) Q:DA'>0 N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIAU,DIKALLR D CHKS I $D(DIKZ1) N DIKIL S DIKIL=1 G @DIKGP S X=2 D DD G ^DIK1 ; DD1 N DISKIPIN D D,A Q ; ; DISKIPIN(DISKIPIN) ;ALSO CALLED FROM DIU1 K DISKIPIN S DISKIPIN=1 D DDGO F DV=0:0 S DV=$O(^DD("IX","B",+$P($G(@(DIK_"0)")),U,2),DV)) Q:'DV I $G(^DD("IX",DV,"NOREINDEX")) S DISKIPIN=DISKIPIN+1 S DISKIPIN=DISKIPIN-1 Q ;RETURN THE NUMBER OF SKIPPED INDEXES ; DD ;CALLED FROM DIKZ0 N DISKIPIN DDGO D DIKJ N DIKCHK S DIKCHK=1,DV=0 D D,A I $G(DIK(0))["s" S DU=1 Q E S DV=$O(^DD(DH,"SB",DV)) I DV>0 S DU=$O(^(DV,0)) G E:'$D(^DD(DV,.01,0)),E:$P(^(0),U,2)["W" S DW=$P($P(^DD(DH,DU,0),U,4),";") S:+DW'=DW DW=""""_DW_"""" S DV(DH,DU)=DW,DV(DH,DU,0)=DV,DU(DV)=DH D:$D(DIK0) CRT^DIKZ2 G E Q:$D(DIK0) DH S DH=$O(DU(DH)) G:DH>0 DH:$D(DV(DH)),E F DH=DH(1):0 S DH=$O(DU(DH)) Q:DH'>0 D D,A DV S DH=0 F S DH=$O(DV(DH)) Q:'DH S DU=0 F S DU=$O(DV(DH,DU)) Q:'DU I $G(DIKCHK),'$G(DIKCHK(DV(DH,DU,0))) S DV(DH,DU,"NOLOOP")="" S DU=1 Q ; DW I $O(^UTILITY("DIK",DIKJ,DH,DV,0))="" K ^UTILITY("DIK",DIKJ,DH,DV) D S DV=$O(^DD(DH,"IX",DV)) Q:DV'>0 I '$D(^DD(DH,DV,0)) K ^DD(DH,"IX",DV) G D D 0 I F DW=0:0 S DW=$O(^DD(DH,DV,1,DW)) G DW:DW'>0 I $D(^(DW,X)),"Q"'[^(X),$D(^(0)) S %=^(0) D .I $G(^("NOREINDEX")),$G(DISKIPIN) S DISKIPIN(DISKIPIN)=%,DISKIPIN=DISKIPIN+1 Q .D INX ; INX I %["TRIGGER" S %=^(X),^UTILITY("DIK",DIKJ,DH,DV,DW)="D RCR",^(DW,0)=% Q I %["BULLETIN MESSAGE",$G(DIK(0))["B" S %=$P("CREA^DELE",U,X)_"TE VALUE" W:$D(^(%)) !,"...('"_^(%)_"' BULLETIN WILL NOT BE TRIGGERED)..." Q I '$D(DIK0),X=2,$P(%,U),$P(%,U,2)]"",$P(%,U,3)="",+%=DH(1)&$G(DIKALLR)!$D(DU(+%)) D . S ^UTILITY("DIK",DIKJ,"KW",+%,$P(%,U,2))=DH_U_DV_U_DW . D CHK($G(DU(+%)),.DU,.DIKCHK) E D . S ^UTILITY("DIK",DIKJ,DH,DV,DW)=^DD(DH,DV,1,DW,X) . D CHK(DH,.DU,.DIKCHK) Q CHK(F,DU,DIKCHK) ;Set CHK(f) for file F and its parents Q:$D(DIK0)!'$G(DIKCHK) F Q:'F Q:$D(DIKCHK(F)) S DIKCHK(F)=1,F=$G(DU(F)) Q ; A F DV=0:0 S DV=$O(^DD(DH,"AUDIT",DV)) Q:DV'>0 D A1 ;FIND AUDITED FIELDS Q A1 D 0 S ^UTILITY("DIK",DIKJ,DH,DV,99)="S DIIX="_(4-X)_" D:$G(DIK(0))'[""A"" AUDIT" D CHK(DH,.DU,.DIKCHK) Q ; 0 ;REMEMBER HOW TO GRAB THE FIELD'S VALUE S DW=$P(^DD(DH,DV,0),U,4),^UTILITY("DIK",DIKJ,DH,DV)=$P(DW,";",1),DW=$P(DW,";",2) S ^UTILITY("DIK",DIKJ,DH,DV,0)=$S(DW:"S X=$P($G(^(X)),U,"_DW_")",1:"S X=$E($G(^(X)),"_+$E(DW,2,9)_","_$P(DW,",",2)_")"),DW=0 Q ; IX ; N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR D CHKS I $D(DIKZ1) N DIKKS S DIKKS=1 G @DIKGP S X=2,DIKNM=1 D DD,1^DIK1 IX1 ; N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKSET,DIKALLR I '$D(DIKNM) D CHKS I $D(DIKZ1) N DIKST S DIKST=1 G @DIKGP S X=1,DIKSET=1 D DD,1^DIK1 ; D INDEX^DIKC(DIK,.DA,"","",$E("K",$D(DIKNM)#2)_"S"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s")) G Q ; IX2 ; Q:$D(@(DIK_"0)"))[0 N DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKDA,DIKALLR S X=2 D DD,1^DIK1 D INDEX^DIKC(DIK,.DA,"","","K"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s")) G Q ; IXALL ; N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKSET,DIKALLR N DINO S X=1 D DISKIPIN(.DINO) D CHKS I $D(DIKZ1),'$G(DINO) N DIKSAT S DIKSAT=1,DA=0 G @DIKGP ;CAN'T DO COMPILED ROUTINE IF THERE ARE SOME WE MUST SKIP ; N DIKDASV,DIKSAVE M DIKDASV=DA S DIKDASV=0,DIKSAVE=DIK S (DA,DCNT)=0,X=1,DIKSET=1 D CNT^DIK1 ;NOW FIRE NEW-STYLE SETS D INDEX^DIKC(DIKSAVE,.DIKDASV,"","","Sx"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s")) G Q ; IXALL2 ; Q:$D(@(DIK_"0)"))[0 N DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKDA,DIKDASV,DIKSAVE,DIKALLR N DINO S X=2 D DISKIPIN(.DINO) M DIKDASV=DA S DIKDASV=0,DIKSAVE=DIK S DIKALLR=1,(DA,DCNT)=0,X=2 D CNT^DIK1 ;NOW FIRE NEW-STYLE KILLS D INDEX^DIKC(DIKSAVE,.DIKDASV,"","","Kx"_$E("RI",$D(DIFROM)#2+1)_$E("s",$G(DIK(0))["s")) G Q ; EN ; N DIKCRFIL,DIKCDIK,DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR D N(1) G:'$D(DH)!'$D(DA) Q S DIKCRFIL=DH M DIKCDIK=DIK S DIKNM=1,X=2 D:$D(DIKNX) PR,1^DIK1 ; EN1 ; N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR D @$S('$D(DIKNM):"N(1)",1:"DIKJ") G:'$D(DH)!'$D(DA) Q I '$D(DIKNM) N DIKCRFIL,DIKCDIK S DIKCRFIL=DH M DIKCDIK=DIK S X=1 D:$D(DIKNX) PR,1^DIK1 I $D(^DD("IX","AC",DIKCRFIL)) M DIK=DIKCDIK D INDEX^DIKC(DIKCRFIL,.DA,$P(DIK(1),U),$P(DIK(1),U,2,999),$E("K",$D(DIKNM))_"S"_$E("RI",$D(DIFROM)#2+1)) G Q ; EN2 ; N DIKCRFIL,DIKCDIK,DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKALLR D N(1) G:'$D(DH)!'$D(DA) Q S DIKCRFIL=DH M DIKCDIK=DIK S X=2 D:$D(DIKNX) PR,1^DIK1 I $D(^DD("IX","AC",DIKCRFIL)) M DIK=DIKCDIK D INDEX^DIKC(DIKCRFIL,.DA,$P(DIK(1),U),$P(DIK(1),U,2,999),"K"_$E("RI",$D(DIFROM)#2+1)) G Q ; ENALL ; N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKXREF,DIKDASV,DIKSAVE,DHSAVE,DIKALLR D N(0) G:'$D(DH) Q M DIKDASV=DA,DIKSAVE=DIK,DHSAVE=DH S DIKDASV=0 S (DA,DCNT)=0,X=1 D PR,CNT^DIK1 D:$D(^DD("IX","AC",DHSAVE)) INDEX^DIKC(DHSAVE,.DIKDASV,$P(DIKSAVE(1),U),$P(DIKSAVE(1),U,2,999),"Sx"_$E("RI",$D(DIFROM)#2+1)) G Q ; ENALL2 ; N DIKJ,DIKS,DIKZ1,DIN,DH,DU,DV,DW,DIKDA,DIKXREF,DIKDASV,DIKSAVE,DHSAVE,DIKALLR D N(0) G:'$D(DH) Q M DIKDASV=DA,DIKSAVE=DIK,DHSAVE=DH S DIKDASV=0 S DIKALLR=1,(DA,DCNT)=0,X=2 D PR,CNT^DIK1 D:$D(^DD("IX","AC",DHSAVE)) INDEX^DIKC(DHSAVE,.DIKDASV,$P(DIKSAVE(1),U),$P(DIKSAVE(1),U,2,999),"Kx"_$E("RI",$D(DIFROM)#2+1)) G Q ; ; N(REINDOK) Q:'$D(DIK)!'$D(DIK(1))!'$D(@(DIK_"0)")) D DIKJ S DIKND=$P(DIK(1),U) I '$D(^DD(DH,"IX",DIKND)) K:'$D(^DD("IX","F",DH,DIKND)) DH Q I $P(DIK(1),U,2)="" D . S %=0 F A1=1:1 S %=$O(^DD(DH,DIKND,1,%)) Q:'% I '$G(^(%,"NOREINDEX"))!REINDOK S DIKNX(A1)=% ;SKIP NON-RERUNNABLE INDEX IF NOT SPECIFIED PRECISELY AND IF THIS IS A MASS REINDEX E F A1=1:1 Q:$P(DIK(1),U,A1+1)="" S DIKNX(A1)=$P(DIK(1),U,A1+1) K A1,% Q ; PR S DV=DIKND I '$D(^DD(DH,"IX",DV)),'$D(^DD(DH,"AUDIT",DV)) Q D 0 S DIKZ1=1 D CK K DIKZ1 D:$D(^DD(DH,"AUDIT",DV)) A1 S DU=1 Q ; CK Q:'$D(DIKNX(DIKZ1)) F DW=0:0 S DW=$O(^DD(DH,DV,1,DW)) Q:DW'>0 I $D(^(DW,0)),(DW=DIKNX(DIKZ1))!($P(^(0),U,2)=DIKNX(DIKZ1)),$D(^(X)),"Q"'[^(X) S %=^(0) D INX S DIKZ1=DIKZ1+1 G CK ; FREE(X) N V S V=$G(^UTILITY("DIK",X)) I 'V Q 1 Q $H-1>V ; DIKJ F DIKJ=$J:.01 I $$FREE(DIKJ) K ^UTILITY("DIK",DIKJ) S ^UTILITY("DIK",DIKJ)=$H Q ;TO ENABLE RECURSIVE CALL, FIND A "$J" THAT'S UNUSED INT K DIKS,DIN,DH,DU,DV,DW S U="^",DH=+$P(@(DIK_"0)"),U,2),DH(1)=DH Q ; CHKS ; I $D(@(DIK_"0)"))[0 S DIKZ1=1,DIKGP="Q^DIK1" Q S DIKZ1=+$P(^(0),"^",2) I DIKZ1,$D(^DD(DIKZ1,0,"DIK")),$$ROUEXIST^DILIBF(^("DIK")) S DIKGP="^"_^DD(DIKZ1,0,"DIK") Q K DIKZ1 Q ; Q K DIKND,DIKNX,DIKZ1,DIKNM,DIAU,DIG,DIH,DIV,DIW,%,DH Q DIK1 DIK1 ;SFISC/GFT-ACTUAL INDEXER ;7SEP2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN N DIC D DI D . N DIKSV S DIKSV=DIK N DIK,DIKJ,DIFKEP . D INDEX^DIKC(DIKSV,.DA,"","","KT") D K G Q:'$D(@(DIK_"0)")) ;IF ZERO NODE IS THERE, RE-SET IT S Y=^(0),DH=$S($O(^(0))'>0:0,1:$P(Y,U,4)-1),X=$P($P(Y,U,3),U,DH>0) D 3:X=DA S ^(0)=$P(Y,U,1,2)_U_X_U_DH IDENTF I DIK?1"^DD(".NP1",",$G(DA(1)),DIK[DA(1) K ^DD(DA(1),0,"ID",DA),^("W"_DA) Q K:$G(DIKJ) ^UTILITY("DIK",DIKJ) K DB(0),DIKJ,DIKS,DIN,DH,DU,DV,DW,DIKGP Q ; K S X="",Y=1 I $D(DIFKEP(DA))#2,DIK="^DIC(",$D(@(DIK_DA_",0,""GL"")")) S X=^("GL"),Y="^DIC("_DA_"," I X'=Y K @(DIK_"DA)"),X,Y Q S X=DIK_"DA,",DH=@(X_"0)") K ^(0),^("%") S Y="""%""" F S Y=$O(@(X_Y_")")) Q:$E(Y)'="%" S Y=""""_Y_"""" K @(X_Y_")") S @(X_"0)")=DH K X,Y Q ; 3 N X1 S X1=X,X=+$O(^(X1),-1) S:X'>0 X=+$O(^(X1)) Q ; DI S (DIC,DIN)=DIK,DH=DH(DU),DV=1 F S DV=$O(DA(DV)) Q:DV'>0 S DU=DU+1 DIN S DV=0 F S DV=$O(^UTILITY("DIK",DIKJ,DH,DV)) Q:DV="" D R:$G(DIKSET)!(DV-.01) DVA S DV=$O(DV(DH,DV)) I DV="" Q:$G(DIKSET) S DV=.01 D R:$D(^UTILITY("DIK",DIKJ,DH,DV)) Q S X=DIN_DA_","_DV(DH,DV) I @("'$D("_X_"))") G DVA S DU(DU)=DIN,DIN=X_",",DH(DU)=DH,DH=DV(DH,DV,0),DV(DU)=DV,DU=DU+1 F X=DU:-1:1 I $D(DA(X)) S DA(X+1)=DA(X) S DA(1)=DA,DA=0 DA I '$D(DV(DH(DU-1),DV,"NOLOOP")) F S @("DA=$O("_DIN_"DA))") Q:DA'>0 D DIN D:$D(^UTILITY("DIK",DIKJ,"KW",DH)) KW(DH,DIN) S DU=DU-1,DIN=DU(DU),DH=DH(DU),DV=DV(DU),DA=DA(1) K DA(1) F X=2:1 G DVA:'$D(DA(X)) S DA(X-1)=DA(X) K DA(X) ;EXECUTE CROSS-REFERENCES R S X=^UTILITY("DIK",DIKJ,DH,DV),%=^(DV,0) I @("$D("_DIN_DA_",X))[0") Q X % Q:X']"" S DIKS=X,DW=0 XEC S DW=$O(^UTILITY("DIK",DIKJ,DH,DV,DW)) Q:DW="" D NXEC(^(DW)) S X=DIKS G XEC ; NXEC(DICODE) ;New variables and execute programming hook I DICODE="D RCR" E I $G(DW)=99,DICODE?.E1" AUDIT" E N DH,DIFKEP,DIK,DIKJ,DIKS,DIKSET,DIN,DU,DV,DW,KW X DICODE Q RCR K Y,%RCR F %="DIKS","DIK","DW","DH","DIN","DU","DV","X","KW","DIKSET" S %RCR(%)="" S %RCR="RR^DIK1",Y=^UTILITY("DIK",DIKJ,DH,DV,DW,0) G STORLIST^%RCR ; RR X Y Q ; AUDIT N %,%F,%T,%D,DIKF,DIKDA Q:DIIX=3&($D(DIKNM)!$D(DIKKS)) S %=DV N DV S DV=% S %F=DH F %=1:1 Q:'$D(^DD(%F,0,"UP")) S %D=%F,%F=^("UP"),DV(%)=$O(^DD(%F,"SB",%D,0)) S:DV(%)="" DV(%)=-1 S DIKDA="",DIKF="" F %=%-1:-1:1 S DIKDA=DIKDA_DA(%)_",",DIKF=DIKF_DV(%)_"," I $G(^DD(DH,DV,"AX"))]"" D NXEC(^("AX")) I '$T Q D ADD^DIET S DIAU(DH,DV,DIKDA_DA)="^DIA("_%F_","_+Y_",",^DIA(%F,%D,0)=DIKDA_DA_U_%T_U_DIKF_DV_U_DUZ,^DIA(%F,"B",DIKDA_DA,%D)="" SET N C S (%F,C)=$P(^DD(DH,DV,0),U,2),Y=X D:Y]"" S^DIQ S @(DIAU(DH,DV,DIKDA_DA)_"DIIX)")=Y S:DIIX=2&($D(DIKNM)!$D(DIKKS)) ^(3)=Y K DIAU I %F["P"!(%F["V")!(%F["S") S ^(DIIX+.1)=X_U_%F Q ; 1 ; N DIKLK S DIKLK=DIK_DA_")" L +@DIKLK:10 K:'$T DIKLK D DI L:$D(DIKLK) -@DIKLK G Q ; CNT ; N DIKLK,DIKLAST S DIKLAST=$S(DA:DA,1:"") S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK C I @("$O("_DIK_"DA))'>0") S $P(@(DIK_"0)"),U,4)=DCNT D:'$P(^(0),U,3) D:$D(^UTILITY("DIK",DIKJ,"KW",DH(1))) KW(DH(1),DIK) K DCNT L:$D(DIKLK) -@DIKLK G Q ;**DI*22*146 .S DCNT=$O(^(" "),-1) I DCNT S $P(^(0),U,3)=DCNT S DA=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DIKLAST=DA,DU=1,DCNT=DCNT+1 S:DA="" DA=-1 D:(DCNT#100=0) D DI K DB(0) G C .I $D(IO)#2,$D(IO(0))#2,IO=IO(0),IO="" Q .I '$D(ZTQUEUED) W "." ; KW(FIL,DIN) ;Kill entire regular indexes N NAM S NAM="" F S NAM=$O(^UTILITY("DIK",DIKJ,"KW",FIL,NAM)) Q:NAM="" K @(DIN_""""_NAM_""")") Q DIKC DIKC ;SFISC/MKO-FIRE INDEX FILE CROSS REFERENCES ;24OCT2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; INDEX(DIFILE,DIREC,DIFLD,DIXREF,DICTRL) ;Fire Index file xrefs N DA,DIF,DIKACT,DIKCT,DIKERR,DIKLOCK,DIKLOG,DIKON,DIKRFIL N DIKTMP,DIKVAL,DIMF,DIROOT ; ;Initialization S DIF=$E("D",$G(DICTRL)["D") I DIF["D",'$D(DIQUIET) N DIQUIET S DIQUIET=1 I DIF["D",'$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; ;Check (and convert) input parameters D CHK^DIKC2 G:$G(DIKERR)]"" EXIT ; ;Setup variables S DIKCT=$E("C",$G(DICTRL)["C")_$E("T",$G(DICTRL)["T") S DIKLOG=$E("K",$G(DICTRL)["K")_$E("S",$G(DICTRL)["S") S:DIKLOG="" DIKLOG=$E("K",DIKCT'["C")_$E("S",DIKCT'["T") S DIKACT=$E("R",$G(DICTRL)["R")_$E("I",$G(DICTRL)["I") S DIKRFIL=$S($G(DICTRL)["W":+$P(DICTRL,"W",2),1:DIFILE) I $G(DICTRL)["k" D . S DIKLOCK=+$P(DICTRL,"k",2)\1 . S:DIKLOCK<0 DIKLOCK=-DIKLOCK . S:$E($P(DICTRL,"k",2))="-" DIKLOCK("STOP")=1 E S DIKLOCK=1 ; LOAD ;Load xref information into @DIKTMP S DIKTMP=$G(DICTRL("LOGIC")) I $G(DIKTMP)="" D . S DIKTMP=$$GETTMP^DIKC1("DIKC") . I $G(DIXREF)?."^" D .. I $G(DIFLD) D ...D LOADFLD^DIKC1(DIKRFIL,DIFLD,DIKLOG_"W",DIKACT,DIKVAL,DIKTMP,DIKTMP,$E("i",$G(DICTRL)["i"),,$E("x",$G(DICTRL)["x")) .. E D LOADALL^DIKC1(DIKRFIL,DIKLOG,DIKACT,DIKVAL,DIKTMP,$E("s",$G(DICTRL)["s")_$E("i",$G(DICTRL)["i")_$E("x",$G(DICTRL)["x"),.DIMF) . E D LOADXREF^DIKC1(DIKRFIL,$G(DIFLD),DIKLOG,.DIXREF,DIKVAL,DIKTMP) ; D:DIKRFIL'=DIFILE SBINFO^DIKCU(DIKRFIL,.DIMF) ; ;Fire the xrefs for all records or the record specified in DA I 'DA D . L +@DIROOT:DIKLOCK E D Q:$G(DIKLOCK("STOP")) .. S DIKLOCK="" .. D:DIF["D" ERR^DIKCU2(112,DIFILE) . D FIREALL(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT) . L:DIKLOCK]"" -@DIROOT E D . L +@DIROOT@(DA):DIKLOCK E D Q:$G(DIKLOCK("STOP")) .. S DIKLOCK="" .. D:DIF["D" ERR^DIKCU2(110,DIFILE,$$IENS^DIKCU(DIFILE,.DA)) . D:$D(@DIKTMP@(DIFILE)) FIRE(DIFILE,.DA,DIKLOG,DIKTMP,DIKON,"",DIKCT) . D:$D(DIMF(DIFILE)) FIRESUB(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT) . L:DIKLOCK]"" -@DIROOT@(DA) ; ;Cleanup ^TMP K @DIKTMP ; EXIT ;Move error messages if necessary I DIF["D",$G(DIERR),$G(DICTRL("MSG"))]"" D CALLOUT^DIEFU(DICTRL("MSG")) Q ; FIREALL(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs, all recs N DICNT,DIIENS,DILAST,DIXR S DILOG=$G(DILOG),DIKON=$G(DIKON) S DIIENS=$$IENS^DIKCU(DIFILE,.DA) ; ;Kill entire indexes I DILOG["K",$D(@DIKTMP@("KW",DIFILE)) D XECKW(DIFILE,.DA,$D(DIMF(DIFILE))>0) I '$D(@DIKTMP@(DIFILE)),'$D(DIMF(DIFILE)) Q ; ;Loop through all records in the file S (DICNT,DA)=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D . S $P(DIIENS,",")=DA . S DICNT=DICNT+1 . D:$D(@DIKTMP@(DIFILE)) FIRE(DIFILE,.DA,DILOG,DIKTMP,DIKON,.DIKEY,DIKCT,DIIENS) . D:$D(DIMF(DIFILE)) FIRESUB(DIFILE,.DA,DIROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT) ; ;Update header node I $D(@DIROOT@(0))#2 D . S DILAST=$O(@DIROOT@(" "),-1) S:'DILAST DILAST="" . S:'DICNT DICNT="" . S $P(@DIROOT@(0),U,4)=DICNT ;**DI*22*146 Q ; FIRE(DIFILE,DA,DILOG,DIKTMP,DIKON,DIKEY,DIKCT,DIIENS) ;Fire xrefs, one record N DI01,DIKCLOG,DINULL,DION,DIXR,I,J,X,X2,XN S DILOG=$G(DILOG),DIKON=$G(DIKON) S:$G(DIIENS)="" DIIENS=$$IENS^DIKCU(DIFILE,.DA) ; I DIKON="" S DIXR=0 F S DIXR=$O(@DIKTMP@(DIFILE,DIXR)) Q:DIXR'=+DIXR D . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL) Q:DINULL . I $G(DIKCT)="" D XECUTE(DIFILE,DIXR,DILOG,.X,.X,DIKTMP) Q . ; . K XN S XN="",I=0 F S I=$O(X(I)) Q:'I S XN(I)="" . I $G(DIKCT)="C" D XECUTE(DIFILE,DIXR,"S",.XN,.X,DIKTMP) Q . I $G(DIKCT)="T" D XECUTE(DIFILE,DIXR,"K",.X,.XN,DIKTMP) Q ; E S DIXR=0 F S DIXR=$O(@DIKTMP@(DIFILE,DIXR)) Q:DIXR'=+DIXR D . K DINFLD . S DIKCLOG="" . ; . ;Set X2 array to new values . S DION=$P(DIKON,U,2) . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION) M X2=X . ; . ;If SET requested, make sure no new values are null . I DILOG["S" D .. I 'DINULL S DIKCLOG="S" .. E I $P(DIKON,U,4)="N" S I=0 F S I=$O(^DD("KEY","AU",DIXR,I)) Q:'I D ... S DIKEY(DIFILE,I,DIIENS)="n" ... S J=0 F S J=$O(DINULL(J)) Q:'J S DIKEY(DIFILE,I,DIIENS,$P(DINULL(J),U),$P(DINULL(J),U,2))=$P(DINULL(J),U,3) . ; . ;Set X array to old values . S DION=$P(DIKON,U) . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION,.DI01) . ; . ;If KILL requested, make sure no old values are null . I DILOG["K",'DINULL S DIKCLOG="K"_DIKCLOG . ; . ;If "C" flag, set old .01 value to null . I $G(DIKCT)="C",$D(DI01) D .. S I=0 F S I=$O(DI01(I)) Q:'I S X(I)="" .. S:$O(DI01(0))=$O(X(0)) X="" .. S DIKCLOG=$TR(DIKCLOG,"K") . ; . ;If "T" flag, set all new values to null . I $G(DIKCT)="T" S X2="",I=0 F S I=$O(X2(I)) Q:'I S X2(I)="" . ; . ;Execute the kill and set logic . D XECUTE(DIFILE,DIXR,DIKCLOG,.X,.X2,DIKTMP) . ; . I DIKCLOG["S",$P(DIKON,U,3)="K",$D(^DD("KEY","AU",DIXR)) D .. Q:$$UNIQUE^DIKK2(DIFILE,DIXR,.X2,.DA,DIKTMP) .. S I=0 F S I=$O(^DD("KEY","AU",DIXR,I)) Q:'I S DIKEY(DIFILE,I,DIIENS)="" Q ; FIRESUB(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs for ;all subfiles under DIFILE, for all subrecords under DA Q:'$D(DIMF(DIFILE)) N DIMULTF,DISBFILE,DISBROOT,X S DILOG=$G(DILOG),DIKON=$G(DIKON) ; ;Push down the DA array D PUSHDA^DIKCU(.DA) ; ;Loop through DIMF array and fire xrefs for subfiles S DIMULTF=0 F S DIMULTF=$O(DIMF(DIFILE,DIMULTF)) Q:'DIMULTF D . S DISBROOT=$NA(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT) . S DISBFILE=DIMF(DIFILE,DIMULTF,0) . D FIREALL(DISBFILE,.DA,DISBROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT) ; ;Pop the DA array D POPDA^DIKCU(.DA) Q ; XECUTE(DIFILE,DIXR,DILOG,DIKCX1,DIKCX2,DIKTMP) ;Xecute the logic in ^TMP Q:$G(DILOG)="" N DIKCOD,DIKCON,X,X1,X2 ; ;Execute kill logic I DILOG["K" D . S DIKCOD=$G(@DIKTMP@(DIFILE,DIXR,"K")) Q:DIKCOD?."^" . S DIKCON=$G(@DIKTMP@(DIFILE,DIXR,"KC")) . I DIKCON'?."^" M X=DIKCX1,X1=DIKCX1,X2=DIKCX2 X DIKCON Q:'$G(X) K X,X1,X2 . M X=DIKCX1,X1=DIKCX1,X2=DIKCX2 . X DIKCOD K X,X1,X2 ; ;Execute set logic I DILOG["S" D . S DIKCOD=$G(@DIKTMP@(DIFILE,DIXR,"S")) Q:DIKCOD?."^" . S DIKCON=$G(@DIKTMP@(DIFILE,DIXR,"SC")) . I DIKCON'?."^" M X=DIKCX2,X1=DIKCX1,X2=DIKCX2 X DIKCON Q:'$G(X) K X,X1,X2 . M X=DIKCX2,X1=DIKCX1,X2=DIKCX2 . X DIKCOD Q ; XECKW(DIFILE,DA,DIKSUB) ;Execute the logic to kill the entire index N DIKFIL,DIKKW,DIKKW0,DIKLDIF,DIXR ; S DIXR=0 F S DIXR=$O(@DIKTMP@("KW",DIFILE,DIXR)) Q:DIXR'=+DIXR D . S DIKKW=$G(@DIKTMP@("KW",DIFILE,DIXR)) Q:DIKKW?."^" . S DIKKW0=$G(@DIKTMP@("KW",DIFILE,DIXR,0)) . ; . ;If not a whole file xref, kill the entire index and quit . I DIKKW0="" X DIKKW D Q .. I '$D(@DIKTMP@(DIFILE,DIXR,"S")) K @DIKTMP@(DIFILE,DIXR) .. E K @DIKTMP@(DIFILE,DIXR,"K"),@DIKTMP@(DIFILE,DIXR,"KC") . ; . ;Quit if this isn't a whole file xref or we're not doing subfiles . Q:$P(DIKKW0,U)'="W"!'$G(DIKSUB) . ; . ;Kill the whole index after pushing DA the appropriate amount . S DIKFIL=$P(DIKKW0,U,2),DIKLDIF=$P(DIKKW0,U,3) . D PUSHDA^DIKCU(.DA,DIKLDIF) . X DIKKW . I '$D(@DIKTMP@(DIKFIL,DIXR,"S")) K @DIKTMP@(DIKFIL,DIXR) . E K @DIKTMP@(DIKFIL,DIXR,"K"),@DIKTMP@(DIKFIL,DIXR,"KC") . D POPDA^DIKCU(.DA,DIKLDIF) Q ; SETXARR(DIFILE,DIXR,DIKTMP,DINULL,DION,DI01) ;Loop through DIKTMP and set X array. ;If any values used as subscripts are null, return ; DINULL=1 ; DINULL(order#) = "" ; or file^field^levDiff (for field type subscripts) ; DI01(order#) = "" if order # is .01 field ; N DIKCX,DIKF,DIKO,X1,X2 K X,DI01,DINULL S DINULL=0,(DIKF,DIKO)=$O(@DIKTMP@(DIFILE,DIXR,0)) Q:'DIKF ; S:$G(DION)="" DION=U F D S DIKO=$O(@DIKTMP@(DIFILE,DIXR,DIKO)) Q:'DIKO . K DIKCX M DIKCX=X . X $G(@DIKTMP@(DIFILE,DIXR,DIKO)) . I $G(X)]"",$D(@DIKTMP@(DIFILE,DIXR,DIKO,"T")) X @DIKTMP@(DIFILE,DIXR,DIKO,"T") . S:$D(X)#2 (DIKCX,DIKCX(DIKO))=X K X M X=DIKCX . S:$P($G(@DIKTMP@(DIFILE,DIXR,DIKO,"F")),U,2)=.01 DI01(DIKO)="" . I $G(X(DIKO))="",$G(@DIKTMP@(DIFILE,DIXR,DIKO,"SS")) S DINULL=1 S:$G(@DIKTMP@(DIFILE,DIXR,DIKO,"F")) DINULL(DIKO)=@DIKTMP@(DIFILE,DIXR,DIKO,"F") ; S:$D(X(DIKF))#2 X=$G(X(DIKF)) Q ; ;#110 The record is currently locked. ;#112 The file is currently locked. DIKC1 DIKC1 ;SFISC/MKO-LOAD XREF INFO ;19DEC2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;============================================ ; LOADALL(File,Log,Activ,ValRt,Tmp,Flag,.MF) ;============================================ ;Load all xrefs for a file. Uses the "AC" index on Root File. ;In: ; RFIL = Root File # ; LOG [ K : load kill logic ; [ S : load set logic ; ACT = Codes: IR ; If ACT '= null, a xref is picked up only if ACT ; and the Activity field (#.41) have codes in common. ; VALRT = Array Ref where old/new values are located ; TMP = Root to store xref info ; FLAG [ s : don't include subfiles under file ; [ i : don't load index-type xrefs (only load whole file xrefs) ; [ f : don't load field-type xrefs ; [ r : don't load record-type xrefs ; [ x : don't load "NOREINDEX" xrefs ; ;Out: ; MF(file#,mField#) = multiple node ; MF(file#,mField#,0) = subfile# ; Set only for those files/multiples that have xrefs ; and only if FLAG '[ "s" ; LOADALL(RFIL,LOG,ACT,VALRT,TMP,FLAG,MF) ; N XR ; ;Loop through "AC" index S XR=0 F S XR=$O(^DD("IX","AC",RFIL,XR)) Q:'XR D . ;Skip if no .01, wrong Activity, wrong Type, or wrong Execution . I $P($G(^DD("IX",XR,0)),U)="" K ^DD("IX","AC",RFIL,XR) Q . I $G(ACT)]"",$TR(ACT,$P(^DD("IX",XR,0),U,7),$TR($J("",$L($P(^(0),U,7)))," ","*"))'["*" Q . I $G(FLAG)["i",$P(^DD("IX",XR,0),U,8)="I" Q . I $G(FLAG)["f",$P(^DD("IX",XR,0),U,6)="F" Q . I $G(FLAG)["r",$P(^DD("IX",XR,0),U,6)="R" Q NOREIN .I $G(FLAG)["x",$G(^DD("IX",XR,"NOREINDEX")) Q ;PATCH 167 . ; . ;Load xref . D CRV^DIKC2(XR,$G(VALRT),TMP) . D:$G(LOG)]"" LOG^DIKC2(XR,LOG,TMP) . D:$G(LOG)["K" KW^DIKC2(XR,TMP) Q:$G(FLAG)["s" ; ;Build info for all subfiles under FILE into arrays SB and MF N CHK,FIL,MFLD,PAR,SB D SUBFILES^DIKCU(RFIL,.SB,.MF) ; ;Load xref for each subfile S:$G(FLAG)'["s" FLAG=$G(FLAG)_"s" S SB=0 F S SB=$O(SB(SB)) Q:'SB D . D LOADALL(SB,$G(LOG),$G(ACT),$G(VALRT),TMP,FLAG) . Q:'$D(@TMP@(SB)) . ; . ;Set CHK(f)="" flag for subfile and its antecedents . S PAR=SB F Q:$D(CHK(PAR)) S CHK(PAR)=1,PAR=$G(SB(PAR)) Q:PAR="" ; ;Use the CHK array to get rid of unneeded elements in MF S FIL=0 F S FIL=$O(MF(FIL)) Q:'FIL D . S MFLD=0 F S MFLD=$O(MF(FIL,MFLD)) Q:'MFLD D .. K:'$D(CHK(MF(FIL,MFLD,0))) MF(FIL,MFLD) Q ; ;======================================== ; LOADXREF(File,Fld,Log,.XRef,ValRt,Tmp) ;======================================== ;Load specified xrefs. Uses the "AC" index on Root file if Index ;Names are passed in. Also, uses the "F" index, if Field is passed in. ;In: ; RFIL = if FLD is not passed in : Root File or subfile# ; (required if XREF contains names) ; if FLD is passed in : The file of the field ; (defaults to Root file of XREF) ; FLD = Field # (optional) (if passed in, a specified index is ; loaded only if FLD is one of the cross-reference values. ; LOG [ K : load kill logic (incl. whole kill) ; [ S : load set logic ; .XREF = ^-delimited list of xref names or numbers; ; (overflow in XREF(n) where n=1,2,...) ; VALRT = Array Ref where old/new values are located ; TMP = Root to store info ; LOADXREF(RFIL,FLD,LOG,XREF,VALRT,TMP) ; N I,N,PC,RF,XR,XRLIST ; ;Loop through XREF array S N=0,XRLIST=$G(XREF) F Q:XRLIST="" D . ; . ;Loop through each xref in XRLIST . F PC=1:1:$L(XRLIST,U) K XR S XR=$P(XRLIST,U,PC) D:XR]"" .. ; .. ;Convert xref name to number, if necessary .. I XR'=+$P(XR,"E") D Q:$D(XR)<2 ... S I=0 F S I=$O(^DD("IX","AC",RFIL,I)) Q:'I D .... S:$P($G(^DD("IX",I,0)),U,2)=XR XR(I)="" .. E Q:$P($G(^DD("IX",XR,0)),U)="" S XR(XR)="" .. ; .. ;Load code from Cross-Reference Values multiple .. S XR=0 F S XR=$O(XR(XR)) Q:'XR D ... S RF=$P(^DD("IX",XR,0),U,9) ... I $G(FLD) Q:'$D(^DD("IX","F",$S($G(RFIL):RFIL,1:RF),FLD,XR)) ... E I $G(RFIL) Q:RFIL'=RF ... D CRV^DIKC2(XR,$G(VALRT),TMP) ... D:$G(LOG)]"" LOG^DIKC2(XR,LOG,TMP) ... D:$G(LOG)["K" KW^DIKC2(XR,TMP) . ; . ;Process next overflow . S N=$O(XREF(N)),XRLIST=$S(N:$G(XREF(N)),1:"") Q ; ;================================================================ ; LOADFLD(File,Field,Log,Activ,ValRt,TmpF,TmpR,FList,RList,Flag) ;================================================================ ;Get all xrefs for a field. Uses the "F" index on file/field. ;In: ; FIL = File # ; FLD = Field # ; LOG [ K : load kill logic ; [ S : load set logic ; [ W : load entire kill logic (if LOG also [ "K") ; ACT = codes: IR ; If ACT is not null, a xref is picked up only if ACT ; and the Activity field (#.41) have codes in common. ; VALRT = Array Ref where old/new values are located ; TMPF = Root to store field-level xref info ; TMPR = Root to store record-level xref info ; FLAG [ i : don't load index-type xrefs (only load whole file xrefs) ; [ f : don't load field-type xrefs ; [ r : don't load record-type xrefs ;Out: ; .FLIST = ^-delimited list of field xrefs (overflow in FLIST(n)) ; .RLIST = ^-delimited list of record xrefs (overflow in RLIST(n)) ; LOADFLD(FIL,FLD,LOG,ACT,VALRT,TMPF,TMPR,FLIST,RLIST,FLAG) ; N EXECFLD,TMP,XR K FLIST,RLIST S (FLIST,RLIST)=0,(FLIST(0),RLIST(0))="" S:$G(TMPR)="" TMPR=TMPF ; ;Loop through "F" index and pick up xrefs S XR=0 F S XR=$O(^DD("IX","F",FIL,FLD,XR)) Q:'XR D . I $P($G(^DD("IX",XR,0)),U)="" K ^DD("IX","F",FIL,FLD,XR) Q . S EXECFLD=$P(^DD("IX",XR,0),U,6) . I $G(ACT)]"",$TR(ACT,$P(^DD("IX",XR,0),U,7),$TR($J("",$L($P(^(0),U,7)))," ","*"))'["*" Q . I $G(FLAG)["i",$P(^DD("IX",XR,0),U,8)="I" Q . I $G(FLAG)["f",$P(^DD("IX",XR,0),U,6)="F" Q . I $G(FLAG)["r",$P(^DD("IX",XR,0),U,6)="R" Q . I $G(FLAG)["x",$G(^DD("IX",XR,"NOREINDEX")) Q . ; . ;Set TMP, RLIST, and FLIST . K TMP . I EXECFLD="R" D .. S TMP=$G(TMPR) .. I $L(RLIST(RLIST))+$L(XR)+1>255 S RLIST=RLIST+1,RLIST(RLIST)="" .. S RLIST(RLIST)=RLIST(RLIST)_$E(U,RLIST(RLIST)]"")_XR . E D .. S TMP=$G(TMPF) .. I $L(FLIST(FLIST))+$L(XR)+1>255 S FLIST=FLIST+1,FLIST(FLIST)="" .. S FLIST(FLIST)=FLIST(FLIST)_$E(U,FLIST(FLIST)]"")_XR . ; . ;Load xref . Q:$G(TMP)="" Q:$D(@TMP@(FIL,XR)) . D CRV^DIKC2(XR,$G(VALRT),TMP) . D:$G(LOG)]"" LOG^DIKC2(XR,LOG,TMP) . I $G(LOG)["K",$G(LOG)["W" D KW^DIKC2(XR,TMP) ; I FLIST(0)]"" S FLIST=FLIST(0) K FLIST(0) E K FLIST S FLIST="" I RLIST(0)]"" S RLIST=RLIST(0) K RLIST(0) E K RLIST S RLIST="" Q ; GETTMP(DIKC) ;Find next available root in ^TMP(DIKC) ;Time stamp ^TMP(DIKC,J) ;Out: ; Name of available ^TMP root; e.g. ^TMP("DIKC",$J+.01) ; N DAY,FREE,J S FREE=0 F J=$J:.01 D Q:FREE . S DAY=$G(^TMP(DIKC,J)) . I DAY<($H-1) K ^TMP(DIKC,J) S ^TMP(DIKC,J)=$H,FREE=1 Q $NA(^TMP(DIKC,J)) DIKC2 DIKC2 ;SFISC/MKO-CHECK INPUT PARAMETERS TO INDEX^DIKC ;19DEC2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;CHK: Check input parameters to INDEX^DIKC ;Also set: ; DA = DA array ; DIROOT = Closed root of file ; DIFILE = File # ; DIKERR = "X" : if there's a problem ; CHK ;File is a required input param I $G(DIFILE)="" D:DIF["D" ERR^DIKCU2(202,"","","","FILE") D ERR Q ; ;Check DIREC and set DA array I $G(DIREC)'["," M DA=DIREC E S:DIREC'?.E1"," DIREC=DIREC_"," D DA^DILF(DIREC,.DA) S:'$G(DA) DA="" I '$$VDA^DIKCU1(.DA,DIF) D ERR Q ; DICTRL ;Check DICTRL parameter I $G(DICTRL)]"",'$$VFLAG^DIKCU1(DICTRL,"KSsDWiRIkCTrfx",DIF) D ERR I $G(DICTRL)["W",'$$VFNUM^DIKCU1(+$P(DICTRL,"W",2),DIF) D ERR I $G(DICTRL)["C",$G(DICTRL)["T" D . D:DIF["D" ERR^DIKCU2(301,"","","","C and T") . D ERR E I $G(DICTRL)["C",$G(DICTRL)["K" D . D:DIF["D" ERR^DIKCU2(301,"","","","C and K") . D ERR E I $G(DICTRL)["T",$G(DICTRL)["S" D . D:DIF["D" ERR^DIKCU2(301,"","","","T and S") . D ERR Q:$G(DIKERR)="X" ; ;Set DIFILE and DIROOT N DILEV I DIFILE=+$P(DIFILE,"E") D . S DIROOT=$$FROOTDA^DIKCU(DIFILE,DIF,.DILEV) I DIROOT="" D ERR Q . I DILEV,$D(DA(DILEV))[0 D Q .. D:DIF["D" ERR^DIKCU2(205,"",$$IENS^DILF(.DA),"",DIFILE) D ERR . S:DILEV DIROOT=$NA(@DIROOT) . S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR E D . S DIROOT=DIFILE . S:"(,"[$E(DIROOT,$L(DIROOT)) DIROOT=$$CREF^DILF(DIFILE) . S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q . S DILEV=$$FLEV^DIKCU(DIFILE,DIF) I DILEV="" D ERR Q . I DILEV,$D(DA(DILEV))[0 D Q .. D:DIF["D" ERR^DIKCU2(205,"",$$IENS^DILF(.DA),"",DIFILE) D ERR ; ;Set DIKVAL,DIKON S DIKVAL=$G(DICTRL("VAL")) I DIKVAL]"" D . S:"(,_"'[$E(DIKVAL,$L(DIKVAL)) DIKVAL=$$OREF^DILF(DIKVAL) . S DIKON="O^N" E S DIKON="" Q ; ERR ;Set error flag S DIKERR="X" Q ; ;========================== ; CRV(Index,ValueRoot,TMP) ;========================== ;Load values from Cross Reference Values multiple into @TMP ;In: ; XR = Index # ; VALRT = Array Ref where old/new values are located ; TMP = Root of array to store data ;Returns: ; @TMP@(RootFile,Index#) = Name^File^RootType^Type ; Index#,Order#) = Code that sets X to the data ; Order#,"SS") = Subscript^MaxLength ; "T") = Transform (for 'Field'-type) ; "F") = file^field^levdiff(file,rFile) CRV(XR,VALRT,TMP) ; Q:'$G(XR)!($G(TMP)="") N CRV,CRV0,DEC,FIL,FLD,MAXL,ND,ORD,OROOT,RFIL,SBSC,TYPE ; S RFIL=$P($G(^DD("IX",XR,0)),U,9) Q:RFIL="" Q:$D(@TMP@(RFIL,XR)) S @TMP@(RFIL,XR)=$P(^DD("IX",XR,0),U,2)_U_$P(^(0),U)_U_$P(^(0),U,8)_U_$P(^(0),U,4) S OROOT=$$FROOTDA^DIKCU(RFIL,"O")_"DA," Q:OROOT="DA," ; S CRV=0 F S CRV=$O(^DD("IX",XR,11.1,CRV)) Q:'CRV D . S CRV0=$G(^DD("IX",XR,11.1,CRV,0)) . S ORD=$P(CRV0,U),TYPE=$P(CRV0,U,2),MAXL=$P(CRV0,U,5),SBSC=$P(CRV0,U,6) . Q:ORD=""!(TYPE="") . ; . I TYPE="F" D .. S FIL=$P(CRV0,U,3),FLD=$P(CRV0,U,4) Q:(FIL="")!'FLD .. I FIL'=RFIL N OROOT,LDIF D Q:$G(OROOT)="" ... S LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL) Q:'LDIF ... S OROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O") Q:OROOT="" ... S OROOT=OROOT_"DA("_LDIF_")," .. S DEC=$$DEC(FIL,FLD,$G(VALRT),OROOT) Q:DEC="" .. S @TMP@(RFIL,XR,ORD)=DEC .. S @TMP@(RFIL,XR,ORD,"F")=FIL_U_FLD_$S($G(LDIF):U_LDIF,1:"") .. S:$G(^DD("IX",XR,11.1,CRV,2))'?."^" @TMP@(RFIL,XR,ORD,"T")=^(2) . ; . E I TYPE="C" S @TMP@(RFIL,XR,ORD)=$G(^DD("IX",XR,11.1,CRV,1.5)) . ; . S:SBSC @TMP@(RFIL,XR,ORD,"SS")=SBSC_$S(MAXL:U_MAXL,1:"") Q ; ;====================================== ; $$DEC(File,Field,ValueRoot,OpenRoot) ;====================================== ;Return Data Extraction Code -- M code that sets X equal to the data. ;In: ; FIL = File # ; FLD = Field # ; VALRT = Array Ref where old/new values are located ; if ends in "_", FILE subscript is concatenated to the last ; subscript (used by DDS02) ; OROOT = Open root of record w/ DA subscripts ;Returns: M code ; For example: ; S X=$P(^DIZ(1000,DA(1),100,0),U,2) or ; S X=$E(^DIZ(1000,DA(1),100,1),1,245) or ; S X=$G(array(file,DIIENS,field,DION),$P(^root(DA,nd),U,pc)) ; DEC(FIL,FLD,VALRT,OROOT) ; Q:$P($G(^DD(FIL,FLD,0)),U)="" "" ; N ND,PC,DEC S PC=$P($G(^DD(FIL,FLD,0)),U,4) S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." "!("0 "[PC) "" S:ND'=+$P(ND,"E") ND=""""_ND_"""" ; I $G(OROOT)="" S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA," "" I PC S DEC="$P($G("_OROOT_ND_")),U,"_PC_")" E S DEC="$E($G("_OROOT_ND_")),"_+$E(PC,2,999)_","_$P(PC,",",2)_")" ; I $G(VALRT)]"" D . I $E(VALRT,$L(VALRT))="_" D Q .. S VALRT=$E(VALRT,1,$L(VALRT)-3) .. S DEC="$G("_VALRT_FIL_""",DIIENS,"_FLD_",DION),"_DEC_")" . S:"(,"'[$E(VALRT,$L(VALRT)) VALRT=$$OREF^DILF(VALRT) . S DEC="$G("_VALRT_FIL_",DIIENS,"_FLD_",DION),"_DEC_")" S DEC="S X="_DEC Q DEC ; ;====================== ; LOG(Index,Logic,TMP) ;====================== ;Load Set and/or Kill logic into into @TMP ;In: ; XR = Index # ; LOG [ K : load kill logic ; [ S : load set logic ; TMP = Root of array to store data ;Returns: ; @TMP@(RootFile,Index#,"S") = Set logic ; "SC") = Set condition ; "K") = Kill logic ; "KC") = Kill condtion LOG(XR,LOG,TMP) ; Q:'$G(XR) Q:$G(LOG)="" Q:$G(TMP)="" N SL,KL,SC,KC,RFIL ; S RFIL=$P(^DD("IX",XR,0),U,9) Q:RFIL="" I LOG["S" D . S SL=$G(^DD("IX",XR,1)),SC=$G(^(1.4)) . I "Q"'[SL,SL'?."^" S @TMP@(RFIL,XR,"S")=SL . I "Q"'[SC,SC'?."^" S @TMP@(RFIL,XR,"SC")=SC I LOG["K" D . S KL=$G(^DD("IX",XR,2)),KC=$G(^(2.4)) . I "Q"'[KL,KL'?."^" S @TMP@(RFIL,XR,"K")=KL . I "Q"'[KC,KC'?."^" S @TMP@(RFIL,XR,"KC")=KC Q ; ;=============== ; KW(Index,TMP) ;=============== ;Load Kill Entire Index logic into @TMP ;In: ; XR = Index # ; TMP = Root of array to store data ;Returns: ; @TMP@("KW",File#[.01],Index#) = Kill Entire Index logic ; Index#,0) = Type ("W" for whole-file index) ; ^RootFile ; ^Level difference between top file ; and root file KW(XR,TMP) ;Get Kill Entire Index logic Q:'$G(XR)!($G(TMP)="") N FILE,KW,RFIL,TYPE S KW=$G(^DD("IX",XR,2.5)) Q:KW="Q"!(KW?."^") S FILE=$P($G(^DD("IX",XR,0)),U),TYPE=$P(^(0),U,8),RFIL=$P(^(0),U,9) Q:FILE=""!(RFIL="") ; S @TMP@("KW",FILE,XR)=KW S:RFIL'=FILE @TMP@("KW",FILE,XR,0)=TYPE_U_RFIL_U_$$FLEVDIFF^DIKCU(FILE,RFIL) Q ; ;#202 The input parameter that identifies the |1| is missing or invalid. ;#205 File# |1| and IEN string |IENS| represent different subfile levels. ; DIKCBLD DIKCBLD ;SFISC/MKO-AUTOBUILD A ROUTINE THAT CALLS CREIXN^DDMOD ; 15NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; MAIN ;Main process N DIKCRTN,DIKCNMSP,DIKCITL,DIKCXR,% ; ;Check save code D:'$D(DISYS) OS^DII I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q ; ;Gather information from user Q1 S DIKCRTN=$$ASKRTN Q:U[DIKCRTN Q2 S DIKCITL=$$ASKITL Q:DIKCITL[U I DIKCITL="" W ! G Q1 Q3 S DIKCNMSP=$$ASKNMSP Q:DIKCNMSP[U I DIKCNMSP="" W ! G Q2 Q4 S DIKCXR=$$ASKXR() I 'DIKCXR W ! G Q3 ; ;Build and save routine D BUILD(DIKCRTN,DIKCITL,DIKCNMSP,DIKCXR) D SAVE(DIKCRTN) ; ;Final message and clean up W !!," Done!" W !!," Be sure to edit the routine to fill in the missing details," W !," and to customize the call to CREIXN^DDMOD." W ! K ^UTILITY($J) Q ; BUILD(DIKCRTN,DIKCITL,NS,XR) ;Build routine DIKCRTN N CV K ^UTILITY($J) D AD(DIKCRTN_" ;xxxx/"_DIKCITL_"-CREATE NEW-STYLE XREF ;") D AD(" ;;1.0") D AD(" ;") D AD(" N "_NS_"XR,"_NS_"RES,"_NS_"OUT") D BC(NS,XR,"FILE",0,1) D:$P($G(^DD("IX",XR,0)),U,8)="W" BC(NS,XR,"ROOT FILE",0,9) D BC(NS,XR,"NAME",0,2) D BC(NS,XR,"TYPE",0,4) D BC(NS,XR,"USE",0,14) D BC(NS,XR,"EXECUTION",0,6) D BC(NS,XR,"ACTIVITY",0,7) D BC(NS,XR,"SHORT DESCR",0,3) D BCW(NS,XR,"DESCR",.1) D:$P($G(^DD("IX",XR,0)),U,4)="MU" . D BC(NS,XR,"SET",1) . D BC(NS,XR,"KILL",2) . D BC(NS,XR,"WHOLE KILL",2.5) D BC(NS,XR,"SET CONDITION",1.4) D BC(NS,XR,"KILL CONDITION",2.4) ; S CV=0 F S CV=$O(^DD("IX",XR,11.1,CV)) Q:'CV D . N ON,TP,VAL . S ON=$P($G(^DD("IX",XR,11.1,CV,0)),U) Q:'ON . S TP=$P($G(^DD("IX",XR,11.1,CV,0)),U,2) . I TP="F" D .. S VAL=$P($G(^DD("IX",XR,11.1,CV,0)),U,4) Q:'VAL .. D AD(" S "_NS_"XR(""VAL"","_ON_")="_VAL) . E D .. S VAL=$G(^DD("IX",XR,11.1,CV,1.5)) Q:VAL="" .. D AD(" S "_NS_"XR(""VAL"","_ON_")="_$$QT(VAL)) . D BCC(NS,XR,CV,ON,"SUBSCRIPT",0,6) . D BCC(NS,XR,CV,ON,"LENGTH",0,5) . D BCC(NS,XR,CV,ON,"COLLATION",0,7) . D BCC(NS,XR,CV,ON,"LOOKUP PROMPT",0,8) . D:TP="F" .. D BCC(NS,XR,CV,ON,"XFORM FOR STORAGE",2) .. D BCC(NS,XR,CV,ON,"XFORM FOR LOOKUP",4) .. D BCC(NS,XR,CV,ON,"XFORM FOR DISPLAY",3) ; D AD(" D CREIXN^DDMOD(."_NS_"XR,""SW"",."_NS_"RES,"""_NS_"OUT"")") D AD(" Q") ; Q BC(NS,XR,SUB,ND,PC) ;Build code that sets an array element N VAL I $G(PC)="" S VAL=$G(^DD("IX",XR,ND)) E S VAL=$P($G(^DD("IX",XR,ND)),U,PC) Q:VAL="" D AD(" S "_NS_"XR("""_SUB_""")="_$$QT(VAL)) Q ; BCW(NS,XR,SUB,ND) ;Build code that sets array for wp field N I,VAL S I=0 F S I=$O(^DD("IX",XR,ND,I)) Q:'I D . S VAL=$G(^DD("IX",XR,ND,I,0)) S:VAL="" VAL=" " . D AD(" S "_NS_"XR("""_SUB_""","_I_")="_$$QT(VAL)) Q ; BCC(NS,XR,CV,ON,SUB,ND,PC) ;Build code that sets an array element N VAL I $G(PC)="" S VAL=$G(^DD("IX",XR,11.1,CV,ND)) E S VAL=$P($G(^DD("IX",XR,11.1,CV,ND)),U,PC) Q:VAL="" D AD(" S "_NS_"XR(""VAL"","_ON_","""_SUB_""")="_$$QT(VAL)) Q ; QT(X) ;Return string X quoted, if noncanonic Q:$G(X)="" """""" Q:X=+$E($P(X,"E"),1,15) X S X(X)="",X=$Q(X("")) Q $E(X,3,$L(X)-1) ; AD(X) ;Add a routine line to ^UTILITY N LN S LN=$O(^UTILITY($J,0," "),-1)+1 S ^UTILITY($J,0,LN)=X Q ; SAVE(DIKCRTN) ;Save routine DIKCRTN N X,%Y S ^UTILITY($J,0,1)=^UTILITY($J,0,1)_$$NOW S X=DIKCRTN X ^DD("OS",DISYS,"ZS") W !!,$$EZBLD^DIALOG(8025,DIKCRTN) Q ; ASKRTN() ;Prompt for routine name; return ^ if timeout, null, or ^ N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="FO^1:8^K:X?.E1.C.E!'(X?1""%""1.7AN!(X?1A1.7AN)) X" S DIR("A")="Routine name" S DIR("?",1)=" Enter the name of the routine, without the leading up-arrow, that" S DIR("?",2)=" should be built." S DIR("?",3)="" S DIR("?",4)=" Answer must be 1-8 characters in length. It must begin with % or a" S DIR("?")=" letter, followed by a combination of letters and numbers." F D Q:$G(DIKCRTN)]"" . D ^DIR I $D(DIRUT) S DIKCRTN=U Q . S DIKCRTN=X . Q:$T(^@X)="" ; routine doesn't exist; overwrite okay. VEN/SMH . Q:$$ASKREPL(DIKCRTN) . S DIKCRTN="" Q $G(DIKCRTN) ; ASKREPL(DIKCRTN) ;Ask whether to replace the existing routine N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="YO" S DIR("A")=" Do you wish to replace routine "_DIKCRTN S DIR("B")="NO" S DIR("?")=" Answer yes if you wish to replace routine "_DIKCRTN_" with a new version." W !!," Routine "_DIKCRTN_" already exists." D ^DIR W ! Q Y ; ASKITL() ;Ask for programmer initials N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="FO^1:15" S DIR("A")="Programmer initials" S DIR("?",1)=" Enter your initials, which will appear on the first line of the" S DIR("?")=" routine." D ^DIR Q Y ; ASKNMSP() ;Prompt for a namespace N DIR,X,Y,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="FO^1:4^K:X?.E1.C.E!'(X?1""%""1.3AN!(X?1A1.3AN)) X" S DIR("A")="Namespace to use for local variables" S DIR("?",1)=" All variables used in the generated routine will start with the namespace" S DIR("?",2)=" you choose." S DIR("?",3)="" S DIR("?",4)=" Answer must be 1-4 characters in length. It must begin with % or a" S DIR("?")=" letter, followed by a combination of letters and numbers." D ^DIR Q Y ; ASKXR() ;Prompt for file/xref N DIKCCNT,DIKCROOT,DIKCTOP,DIKCFILE,DDS1,D,DIC,X,Y S DDS1="CROSS-REFERENCE FROM: " D W^DICRW Q:Y<0 "" S DIKCTOP=+$P($G(@(DIC_"0)")),U,2) Q:'DIKCTOP "" S DIKCFILE=$$SUB^DIKCU(DIKCTOP) ; D GETXR^DIKCUTL2(DIKCFILE,.DIKCCNT) W ! D LIST^DIKCUTL2(.DIKCCNT) Q $$CHOOSE^DIKCUTL2(.DIKCCNT,"to build a routine for") ; NOW() ;Return current time in external form N %,%I,%H,AP,HR,MIN,MON,TIM,X D NOW^%DTC S TIM=$P(%,".",2) S HR=$E(TIM,1,2) S AP=$S(HR<12:"AM",1:"PM") S HR=$S(HR<13:+HR,1:HR#12) S MIN=$E(TIM_"0000",3,4) ; S MON=$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec",U,%I(1)) Q HR_":"_MIN_" "_AP_" "_%I(2)_" "_MON_" "_(%I(3)+1700) DIKCDD DIKCDD ;SFISC/MKO-DATA DICTIONARY CODE FOR INDEX AND KEY FILES ;3:02 PM 5 Dec 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ITFLD ;Input transform for field Q:'$D(DA)!'$D(DA(1))!'$D(DDS) N DIKCFILE S DIKCFILE=$$GETFILE(.DA) I 'DIKCFILE K X Q ; N %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,DZ,Y S DIC="^DD("_DIKCFILE_",",DIC(0)="EN" S DIC("S")="I '$P(^(0),U,2)&($P(^(0),U,2)'[""C"")" D ^DIC I Y'>0 K X E S X=+$P(Y,"E") Q ; EHFLD ;Executable help for field Q:'$D(DA)!'$D(DA(1))!'$D(DDS) N DIKCFILE S DIKCFILE=$$GETFILE(.DA) Q:'DIKCFILE ; N %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,Y S DIC="^DD("_DIKCFILE_",",DIC(0)="",D="B" S DIC("S")="I '$P(^(0),U,2)&($P(^(0),U,2)'[""C"")" S:$G(X)="??" DZ=X D DQ^DICQ Q ; GETFILE(DA) ; Q:'$D(DA)!'$D(DA(1))!'$D(DDS) N DIKCFILE S DIKCFILE=$$GET^DDSVAL(.114,.DA,2) Q DIKCFILE DIKCFORM DIKCFORM ;SFISC/MKO-ENTRY POINTS FOR THE 'DIKC EDIT' FORM ;2:57 PM 25 Apr 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;========================== ; [DIKC EDIT] entry points ;========================== ; TYPEVAL ;Validation on Type (#.2) Q:DDSOLD="" I X'="MU"!($G(DUZ(0))'="@") D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"You can only change the Type of cross reference to MUMPS, and only if you're a programmer.") ; I X="MU",$P($G(^DD(+$$FNO^DILIBF($$GET^DDSVAL(.11,DA,.01)),0,"DI")),U)="Y" D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Cannot create MUMPS cross references on archived files.") Q TYPECHG ;Post action on change for Type (#.2) N NAME,USE S USE=$$GET^DDSVAL(.11,DA,.42) Q:USE]"" S NAME=$$GET^DDSVAL(.11,DA,.02) I NAME]"",$E(NAME)'="A" D PUT^DDSVAL(.11,DA,.42,"LS","","I") Q ; NAMEVAL ;Validation for Name (#.02) Q:$P(^DD("IX",DA,0),U,2)=X I X="" D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Index Name is a required field.") ; N F01,TYPE ; S F01=$$GET^DDSVAL(.11,DA,.01) I $D(^DD("IX","BB",F01,X)) D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"A"_$E("n","AEIOUaeiou"[$E(X))_" '"_X_"' Index already exists.") ; I $D(^DD(F01,0,"IX",X)) D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"A"_$E("n","AEIOUaeiou"[$E(X))_" '"_X_"' cross-reference already exists.") ; I $E(X)="A",$D(^DD("KEY","AU",DA)) D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Uniqueness Index Name cannot start with 'A'.") Q ; NAMECHG ;Post action on change for Name (#.02) N SORT1,SORT2,USE S USE=$$GET^DDSVAL(.11,DA,.42) S SORT1=$E(DDSOLD)="A",SORT2=$E(X)="A" D:SORT1'=SORT2!(USE="") PUT^DDSVAL(.11,DA,.42,$S(SORT2:"S",1:"LS"),"","I") D BLDLOG^DIKCFORM(DA) Q ; USEVAL ;Validation for Use (#.42) N NAME,TYPE S NAME=$$GET^DDSVAL(.11,DA,.02) S TYPE=$$GET^DDSVAL(.11,DA,.2) I NAME=""!(TYPE="") D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Please enter a NAME and TYPE for this Index.") ; I X="S" D:$E(NAME)'="A" . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Indexes used for Sorting Only must start with 'A'.") E I X="LS" D:$E(NAME)="A" . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Indexes used for Lookup & Sorting cannot start with 'A'.") E I TYPE="R" D . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Only MUMPS Indexes can be Action-type Indexes.") E I $E(NAME)'="A" D . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Action-type Indexes must start with 'A'.") Q ; VALLOG ;Called from data validation of logic fields I $G(DUZ(0))'="@" D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Only programmers are allowed to edit index logic.") ; I $$GET^DDSVAL(DIE,.DA,.2,"","I")'="MU" D Q . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"You can modify the logic of only 'MUMPS' indexes.") Q ; BLDLOG(DIXR) ;Build the logic of the cross reference ;Called from post actions of fields on form [DIKC EDIT] N TYPE S TYPE=$$GET^DDSVAL(.11,DIXR,.2) I TYPE="MU" D UPDEXEC(DIXR) Q ; N FILE,NAME,RTYPE,RFILE S FILE=$$GET^DDSVAL(.11,DIXR,.01) S NAME=$$GET^DDSVAL(.11,DIXR,.02) S RTYPE=$$GET^DDSVAL(.11,DIXR,.5) S RFILE=$$GET^DDSVAL(.11,DIXR,.51) ; N LDIF,LEV,ROOT,WKILL I FILE'=RFILE Q:RTYPE'="W" S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE) E S LDIF=0 S ROOT=$$FROOTDA^DIKCU(FILE,LDIF_"O",.LEV)_""""_NAME_"""" S WKILL="K "_ROOT_")" ; N CNT,CRV,FCNT,MAXL,ORD,SBSC,VAL S CRV(1)=DIXR S CRV=0 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D:$G(^(CRV,0))'?."^" . S ORD=$$GET^DDSVAL(.114,.CRV,.01) Q:'ORD . S:$$GET^DDSVAL(.114,.CRV,1)="F" FCNT=$G(FCNT)+1 . S CNT=$G(CNT)+1 . S SBSC=$$GET^DDSVAL(.114,.CRV,.5) Q:'SBSC . S MAXL=$$GET^DDSVAL(.114,.CRV,6) . S SBSC(SBSC)=ORD_U_MAXL ; S SBSC=0 F S SBSC=$O(SBSC(SBSC)) Q:'SBSC D . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2) . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X") . E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")") . S ROOT=ROOT_","_VAL ; N L F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")" S ROOT=ROOT_",DA)" ; N SET,KILL I '$O(SBSC(0)) S (SET,KILL)="Q",WKILL="" E S SET="S "_ROOT_"=""""",KILL="K "_ROOT D PUT^DDSVAL(.11,DIXR,1.1,SET) D PUT^DDSVAL(.11,DIXR,2.1,KILL) D PUT^DDSVAL(.11,DIXR,2.5,WKILL) D PUT^DDSVAL(.11,DIXR,.4,$S($G(FCNT)>1:"R",1:"F"),"","I") Q ; CRVTYPE ;Post-Action on change for Cross-Reference Value -> Type of Value N DIKCIENS S DIKCIENS=DA_","_DA(1)_"," ; I X="F" D . D REQ^DDSUTL("FILE",1,2.1,1,DIKCIENS) . D REQ^DDSUTL("FIELD",1,2.1,1,DIKCIENS) . D REQ^DDSUTL("COMPUTED CODE",1,2.2,0,DIKCIENS) . D PUT^DDSVAL(DIE,.DA,4,"") . D PUT^DDSVAL(DIE,.DA,4.5,"") E D . D REQ^DDSUTL("FILE",1,2.1,0,DIKCIENS) . D REQ^DDSUTL("FIELD",1,2.1,0,DIKCIENS) . D REQ^DDSUTL("COMPUTED CODE",1,2.2,1,DIKCIENS) . D PUT^DDSVAL(DIE,.DA,2,"") . D PUT^DDSVAL(DIE,.DA,3,"") ; D UPDEXEC(DA(1)) Q ; UPDEXEC(DIXR) ;Update Execution based on number of field-type xref values N CRV,FCNT S CRV(1)=DIXR,CRV=0 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D . Q:'$$GET^DDSVAL(.114,.CRV,.01) . S:$$GET^DDSVAL(.114,.CRV,1)="F" FCNT=$G(FCNT)+1 D PUT^DDSVAL(.11,DIXR,.4,$S($G(FCNT)>1:"R",1:"F"),"","I") Q ; BKPRE21 ;Pre-Action for block 'DIKC EDIT FIELD CRV' N X S X=$$GET^DDSVAL(DIE,.DA,5) D TRANS Q ; TRANS ;Post-Action on Change for Transform for Storage N DIKCIENS S DIKCIENS=DA_","_DA(1)_"," I X]"" D . D UNED^DDSUTL("TRANSFORM FOR DISPLAY",1,2.1,0,DIKCIENS) E D . D PUT^DDSVAL(DIE,.DA,5.5,"") . D UNED^DDSUTL("TRANSFORM FOR DISPLAY",1,2.1,1,DIKCIENS) Q ; VALFILE ;Data Validation for File Q:X="" Q:X=DDSOLD N LDIF,RFILE S RFILE=$$GET^DDSVAL(.11,DA,.51) ; I X'=RFILE D . S LDIF=$$FLEVDIFF^DIKCU(X,RFILE) . I LDIF="" D Q .. D HLP^DDSUTL($C(7)_"File must be a parent (ancestor) of Root File.") .. S DDSERROR=1 . D:DDSOLD=RFILE PUT^DDSVAL(.11,DA,.5,"W","","I") E D:DDSOLD'=RFILE PUT^DDSVAL(.11,DA,.5,"I","","I") Q ; FORMDV ;Form-Level Data Validation ;Check that Subscript Numbers are unique and consecutive from 1. N DIKCDA,DIKCI,DIKCLIST,DIKCSS,DIKCSQ ; ;Build list DIKCLIST(ss#,ien) while checking for duplicates. ;Also check that a file# is assigned for Field-type CRVs and that ;they it is equal to root file. S DIKCDA(1)=DA S DIKCDA=0 F S DIKCDA=$O(^DD("IX",DA,11.1,DIKCDA)) Q:'DIKCDA D . I $$GET^DDSVAL(.114,.DIKCDA,1)="F" D .. N DIKCFIL,DIKCMSG,DIKCRF .. S DIKCFIL=$$GET^DDSVAL(.114,.DIKCDA,2) .. I DIKCFIL="" D ... D:'$D(DDSERROR) MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES") ... S DDSERROR=1 ... S DIKCMSG(1)="FILE for Order #"_$$GET^DDSVAL(.114,.DIKCDA,.01)_" is missing." ... S DIKCMSG(2)=" To correct the problem, press at the Order # on Page 2." ... S DIKCMSG(3)=" In the resulting pop-up page, FILE will be filled in automatically." ... S DIKCMSG(4)=" Try saving again." ... D MSG^DDSUTL(.DIKCMSG) .. E S DIKCRF=$$GET^DDSVAL(.11,DA,.51) I DIKCFIL'=DIKCRF D ... D:'$D(DDSERROR) MSG ... S DDSERROR=1 ... D MSG^DDSUTL("FILE for Order #"_$$GET^DDSVAL(.114,.DIKCDA,.01)_" is not equal to the Root File: "_DIKCRF_".") . S DIKCSS=$$GET^DDSVAL(.114,.DIKCDA,.5) Q:'DIKCSS . I $D(DIKCLIST(DIKCSS)) D .. D:'$D(DDSERROR) MSG .. S DDSERROR=1 .. D MSG^DDSUTL("The subscript number "_DIKCSS_" is used more than once.") . E S DIKCLIST(DIKCSS,DIKCDA)="" ; ;If no duplicates, check that subscript numbers are consecutive from 1 I '$D(DDSERROR) D . S DIKCSS=0 . F DIKCI=1:1 S DIKCSS=$O(DIKCLIST(DIKCSS)) Q:'DIKCSS!$G(DDSERROR) D:DIKCSS'=DIKCI .. S DDSERROR=1 .. D MSG .. D MSG^DDSUTL("Subscript numbers must be consecutive numbers starting with 1.") Q ; MSG ;Print message D MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES") Q ; POSTSV ;Post Save ;Clean-up global (get rid of null nodes) ;Kill DIKCREB, the flag that indicates that a crv was deleted, but ;the logic wasn't yet saved. N CRV,ND S CRV=0 F S CRV=$O(^DD("IX",DA,11.1,CRV)) Q:'CRV D . F ND=1.5,2,3 I $D(^DD("IX",DA,11.1,CRV,ND))#2,^(ND)="" K ^(ND) K DIKCREB Q DIKCP DIKCP ;SFISC/MKO-PRINT INDEX(ES) ;11:33 AM 1 Nov 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;============================== ; PRINT(File,Field,Flag,.Page) ;============================== ;In: ; FIL = File # ; FLD = Field # (optional) (ignored if FLAG [ M) ; FLAG [ Cn : column tab stop from left margin (def=18) ; [ F : print field-level indexes ; [ Ln : left margin (def=0) ; [ M : include subfiles (multiples) under File ; [ N : don't print any mumps code ; [ O : print traditional 1-node cross references ; [ R : print record-level indexes ; [ S : single space (no blank lines) ; [ Tn : type (style) of 1st lines of each xref ; PAGE("H") = header text or M code that begins with a write statement ; If text : eop read issued; and @IOF, PAGE("H") ; is written automatically ; If M code : code must issue eop read, write @IOF, and ; write the header. ; undefined : no paging ; ; PAGE("B") = bottom margin ;Out: ; PAGE(U) = returns as 1, if timeout or ^ at eop ;Notes: ; Type 0 : Used for the listings at the beg and end of report. ; First line looks like: ; AC (#30) REGULAR FIELD IR SORTING ONLY ; ; Type 1 : Used for the listing with each field. ; First line looks like: ; FIELD INDEX: AC (#30) REGULAR IR SORTING ONLY ; PRINT(FIL,FLD,FLAG,PAGE) ;Print all indexes on one file(/field) Q:'$G(FIL) N HSTR,LM,SB,TOP,TS,TYP,WID ; ;Initialize variables D INIT ; ;M flag, print file and subfile indexes I FLAG["M" D . D SUBFILES^DIKCU(FIL,.SB) . S TOP=1 F D Q:PAGE(U) S FIL=$O(SB(FIL)) Q:'FIL .. I FLAG["R"!(FLAG["F"),$D(^DD("IX","AC",FIL)) D ... D PRFILE(FIL,"",FLAG,.PAGE) .. E I FLAG["O",$D(^DD(FIL,"IX")) D ... D PRFILE(FIL,"",FLAG,.PAGE) .. I $G(TOP) S FIL=0 K TOP ; E D PRFILE(FIL,$G(FLD),FLAG,.PAGE) Q ; PRFILE(FIL,FLD,FLAG,PAGE) ;Print indexes for 1 file Q:'$G(FIL) N FHDR,HDR,NAM,NO,XR,XRL I $G(FLAG)'["i" N LM,TS,TYP,WID D INIT ; ;Print traditional xrefs I FLAG["O" D PRFILE^DIKCP3(FIL,$G(FLD),FLAG,.PAGE,.FHDR) Q:PAGE(U) I FLAG'["F",FLAG'["R" Q ; ;Print indexes I $G(FLD)="" D . ;Build list of xrefs sorted by name . S XR=0 F S XR=$O(^DD("IX","AC",FIL,XR)) Q:'XR D .. Q:$G(^DD("IX",XR,0))?."^" Q:FLAG'[$P(^(0),U,6) S NAM=$P(^(0),U,2) .. S:NAM="" NAM=" ",NO=$G(NO)+1 .. S XRL(NAM,XR)="" . ; . ;Loop through sorted list . S NAM="" F S NAM=$O(XRL(NAM)) Q:NAM="" D Q:PAGE(U) .. S XR=0 F S XR=$O(XRL(NAM,XR)) Q:'XR D Q:PAGE(U) ... I '$G(FHDR) D FHDR(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U) ... I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U) ... D PRINDEX(XR,FLAG,.PAGE) Q:PAGE(U) ... D WRLN("",0,.PAGE) Q:PAGE(U) ... I FLAG'["S" D WRLN("",0,.PAGE) ; E S XR=0 F S XR=$O(^DD("IX","F",FIL,FLD,XR)) Q:'XR D Q:PAGE(U) . Q:$D(^DD("IX",XR,0))?."^" Q:FLAG'[$P(^(0),U,6) . I '$G(FHDR) D FHDR(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U) . I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U) . D PRINDEX(XR,FLAG,.PAGE) Q:PAGE(U) . D WRLN("",0,.PAGE) Q:PAGE(U) . I FLAG'["S" D WRLN("",0,.PAGE) Q ; PRINDEX(XR,FLAG,PAGE) ;Print one index G PRINDEX^DIKCP1 ; HDR(FIL,FLAG,LM,PAGE,HDR) ;Print header for indexes S HDR=1 I FLAG'["M",FLAG'["O" Q D WRLN($S(FLAG["R"&(FLAG["F"):"New-Style",FLAG["R":"Record",1:"Field")_" Indexes:",LM,.PAGE,2) Q:PAGE(U) D WRLN("",0,.PAGE) Q ; FHDR(FIL,FLAG,PAGE,FHDR) ;Print header for file S FHDR=1 Q:FLAG'["M" D WRLN($P("F^Subf",U,$D(^DD(FIL,0,"UP"))#2+1)_"ile #"_FIL,0,.PAGE,2) Q:PAGE(U) D WRLN("",0,.PAGE) Q ; ;============================= ; LIST(File,Field,Flag,.Page) ;============================= ;List Indexes that reside on a given file. ;In: ; Same as PRINT above (except that N and O flag don't apply) ;Out: ; PAGE(U) = Returns as 1, if timeout or ^ at eop ;Notes: ; Type 0 : Used for the listing of Indexes on a file or subfile ; INDEXED BY: ANOTHER FIELD (AC), SET & FREE (C), ; ANOTHER FIELD & EXTRACT (D) ; ; Type 1 : Used for the listing of Record Indexes with each field. ; RECORD INDEXES: WF (#22) [WHOLE FILE on #9999)], ; WF (#24), AC (#52) ; LIST(FIL,FLD,FLAG,PAGE) ; Q:'$G(FIL) N LAB,LM,SB,SUB,TS,TYP,WID ; ;Initialize variables D INIT ; ;Set label I TYP=1 D . I FLAG["R",FLAG["F" S LAB="INDEXES: " . E I FLAG["R" S LAB="RECORD INDEXES: " . E S LAB="FIELD INDEXES: " E S LAB="INDEXED BY: " S LAB=LAB_$J("",TS-$L(LAB)) ; ;M flag, get and list for file and subfiles I FLAG["M" D . D SUBFILES^DIKCU(FIL,.SB) . S SUB="" . F D Q:PAGE(U) S:SUB="" SUB="SUB",FIL=0 S FIL=$O(SB(FIL)) Q:'FIL .. Q:'$D(^DD("IX","B",FIL)) .. I SUB]""!(FLAG'["S") D WRLN("",0,.PAGE) Q:PAGE(U) .. D WRLN(SUB_"FILE #"_FIL,LM,.PAGE,1) Q:PAGE(U) .. D LFILE(FIL,"",FLAG,LAB,.PAGE) Q:PAGE(U) ; ;Otherwise, just list for one file E D . I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U) . D LFILE(FIL,$G(FLD),FLAG,LAB,.PAGE) Q ; LFILE(FIL,FLD,FLAG,LAB,PAGE) ;Format list of indexes and print G LFILE^DIKCP2 ; INIT ;Initialize module-wide variables Q:$G(FLAG)["i" S FLAG=$G(FLAG)_"i" I FLAG'["F",FLAG'["R",FLAG'["O" S FLAG="OFR"_FLAG S LM=+$P(FLAG,"L",2)\1 S TS=+$P(FLAG,"C",2) S:'TS TS=18 S TYP=+$P(FLAG,"T",2)\1 S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1 S PAGE(U)="" Q ; ;=================================== ; WRLN(Text,Tab,.Page,KeepWithNext) ;=================================== ;Write a single line of text, precede with a !, do paging if necessary ;In: ; TXT = Text to write; $C(0) replaced with spaces. ; TAB = ?Tab before writing text (def=0) ; PAGE("H") = Header text or M code that begins with a write statement ; If not passed in, no paging. ; PAGE("B") = Bottom margin ; KWN = Additional padding on bottom margin ("keep with next") ;Out: ; PAGE(U) = Returns as 1, if timeout or ^ at eop ; WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text N X S PAGE(U)="" ; ;Do paging, if necessary I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U) . I PAGE("H")?1"W ".E X PAGE("H") Q . I $E($G(IOST,"C"))="C" D Q:PAGE(U) .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1 . W @$G(IOF,"#"),PAGE("H") ; ;Write text W !?$G(TAB),$TR($G(TXT),$C(0)," ") Q DIKCP1 DIKCP1 ;SFISC/MKO-PRINT INDEX(ES) ;20DEC2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. PRINDEX ;Come here from PRINDEX^DIKCP Q:'$G(XR) N XR0 I $G(FLAG)'["i" N LM,TYP,TS,WID D INIT^DIKCP S XR0=$G(^DD("IX",XR,0)) Q:XR0?."^" ; ;Print first line of information D FL(XR0,WID,LM,TS,TYP,.PAGE) Q:PAGE(U) I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U) ; ;Print Keys with this Uniqueness Index D KEY(XR,WID,LM,TS,.PAGE) Q:PAGE(U) ; ;Print short description I $P(XR0,U,3)]"" D Q:PAGE(U) . D WLP("Short Descr: ",$P(XR0,U,3),WID,LM+TS,0,.PAGE) ; ;Print description I $O(^DD("IX",XR,.1,0)) D Q:PAGE(U) . D WRWP($NA(^DD("IX",XR,.1)),LM,WID,"Description: ",TS,.PAGE) I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U) ; ;Print logic I FLAG'["N" D Q:PAGE(U) . D LOGIC(XR,WID,LM,TS,FLAG,.PAGE) Q:PAGE(U) . I FLAG'["S" D WRLN("",0,.PAGE) ; ;Print Cross Reference Values D CRV(XR,WID,LM,TS,FLAG,.PAGE) NOREIN I $G(^DD("IX",XR,"NOREINDEX")) W !?9,"NO RE-INDEXING ALLOWED!" Q ; FL(XR0,WID,LM,TS,TYP,PAGE) ;Print first line N ACT,EXEC,NAME,RTYP,SP,TYPE,TXT,USE ; S SP=$J("",4) S EXEC=$$EXTERNAL^DILFD(.11,.4,"",$P(XR0,U,6)) S NAME=$P(XR0,U,2)_" (#"_XR_")" S TYPE=$$EXTERNAL^DILFD(.11,.2,"",$P(XR0,U,4)) S ACT=$P(XR0,U,7) S USE=$TR($$EXTERNAL^DILFD(.11,.42,"",$P(XR0,U,14))," ",$C(0)) S RTYP=$P(XR0,U,8) S:"I"[RTYP RTYP="" S:RTYP]"" RTYP=$TR($$EXTERNAL^DILFD(.11,.5,"",RTYP)," ",$C(0)) S:RTYP]"" RTYP=SP_RTYP_$C(0)_"(#"_$P(XR0,U)_")" ; ;Print first line I TYP=1 D . S TXT=EXEC_" INDEX: ",TXT=TXT_$J("",TS-$L(TXT)) . S TXT=TXT_NAME_SP_TYPE_SP_ACT_SP_USE_RTYP E S TXT=NAME_SP_EXEC_SP_TYPE_SP_ACT_SP_USE_RTYP ; D WRPHI(TXT,WID,LM,TS,0,.PAGE) Q ; KEY(XR,WID,LM,TS,PAGE) ;Print keys that have XR as Uniqueness Index Q:'$D(^DD("KEY","AU",XR)) N KEY,KEY0,KEYLN,TXT ; S TXT=0,TXT(0)="" S KEY=0 F S KEY=$O(^DD("KEY","AU",XR,KEY)) Q:'KEY D . S KEY0=$G(^DD("KEY",KEY,0)) Q:KEY0?."^" . S KEYLN="Key "_$P(KEY0,U,2)_" (#"_KEY_"), File #"_$P(KEY0,U) . S:$G(TXT(TXT))]"" TXT(TXT)=TXT(TXT)_"; " . D ADDSTR($TR(KEYLN," ",$C(0)),.TXT) Q:$G(TXT(0))="" D WLP("Unique for: ",.TXT,WID,LM+TS,0,.PAGE) Q ; LOGIC(XR,WID,LM,TS,FLAG,PAGE) ;Print set and kill logic N CD,LN S CD=$G(^DD("IX",XR,1)) I CD'?."^" D Q:PAGE(U) . D WLP("Set Logic: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U) . S LN=0 F S LN=$O(^DD("IX",XR,1.2,LN)) Q:LN'=+LN D Q:PAGE(U) .. S CD=$G(^DD("IX",XR,1.2,LN,1)) .. I CD'?."^" D WLP(LN_") ",CD,WID,LM+TS,1,.PAGE) S CD=$G(^DD("IX",XR,1.4)) I CD'?."^" D WLP("Set Cond: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U) ; S CD=$G(^DD("IX",XR,2)) I CD'?."^" D Q:PAGE(U) . D WLP("Kill Logic: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U) . S LN=0 F S LN=$O(^DD("IX",XR,2.2,LN)) Q:LN'=+LN D Q:PAGE(U) .. S CD=$G(^DD("IX",XR,2.2,LN,2)) .. I CD'?."^" D WLP(LN_") ",CD,WID,LM+TS,1,.PAGE) S CD=$G(^DD("IX",XR,2.4)) I CD'?."^" D WLP("Kill Cond: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U) S CD=$G(^DD("IX",XR,2.5)) I CD'?."^" D WLP("Whole Kill: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U) Q ; CRV(XR,WID,LM,TS,FLAG,PAGE) ;Print cross reference values N CD,CV,CV0,FL,FD,LAB,ORD,TXT S ORD="" F S ORD=$O(^DD("IX",XR,11.1,"B",ORD)) Q:ORD="" D Q:PAGE(U) . S CV=$O(^DD("IX",XR,11.1,"B",ORD,0)) Q:'CV . Q:$G(^DD("IX",XR,11.1,CV,0))?."^" S CV0=^(0) . S LAB=$S(FLAG'["N":"X("_ORD_"): ",1:ORD_": ") . ; . ;Field-type values . I $P(CV0,U,2)="F" D Q:PAGE(U) .. S FL=$P(CV0,U,3),FD=$P(CV0,U,4) .. I FL,FD S TXT=$P($G(^DD(FL,FD,0)),U)_" ("_FL_","_FD_")" .. E S TXT="" .. D CRVOTH(CV0,.TXT) .. D WLP(LAB,TXT,WID,LM+TS,"",.PAGE) . ; . ;Computed-type values . E D Q:PAGE(U) .. S CD=$G(^DD("IX",XR,11.1,CV,1.5)) .. I CD'?."^" D ... S TXT=$S(FLAG["N":"",1:"Computed Code: "_CD) .. E S TXT="" .. D WLP(LAB,TXT,WID,LM+TS,1,.PAGE) Q:PAGE(U) .. S TXT="" .. D CRVOTH(CV0,.TXT) .. D WLP("",TXT,WID,LM+TS,"",.PAGE) . ; . ;Lookup prompt . I $P(CV0,U,8)]"" D Q:PAGE(U) .. D WLP("Lookup Prompt: ",$P(CV0,U,8),WID-18,LM+TS+18,"",.PAGE) . ; . ;Transform . I FLAG'["N" D .. S CD=$G(^DD("IX",XR,11.1,CV,2)) .. I CD'?."^" D WLP("Transform (Storage): ",CD,WID-24,LM+TS+24,1,.PAGE) .. S CD=$G(^DD("IX",XR,11.1,CV,4)) .. I CD'?."^" D WLP(" Transform (Lookup): ",CD,WID-24,LM+TS+24,1,.PAGE) .. S CD=$G(^DD("IX",XR,11.1,CV,3)) .. I CD'?."^" D WLP("Transform (Display): ",CD,WID-24,LM+TS+24,1,.PAGE) Q ; CRVOTH(CV0,TXT) ;Get other attributes of Cross Reference Value S:$P(CV0,U,6) TXT=TXT_" (Subscr"_$C(0)_$P(CV0,U,6)_")" S:$P(CV0,U,5) TXT=TXT_" (Len"_$C(0)_$P(CV0,U,5)_")" I $P(CV0,U,7)]"" D . S TXT=TXT_" ("_$$EXTERNAL^DILFD(.114,7,"",$P(CV0,U,7))_")" Q ; ADDSTR(X,TXT) ;Add string X to the TXT array I $L(TXT(TXT))+$L(X)>200 S TXT=TXT+1,TXT(TXT)="" S TXT(TXT)=TXT(TXT)_X Q ; WRPHI(TXT,WID,LM,TS,COD,PAGE) ;Write a paragraph with a hanging indent N LAB,LN,TAB S:$D(TXT(0))[0 TXT(0)=$G(TXT) S LAB=$E(TXT(0),1,$G(TS)),TXT(0)=$E(TXT(0),$G(TS)+1,999) D WRAP^DIKCU2(.TXT,WID,"",$G(COD)) D WRLN($G(LAB)_TXT(0),$G(LM),.PAGE) Q:PAGE(U) F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),$G(LM)+$G(TS),.PAGE) Q:PAGE(U) Q ; WLP(LAB,TXT,WID,TAB,COD,PAGE,WFLAG) ;Write a labeled paragraph N LN S:$D(TXT(0))[0 TXT(0)=$G(TXT) D WRAP^DIKCU2(.TXT,WID,"",$G(COD)) D WRLN($G(LAB)_TXT(0),TAB-$L(LAB),.PAGE) Q:PAGE(U) F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),TAB,.PAGE) Q:PAGE(U) S WFLAG=LN>1 Q ; WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text ;See ^DIKCP for documentation N X S PAGE(U)="" ; ;Do paging, if necessary I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U) . I PAGE("H")?1"W ".E X PAGE("H") Q . I $E($G(IOST,"C"))="C" D Q:PAGE(U) .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1 . W @$G(IOF,"#"),PAGE("H") ; ;Write text W !?$G(TAB),$TR($G(TXT),$C(0)," ") Q ; WRWP(ROOT,LM,WID,LAB,TS,PAGE) ;Call DIWP/DIWW to format a wp field. ;Then write the formatted lines. Q:$G(ROOT)="" Q:'$D(@ROOT) N DIWF,DIWL,DIWR,LN,X N DIW,DIWI,DIWT,DIWTC,DIWX,DN,I,Z K ^UTILITY($J,"W") ; S LM=$G(LM)\1,WID=$G(WID)\1,TS=$G(TS)\1,LAB=$G(LAB) I 'WID S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1 S DIWL=0,DIWR=WID,DIWF="|" S LN=0 F S LN=$O(@ROOT@(LN)) Q:'LN S X=$G(@ROOT@(LN,0)) D ^DIWP ; D WRLN($G(LAB)_$G(^UTILITY($J,"W",DIWL,1,0)),LM+TS-$L(LAB),.PAGE) G:$G(PAGE(U)) WRWPQ ; S LN=1 F S LN=$O(^UTILITY($J,"W",DIWL,LN)) Q:'LN D Q:$G(PAGE(U)) . D WRLN(^UTILITY($J,"W",DIWL,LN,0),LM+TS,.PAGE) ; WRWPQ ;Cleanup and quit K ^UTILITY($J,"W") Q DIKCP2 DIKCP2 ;SFISC/MKO-PRINT INDEX(ES) ;9:39 AM 5 Aug 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. LFILE ;Format list of indexes and print; Come here from LFILE^DIKCP N LN,NAM,NO,TXT,XR,XRL S TXT=0,TXT(0)="" ; I $G(FLD)="" S NAM="" F S NAM=$O(^DD("IX","BB",FIL,NAM)) Q:NAM="" D . S XR=0 . F S XR=$O(^DD("IX","BB",FIL,NAM,XR)) Q:'XR D ADDXR(XR,.TXT,FLAG) E D . S XR=0 . F S XR=$O(^DD("IX","F",FIL,FLD,XR)) Q:'XR D .. Q:$G(^DD("IX",XR,0))?."^" S NAM=$P(^(0),U,2) .. S:NAM="" NAM=" ",NO=$G(NO)+1 .. S XRL(NAM,XR)="" . S NAM="" F S NAM=$O(XRL(NAM)) Q:NAM="" D .. S XR=0 F S XR=$O(XRL(NAM,XR)) Q:'XR D ADDXR(XR,.TXT,FLAG) Q:TXT(0)="" ; D WRAP^DIKCU2(.TXT,WID) D WRLN($G(LAB)_TXT(0),LM,.PAGE) Q:PAGE(U) F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+$L(LAB),.PAGE) Q:PAGE(U) Q ; ADDXR(XR,TXT,FLAG) ;Add field list and xref name to TXT array N CRV,FIL,FLD,FLDNAM,FND,NAM,RTYP,STR,XR0 S XR0=$G(^DD("IX",XR,0)) Q:XR0?."^" Q:FLAG'[$P(XR0,U,6) ; S:$G(TXT(TXT))]"" TXT(TXT)=TXT(TXT)_", " S NAM=$P(XR0,U,2) ; I TYP=1 D . S STR=NAM_$C(0)_"(#"_XR_")" . S RTYP=$P(XR0,U,8) . I "I"'[RTYP D .. S STR=STR_" ("_$TR($$EXTERNAL^DILFD(.11,.5,"",RTYP)," ",$C(0)) .. S STR=STR_" #"_$P(XR0,U)_")" ; E D . S CRV=0 F S CRV=$O(^DD("IX",XR,11.1,CRV)) Q:'CRV D .. Q:$P($G(^DD("IX",XR,11.1,CRV,0)),U,2)'="F" .. S FIL=$P(^DD("IX",XR,11.1,CRV,0),U,3),FLD=$P(^(0),U,4) .. Q:'FIL Q:'FLD .. S FLDNAM=$P($G(^DD(FIL,FLD,0)),U) Q:FLDNAM="" .. D:$G(FND) ADDSTR("& ",.TXT) D ADDSTR(FLDNAM_" ",.TXT) .. S FND=1 . S STR="("_NAM_")" . ; D ADDSTR(STR,.TXT) Q ; ADDSTR(X,TXT) ;Add string X to the TXT array I $L(TXT(TXT))+$L(X)>250 S TXT=TXT+1,TXT(TXT)="" S TXT(TXT)=TXT(TXT)_X Q ; WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text ;See ^DIKCP for documentation N X S PAGE(U)="" ; ;Do paging, if necessary I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U) . I PAGE("H")?1"W ".E X PAGE("H") Q . I $E($G(IOST,"C"))="C" D Q:PAGE(U) .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1 . W @$G(IOF,"#"),PAGE("H") ; ;Write text W !?$G(TAB),$TR($G(TXT),$C(0)," ") Q DIKCP3 DIKCP3 ;SFISC/MKO-PRINT INDEX(ES) ;9:21 PM 7 Dec 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; PRFILE(FIL,FLD,FLAG,PAGE,FHDR) ;Print Traditional cross-references on a file Q:'$G(FIL) N HDR,NAM,NO,XR I $G(FLAG)'["i" N LM,TS,TYP,WID D INIT^DIKCP ; ;If field is not specified, print all xrefs on field I $G(FLD)="" D . ;Build list of xrefs sorted by name . K ^TMP("DIKCP3",$J) . S FLD=0 F S FLD=$O(^DD(FIL,"IX",FLD)) Q:'FLD D .. S XR=0 F S XR=$O(^DD(FIL,FLD,1,XR)) Q:'XR D ... Q:$D(^DD(FIL,FLD,1,XR))<9 S NAM=$P($G(^(XR,0)),U,2) ... S:NAM="" NAM="~~"_$G(NO),NO=$G(NO)+1 ... S ^TMP("DIKCP3",$J,NAM,FLD,XR)="" . ; . ;Loop through sorted list and print . S NAM="" F S NAM=$O(^TMP("DIKCP3",$J,NAM)) Q:NAM="" D Q:PAGE(U) .. S FLD=0 F S FLD=$O(^TMP("DIKCP3",$J,NAM,FLD)) Q:'FLD D Q:PAGE(U) ... S XR=0 F S XR=$O(^TMP("DIKCP3",$J,NAM,FLD,XR)) Q:'XR D Q:PAGE(U) .... I '$G(FHDR) D FHDR^DIKCP(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U) .... I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U) .... D PRINDEX(FIL,FLD,XR,FLAG,.PAGE) Q:PAGE(U) .... D WRLN("",0,.PAGE) Q:PAGE(U) .... I FLAG'["S" D WRLN("",0,.PAGE) . K ^TMP("DIKCP3",$J) ; ;Else print cross-references on specific field E S XR=0 F S XR=$O(^DD(FIL,FLD,1,XR)) Q:'XR D Q:PAGE(U) . I '$G(FHDR) D FHDR^DIKCP(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U) . I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U) . D PRINDEX(FIL,FLD,XR,FLAG,.PAGE) Q:PAGE(U) . D WRLN("",0,.PAGE) Q:PAGE(U) . I FLAG'["S" D WRLN("",0,.PAGE) Q ; PRINDEX(FIL,FLD,XR,FLAG,PAGE) ;Print a specific index Q:'$G(FIL)!'$G(FLD)!'$G(XR) N ND,WFLAG I $G(FLAG)'["i" N LM,TYP,TS,WID D INIT^DIKCP ; ;Print first line of information D FL(FIL,FLD,XR,WID,LM,TS,TYP,.PAGE) Q:PAGE(U) ; ;Print Field D WLP^DIKCP1("Field: ",$P($G(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",WID,LM+TS,0,.PAGE) Q:PAGE(U) ; ;For Triggers, print triggered field I $P($G(^DD(FIL,FLD,1,XR,0)),U,3)["TRIG" D Q:PAGE(U) . N LAB,TFIL,TFLD . S TFIL=$P(^DD(FIL,FLD,1,XR,0),U,4),TFLD=$P(^(0),U,5) . S LAB="Triggered Field: " . D WLP^DIKCP1(LAB,$P($G(^DD(TFIL,TFLD,0)),U)_" ("_TFIL_","_TFLD_")",WID-$L(LAB),LM+TS+$L(LAB),"",.PAGE) ; ;Print Description I $O(^DD(FIL,FLD,1,XR,"%D",0)) D Q:PAGE(U) . D WRWP^DIKCP1($NA(^DD(FIL,FLD,1,XR,"%D")),LM,WID,"Description: ",TS,.PAGE) I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U) ; ;Print xref nodes K WFLAG S ND=0 F S ND=$O(^DD(FIL,FLD,1,XR,ND)) Q:ND="" D Q:PAGE(U) . Q:ND="%D"!(ND="DT") . N TXT . S TXT(0)=ND_")= " . S TXT(1)=^DD(FIL,FLD,1,XR,ND) . I FLAG'["S",ND,$G(WFLAG) D WRLN("",0,.PAGE) Q:PAGE(U) . D WLP^DIKCP1("",.TXT,WID,LM+TS,1,.PAGE,.WFLAG) Q ; FL(FIL,FLD,XR,WID,LM,TS,TYP,PAGE) ;Print first line N NAME,SP,TYPE,TXT,WF,XR0 ; S SP=$J("",4) S XR0=$G(^DD(FIL,FLD,1,XR,0)) Q:XR0?."^" S NAME=$P(XR0,U,2) S TYPE=$P(XR0,U,3) S:TYPE="" TYPE="REGULAR" S TXT=NAME_SP_TYPE ; I $P(XR0,U),$P(XR0,U)'=FIL D . S TXT=TXT_SP_"WHOLE"_$C(0)_"FILE"_$C(0)_"(#"_$P(XR0,U)_")" ; ;Print first line D WRPHI^DIKCP1(TXT,WID,LM,TS,0,.PAGE) Q ; HDR(FIL,FLAG,LM,PAGE,HDR) ;Print header I FLAG'["M",FLAG'["R",FLAG'["F" Q D WRLN("Traditional Cross-References:",LM,.PAGE,2) Q:PAGE(U) D WRLN("",0,.PAGE) S HDR=1 Q ; ; WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text ;See ^DIKCP for documentation N X S PAGE(U)="" ; ;Do paging, if necessary I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U) . I PAGE("H")?1"W ".E X PAGE("H") Q . I $E($G(IOST,"C"))="C" D Q:PAGE(U) .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1 . W @$G(IOF,"#"),PAGE("H") ; ;Write text W !?$G(TAB),$TR($G(TXT),$C(0)," ") Q DIKCR DIKCR ;SFISC/MKO-API TO CREATE A NEW-STYLE XREF ;9:55 AM 1 Nov 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CREIXN(DIKCXREF,DIFLG,DIXR,DIKCOUT,DIKCMSG) ;Create a new-style index ;DIFLG: ; e : Throw away Dialog errors ; r : Don't recompile templates, xrefs ; W : Write messages to the current device ; S : Execute set logic of new xref ; CREIXNX ;Entry point from DDMOD N DIKCDEL,DIKCXR,DIKCDMSG,DIKCERR,X,Y ; ;Init S DIFLG=$G(DIFLG) I DIFLG["e" S DIKCMSG="DIKCDMSG" N DIERR I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIKCDEL=$G(DIKCXREF("NAME"))]"" M DIKCXR=DIKCXREF ; ;Check input, set defaults D CHK(.DIKCXR,.DIKCERR) G:DIKCERR EXIT D CHKVAL(.DIKCXR,.DIKCERR) G:DIKCERR EXIT ; ;Delete the old index of the same name D:DIKCDEL . N DIKCFLAG,DIERR,DIKCDMSG . S DIKCFLAG="d"_$E("W",DIFLG["W")_$E("K",DIFLG'["k") . D DELIXN^DDMOD(DIKCXR("FILE"),DIKCXR("NAME"),DIKCFLAG,"","DIKCDMSG") ; ;Create the index D UPDATE(.DIKCXR,.DIXR,DIFLG) I DIXR="" S DIKCERR=1 G EXIT ; ;Execute set logic D:DIFLG["S" SET(DIXR,DIFLG) ; ;Recompile templates and xrefs D:DIFLG'["r" RECOMP(DIXR,DIFLG) ; EXIT ;Write and move error messages if necessary I $G(DIERR) D . D:DIFLG["W" MSG^DIALOG("WES") . D:$G(DIKCMSG)]"" CALLOUT^DIEFU(DIKCMSG) I $G(DIKCERR) S DIXR="" E S DIXR=DIXR_U_DIKCXR("NAME") Q ; UPDATE(DIKCXR,DIXR,DIFLG) ;Call Updater to create index, return DIXR=ien N DIKCFDA,DIKCIEN,IENS,ORD,R,SEQ,X W:$G(DIFLG)["W" !,"Creating index definition ..." ; ;Set FDA for top level Index file fields S DIKCFDA(.11,"+1,",.01)=DIKCXR("FILE") S DIKCFDA(.11,"+1,",.02)=DIKCXR("NAME") S DIKCFDA(.11,"+1,",.11)=DIKCXR("SHORT DESCR") S DIKCFDA(.11,"+1,",.2)=DIKCXR("TYPE") S DIKCFDA(.11,"+1,",.4)=DIKCXR("EXECUTION") S DIKCFDA(.11,"+1,",.41)=DIKCXR("ACTIVITY") S DIKCFDA(.11,"+1,",.42)=DIKCXR("USE") S DIKCFDA(.11,"+1,",.5)=DIKCXR("ROOT TYPE") S DIKCFDA(.11,"+1,",.51)=DIKCXR("ROOT FILE") S DIKCFDA(.11,"+1,",1.1)=$S($G(DIKCXR("SET"))]"":DIKCXR("SET"),1:"Q") S DIKCFDA(.11,"+1,",2.1)=$S($G(DIKCXR("KILL"))]"":DIKCXR("KILL"),1:"Q") S:$G(DIKCXR("SET CONDITION"))]"" DIKCFDA(.11,"+1,",1.4)=DIKCXR("SET CONDITION") S:$G(DIKCXR("KILL CONDITION"))]"" DIKCFDA(.11,"+1,",2.4)=DIKCXR("KILL CONDITION") S:$G(DIKCXR("WHOLE KILL"))]"" DIKCFDA(.11,"+1,",2.5)=DIKCXR("WHOLE KILL") ; ;Set FDA for Values multiple S ORD=0 F SEQ=2:1 S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD D . S IENS="+"_SEQ_",+1," . S R=$NA(DIKCXR("VAL",ORD)) . S DIKCFDA(.114,IENS,.01)=ORD . S DIKCFDA(.114,IENS,1)=@R@("TYPE") . ; . I @R@("TYPE")="C" S DIKCFDA(.114,IENS,4.5)=@R . E D .. S DIKCFDA(.114,IENS,2)=DIKCXR("ROOT FILE") .. S DIKCFDA(.114,IENS,3)=@R .. S X=$G(@R@("XFORM FOR STORAGE")) S:X]"" DIKCFDA(.114,IENS,5)=X .. S X=$G(@R@("XFORM FOR LOOKUP")) S:X]"" DIKCFDA(.114,IENS,5.3)=X .. S X=$G(@R@("XFORM FOR DISPLAY")) S:X]"" DIKCFDA(.114,IENS,5.5)=X . ; . S X=$G(@R@("SUBSCRIPT")) S:X]"" DIKCFDA(.114,IENS,.5)=X . S X=$G(@R@("LENGTH")) S:X]"" DIKCFDA(.114,IENS,6)=X . S X=$G(@R@("COLLATION")) S:X]"" DIKCFDA(.114,IENS,7)=X . S X=$G(@R@("LOOKUP PROMPT")) S:X]"" DIKCFDA(.114,IENS,8)=X ; ;Call Updater D UPDATE^DIE("E","DIKCFDA","DIKCIEN") K DIXR I $G(DIERR) S DIXR="" Q S DIXR=DIKCIEN(1) ; ;Add Description D:$O(DIKCXR("DESCR",0)) WP^DIE(.11,DIXR_",",.1,"",$NA(DIKCXR("DESCR"))) Q ; RECOMP(DIXR,DIFLG) ;Recompile templates and xrefs, update triggering fields N DIKCFLIS,DIKCI,DIKCTLIS,DIKCTOP,DIKTEML ; ;Get top level file number S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP ; ;Get list of fields in xref D GETFLIST^DIKCUTL(DIXR,.DIKCFLIS) Q:'$D(DIKCFLIS) ; ;Recompile input templates and xrefs D DIEZ^DIKD2(.DIKCFLIS,DIFLG,$G(DIKCOUT)) D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT)) S DIKCTOP(DIKCTOP)="" ; ;Also update triggering fields, and their compiled templates and xrefs D TRIG^DICR(.DIKCFLIS,.DIKCTLIS) I $D(DIKCTLIS) D . D DIEZ^DIKD2(.DIKCTLIS,DIFLG,$G(DIKCOUT)) . S DIKCI=0 F S DIKCI=$O(DIKCTLIS(DIKCI)) Q:'DIKCI D .. S DIKCTOP=+$$FNO^DILIBF(DIKCI) Q:$D(DIKCTOP(DIKCTOP))#2!'DIKCTOP .. S DIKCTOP(DIKCTOP)="" .. D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT)) Q ; CHK(DIKCXR,DIKCERR) ;Check/default input array N FIL,NAM,RFIL,TYP,USE S DIKCERR=0 ; ;Check FILE S FIL=$G(DIKCXR("FILE")) I 'FIL D ER202("FILE") Q I '$$VFNUM^DIKCU1(FIL,"D") S DIKCERR=1 Q ; ;Check Type, get internal form S TYP=$G(DIKCXR("TYPE")) I TYP="" D ER202("TYPE") Q D CHK^DIE(.11,.2,"",TYP,.TYP) I TYP=U S DIKCERR=1 Q S DIKCXR("TYPE")=TYP ; ;Check USE, get internal form. S USE=$G(DIKCXR("USE")) I USE]"" D CHK^DIE(.11,.42,"",USE,.USE) I USE=U S DIKCERR=1 Q S DIKCXR("USE")=USE ; S NAM=$G(DIKCXR("NAME")) S RFIL=$G(DIKCXR("ROOT FILE")) ; ;Check Root File, set Root Type S:'RFIL (RFIL,DIKCXR("ROOT FILE"))=FIL I FIL=RFIL S DIKCXR("ROOT TYPE")="I" E D Q:DIKCERR . I $$FLEVDIFF^DIKCU(FIL,RFIL)="" D ER202("ROOT FILE") Q . I '$$VFNUM^DIKCU1(RFIL,"D") S DIKCERR=1 Q . S DIKCXR("ROOT TYPE")="W" ; ;Check USE, NAME, TYPE I NAM="",USE="" D ER202("NAME/USE") Q I $E(NAM)="A",USE="LS" D ER202("NAME/USE") Q I USE="A",TYP'="MU" D ER202("TYPE/USE") Q ; ;Default NAM based on USE and FILE ; or USE based on NAME and TYPE I NAM="" S DIKCXR("NAME")=$$GETNAM(FIL,USE) E I USE="" S DIKCXR("USE")=$S($E(NAM)="A":$S(TYP="MU":"A",1:"S"),1:"LS") ; ;Check SHORT DESCRIPTION'=null', if null set default Activity I $G(DIKCXR("SHORT DESCR"))="" D ER202("SHORT DESCR") Q S:$D(DIKCXR("ACTIVITY"))[0 DIKCXR("ACTIVITY")="IR" Q ; CHKVAL(DIKCXR,DIKCERR) ;Check values, build logic for regular indexes N CNT,FCNT,FIL,KILL,L,LEV,LDIF,MAXL,NAM,ORD,RFIL,ROOT,SBSC,SEQ,SET,TYP,VAL,WKIL ; S FIL=DIKCXR("FILE") S NAM=DIKCXR("NAME") S RFIL=DIKCXR("ROOT FILE") S TYP=DIKCXR("TYPE") S DIKCERR=0 ; ;Begin building logic for regular indexes I TYP="R" D Q:DIKCERR . I FIL'=RFIL S LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL) . E S LDIF=0 . S ROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O",.LEV)_""""_NAM_"""" . I $D(DIERR) S DIKCERR=1 Q . S WKIL="K "_ROOT_")" ; ;Build list of subscripts, count #values and #fields S ORD=0 F S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD D Q:DIKCERR . I $G(DIKCXR("VAL",ORD))="" K DIKCXR("VAL",ORD) Q . S CNT=$G(CNT)+1 . ; . ;Get type of value; if field, increment field count . I DIKCXR("VAL",ORD) S DIKCXR("VAL",ORD,"TYPE")="F",FCNT=$G(FCNT)+1 . E S DIKCXR("VAL",ORD,"TYPE")="C" . ; . ;Set subscript array; error if duplicate subscript # . S SBSC=$G(DIKCXR("VAL",ORD,"SUBSCRIPT")) Q:'SBSC . I $D(SBSC(SBSC))#2 D ER202("SUBSCRIPT") Q . S SBSC(SBSC)=ORD_U_$G(DIKCXR("VAL",ORD,"LENGTH")) . ; . ;Set default collation . S:$G(DIKCXR("VAL",ORD,"COLLATION"))="" DIKCXR("VAL",ORD,"COLLATION")="F" Q:DIKCERR ; S SBSC=0 F SEQ=1:1 S SBSC=$O(SBSC(SBSC)) Q:'SBSC D Q:DIKCERR . ;Check that subscripts are consecutive from 1 . I SEQ'=SBSC D ER202("SUBSCRIPTS") Q . Q:TYP="MU" . ; . ;Continue building logic for regular indexes . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2) . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X") . E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")") . S ROOT=ROOT_","_VAL ; ;If null, default Execution based on #fields S:$G(DIKCXR("EXECUTION"))="" DIKCXR("EXECUTION")=$S($G(FCNT)>1:"R",1:"F") ; ;We're done for MUMPS xrefs Q:TYP="MU" ; ;Continue building logic for regular indexes F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")" S ROOT=ROOT_",DA)" ; I '$O(SBSC(0)) S (SET,KILL)="Q",WKIL="" E S SET="S "_ROOT_"=""""",KILL="K "_ROOT S DIKCXR("SET")=SET S DIKCXR("KILL")=KILL S DIKCXR("WHOLE KILL")=WKIL Q ; GETNAM(F01,USE) ;Get next available index name N ASC,STRT,NAME,I S STRT=$S(USE="LS":"",1:"A") F ASC=67:1:89 D Q:NAME]"" . S NAME=STRT_$C(ASC) . I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q . I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q Q:NAME]"" NAME ; F I=1:1 D Q:NAME]"" . S NAME=STRT_"C"_I . I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q . I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q Q NAME ; SET(DIXR,DIFLG) ;Execute set logic N DIKCRFIL,DIKCTOP,DIKCTRL,DIKCTYP ; S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP S DIKCRFIL=$P($G(^DD("IX",DIXR,0)),U,9) Q:'DIKCRFIL S DIKCTYP=$P($G(^DD("IX",DIXR,0)),U,4) ; I $G(DIFLG)["W" D . I DIKCTYP="R" W !,"Building index ..." . E W !,"Executing set logic ..." ; ;Call INDEX^DIKC to execute the set logic S DIKCTRL="S"_$S(DIKCTOP'=DIKCRFIL:"W"_DIKCRFIL,1:"") D INDEX^DIKC(DIKCTOP,"","",DIXR,.DIKCTRL) Q ; ER202(DIKCP1) ;;The input variable or parameter that identifies the |1| is missing or invalid. D ERR^DIKCU2(202,"","","",DIKCP1) S DIKCERR=1 Q DIKCU DIKCU ;SFISC/MKO-LIBRARY OF GENERIC MODULES ;9:29 AM 22 Oct 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;=============== ; PUSHDA(.DA,N) ;=============== ;Push down the DA array, N times ; PUSHDA(DA,N) ; N I S:'$G(N) N=1 F I=+$O(DA(""),-1):-1:1 S DA(I+N)=$G(DA(I)) S DA(N)=$G(DA) S DA=0 F I=N-1:-1:1 S DA(I)=0 Q ; ;============== ; POPDA(.DA,N) ;============== ;Pop the DA array ; POPDA(DA,N) ; N I,L S:'$G(N) N=1 S L=+$O(DA(""),-1) S DA=$G(DA(N)) F I=N+1:1:L S DA(I-N)=$G(DA(I)) F I=L-N+1:1:L K DA(I) Q ; ;================= ; $$IENS(File,DA) ;================= ;Return IENS given file# and DA array ;In: ; FIL = File or subfile # ; DA = DA array (any unneeded elements in the DA array are ignored) ; IENS(FIL,DA) ; N LEV,I,IENS,ERR Q:$G(FIL)="" "" S LEV=$$FLEV(FIL) Q:LEV="" "" ; ;Build IENS S IENS=$G(DA)_"," F I=1:1:LEV S IENS=IENS_$G(DA(I))_"," Q IENS ; ;========================= ; $$FNUM(Root,Flag) ;========================= ;Given file root, return File # from 2nd piece of header node. ;Also check that that file has a DD entry and a non-wp .01 field. ;Return null if error. ;In: ; ROOT = file root ; F [ D : generate dialog ; FNUM(ROOT,F) ; Q:$G(ROOT)="" "" N FIL S ROOT=$$CREF(ROOT) I $D(@ROOT@(0))[0 D:$G(F)["D" ERR^DIKCU2(404,"","","",ROOT) Q "" S FIL=+$P(@ROOT@(0),U,2) I '$$VFNUM^DIKCU1(FIL,$G(F)) Q "" Q FIL ; ;=============================== ; $$FROOTDA(File,Flag,.L,.TRoot ;=============================== ;Return global root of File; may include DA(1), DA(2), ... for subfiles ;Examples: ^DIZ(9999) and ^DIZ(9999,DA(1),"MULT1") ;In: ; FIL = file # ; FLAG [ O : return open root ; [ D : generate dialog ; starts with number : indicates offset to use for DA array ;Out: ; .L = level of file ; .TROOT = top level root ; FROOTDA(FIL,F,L,TROOT) ; I $G(FIL)="" S (L,TROOT)="" Q "" S F=$G(F) ; ;If top level, return "GL" I $D(^DIC(FIL,0,"GL"))#2 D Q TROOT . S L=0,TROOT=$S(F["O":^("GL"),1:$$CREF(^("GL"))) ; ;Must be a subfile level, get mult nodes, and level N ERR,I,MFLD,ND,PAR,ROOT,SUB S SUB=FIL F L=0:1 S PAR=$G(^DD(SUB,0,"UP")) Q:'PAR D Q:$G(ERR) . S MFLD=$O(^DD(PAR,"SB",SUB,"")) . S ND=$P($P($G(^DD(PAR,MFLD,0)),U,4),";") . I ND?." " S ERR=1 D:F["D" ERR^DIKCU2(502,PAR,"",MFLD) Q . S:ND'=+$P(ND,"E") ND=""""_ND_"""" . S ND(L+1)=ND . S SUB=PAR I $G(ERR) S (L,TROOT)="" Q "" ; ;Build global root for subfile S (ROOT,TROOT)=$G(^DIC(SUB,0,"GL")) I ROOT="" D:F["D" ERR^DIKCU2(402,SUB) S L="" Q "" ; F I=L:-1:1 S ROOT=ROOT_"DA("_(I+F)_"),"_ND(I)_"," S:F'["O" TROOT=$$CREF(TROOT) Q $S(F["O":ROOT,1:$$CREF(ROOT)) ; CREF(X) ;Return closed root of X N F,L S L=$E(X,$L(X)),F=$E(X,1,$L(X)-1) Q $S(L="(":F,L=",":F_")",1:X) ; ;================ ; $$FLEV(File,F) ;================ ;Return the level of File ;In: ; FIL = file# ; F [ "D" : generate Dialog ; FLEV(FIL,F) ; Q:$G(FIL)="" "" ; N LEV F LEV=0:1 Q:$G(^DD(FIL,0,"UP"))="" S FIL=^("UP") I '$D(^DD(FIL)) D:$G(F)["D" ERR^DIKCU2(402,FIL) Q "" Q LEV ; ;========================= ; $$FLEVDIFF(File1,File2) ;========================= ;Find the difference in levels between File1 and File2. ;File1 is an ancestor of File2. ;In: ; FIL1 = File or subfile # of ancestor ; FIL2 = File or subfile # ;Returns: level difference; null if invalid input ; FLEVDIFF(FIL1,FIL2) ; Q:$G(FIL1)=""!($G(FIL2)="") "" ; N DIFF,FIL S FIL=FIL2 F DIFF=0:1 Q:FIL=FIL1 S FIL=$G(^DD(FIL,0,"UP")) Q:FIL="" Q $S(FIL=FIL1:DIFF,1:"") ; ;=============================================== ; SUBFILES(File,.Subfile#Array,.NodeArray,Flag) ;=============================================== ;Build list of subfiles ;In: ; FIL = file # ; FLG = 1 (if wp subfiles should be returned) ;Out: ; .SB(subfile#) = parentFile# ; .MF(file#,multField#) = node ; .MF(file#,multField#,0) = subfile# ; SUBFILES(FIL,SB,MF,FLG) ; Q:$G(FIL)="" N SUB,MUL,ND ; ;Loop through "SB" nodes S SUB="" F S SUB=$O(^DD(FIL,"SB",SUB)) Q:'SUB D . S MUL=$O(^DD(FIL,"SB",SUB,0)) Q:'MUL . Q:$D(^DD(SUB,.01,0))[0 Q:$P(^(0),U,2)["W"&'$G(FLG) . ; . S ND=$P($P(^DD(FIL,MUL,0),U,4),";") Q:ND="" . S SB(SUB)=FIL,MF(FIL,MUL)=ND,MF(FIL,MUL,0)=SUB . ; . ;Make a recursive call to get all subfiles under file SUB . D SUBFILES(SUB,.SB,.MF,$G(FLG)) Q ; ;============================ ; SBINFO(Subfile,.NodeArray) ;============================ ;Get info for Subfile ;In: ; SUB = subfile # ;Out: ; .MF(file#,multField#) = node ; .MF(file#,multField#,0) = subfile# ; SBINFO(SUB,MF) ; N ERR,MUL,ND,PAR F S PAR=$G(^DD(SUB,0,"UP")) Q:'PAR D Q:$G(ERR) . S MUL=$O(^DD(PAR,"SB",SUB,0)) I 'MUL S ERR=1 Q . S ND=$P($P(^DD(PAR,MUL,0),U,4),";") I ND="" S ERR=1 Q . S MF(PAR,MUL)=ND,MF(PAR,MUL,0)=SUB,SUB=PAR Q ; ;============================ ; SELFILE(Root,TopFile,File) ;============================ ;Prompt for file/subfile ;Out: ; .ROOT = open root of top level file ; .TOP = top level file # ; .FILE = (sub)file # ; SELFILE(ROOT,TOP,FILE) ; N %,C,D,DA,DDA,DI,DIAC,DIC,DICS,DIFILE,X,Y S (ROOT,TOP,FILE)="" D D^DICRW Q:Y<0 ; ;Check if this is a new file I '$D(DIC) D Q:'$D(DIC) . N DG,DIE,DIK,DLAYGO,F,Z . D DIE^DIB . S:$D(DG) DIC=DG ; ;Check that file exists S DI=+$P($G(@(DIC_"0)")),U,2) I 'DI W $C(7),!,$$EZBLD^DIALOG(410,DIC_"0)"),! Q ; ;Get subfile, root, and top S FILE=$$SUB^DIKCU(DI) Q:FILE="" S ROOT=DIC,TOP=DI Q ; ;============== ; $$SUB(File#) ;============== ;Prompt for subfiles under file ;Returns: file or subfile # ; null : if user ^-out ; SUB(FIL) ; N D,DIC,DTOUT,DUOUT,QUIT,X,Y ; S DIC(0)="QEAI" S DIC("A")="Select Subfile: " S DIC("S")="N % S %=+$P(^(0),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'[""W""" ; F Q:$O(^DD(+$G(FIL),"SB",0))'>0!$D(QUIT) D . S DIC="^DD("_FIL_"," . D ^DIC . I X="" S QUIT=1 Q . I Y=-1 S QUIT=1 S FIL="" Q . S FIL=+$P(^DD(FIL,+Y,0),U,2) . W " (Subfile #"_FIL_")" Q FIL ; ;#401 File #|FILE| does not exist. ;#402 The global root of file #|FILE| is missing or not valid. ;#404 The File Header node of the file stored at |1| lacks a file number. ;#410 Missing or incomplete global node |1|. ;#502 Field# |FIELD| in file# |FILE| has a corrupted definition. DIKCU1 DIKCU1 ;SFISC/MKO-FILE/RECORD INFO ;11:21 AM 20 Aug 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;=================== ; $$VDA([.]DA,Flag) ;=================== ;Make sure elements DA array are positive canonic numbers. ;In: ; [.]DA = DA array ; F [ R : DA can't be 0 or null ; [ D : generate Dialog ;Returns: 1 if valid; 0 if invalid ; VDA(DA,F) ; N I,ERR Q:$D(DA)[0 0 I $G(F)["R" D:0[DA . S ERR=1 D:$G(F)["D" ERR^DIKCU2(202,"","","","RECORD") I DA]"",DA<0!(DA'=+$P(DA,"E")) D . S ERR=1 D:$G(F)["D" ERR^DIKCU2(202,"","","","RECORD") E F I=1:1 Q:'$D(DA(I)) I DA(I)'>0!(DA(I)'=+$P(DA(I),"E")) D Q . S ERR=1 D:$G(F)["D" ERR^DIKCU2(202,"","","","RECORD") Q '$G(ERR) ; ;==================================== ; $$VFLAG(InputFlags,GoodFlags,Flag) ;==================================== ;Makes sure Flags contain only Good Flags. ;In: ; FLAG = flags ; GDFLAG = good flags ; F [ D : generate Dialog ;Returns: 1 if valid; 0 if invalid ; VFLAG(FLAG,GDFLAG,F) ; S FLAG=$G(FLAG) I $TR($G(FLAG),$G(GDFLAG),"")'?.NP D Q 0 . D:$G(F)["D" ERR^DIKCU2(301,"","","",FLAG) Q 1 ; ;===================== ; $$VFNUM(File#,Flag) ;===================== ;Check that File# exists and has a non-wp .01 field ;In: ; FIL = File or subfile # ; F [ D : generate Dialog ;Returns: 1 if valid; 0 if invalid ; VFNUM(FIL,F) ; Q:$G(FIL)="" 0 I '$D(^DD(FIL)) D:$G(F)["D" ERR^DIKCU2(401,FIL) Q 0 I $P($G(^DD(FIL,.01,0)),U,2)="" D:$G(F)["D" ERR^DIKCU2(406,FIL) Q 0 I $P(^DD(FIL,.01,0),U,2)["W" D:$G(F)["D" ERR^DIKCU2(407,FIL) Q 0 Q 1 ; ;=========================== ; $$VFLD(File#,Field#,Flag) ;=========================== ;Check that the Fil/Fld exists in the ^DD ;In: ; FIL = File or subfile # ; FLD = Field # ; F [ D : generate Dialog ;Returns: 1 if valid; 0 if invalid ; VFLD(FIL,FLD,F) ; Q:$G(FIL)="" 0 Q:$G(FLD)="" 0 I '$D(^DD(FIL,FLD)) D:$G(F)["D" ERR^DIKCU2(501,FIL,"",FLD,FLD) Q 0 Q 1 ; ;================================================ ; FRNAME(File#,[.]Rec,FileText,RecordTxt,.Level) ;================================================ ;Return string that identifies (sub)file and (sub)record. ;In: ; FIL = File or subfile # ; .REC = DA array ;Out: ; .FTXT = Text that identifies file ; .RTXT = Text that identifies record ; .LEV = Level ; FRNAME(FIL,REC,FTXT,RTXT,LEV) ; K FTXT,RTXT,LEV Q:'$G(FIL) Q:'$D(REC) N FINFO D FINFO(FIL,.FINFO) Q:'$D(FINFO) D FILENAME("",.FTXT,.FINFO) D RECNAME("",REC,.RTXT,.FINFO) S LEV=FINFO Q ; ;================================= ; FILENAME(File#,.NameArr,.FINFO) ;================================= ;Get text that identifies the (sub)file ;In: ; FIL = File or subfile # ;In/Out: ; .FINFO = File info array (optional) (see FINFO below) ;Out: ; N = Text (undefined if error) ; N(n) = Overflow text ; FILENAME(FIL,N,FINFO) ; K N I '$D(FINFO) Q:'$G(FIL) D FINFO(FIL,.FINFO) Q:'$D(FINFO) N I,L,T ; S L=FINFO,N=0,N(0)="" F I=L:-1:0 D . I I S T=$P(FINFO(I),U,3)_" (#"_$P(FINFO(I),U)_"), subfield #"_$P(FINFO(I),U,2)_" of " . E S T=$S(L:"the ",1:"")_$P(FINFO(I),U,3)_" File (#"_$P(FINFO(I),U)_")" . I $L(N(N))+$L(T)>240 S N=N+1,N(N)="" . S N(N)=N(N)_T S N=N(0) K N(0) Q ; ;======================================== ; RECNAME(File#,.Record,.NameArr,.FINFO) ;======================================== ;Get text that identifies the (sub)recird ;In: ; FIL = File or subfile # ; [.]REC = DA array or IENS ;In/Out: ; .FINFO = File info array (optional) (see FINFO below) ;Out: ; NA = Text (undefined if error) ; NA(n) = Overflow text ; RECNAME(FIL,REC,NA,FINFO) ;Return string that identifies the (sub)record K NA Q:'$G(REC) I '$D(FINFO) Q:'$G(FIL) D FINFO(FIL,.FINFO) Q:'$D(FINFO) ; N DA,DIERR,ERR,J,LV,LVI,MSG,NDA,ROOT,TX,V01 ; ;Set DA array I REC'["," M DA=REC E D DA^DILF(REC,.DA) ; S LV=FINFO,NA=0,NA(0)="" F LVI=LV:-1:0 D Q:$G(ERR) . I LVI,$G(DA(LVI))'>0 S ERR=1 Q . I 'LVI,$G(DA)'>0 S ERR=1 Q . ; . I '$D(DDS) D Q:$G(ERR) .. S ROOT=$P(FINFO(LVI),U,4,999) .. S V01=$P($G(@ROOT@(0)),U) I V01="" S ERR=1 Q .. S TX=$$EXTERNAL^DILFD($P(FINFO(LVI),U),.01,"",V01,"MSG") .. I $G(DIERR) S TX=V01 K MSG,DIERR . ; . E D .. F J=LVI:-1:1 S NDA(J)=DA(J+LV-LVI) .. S NDA=$S(LVI=LV:DA,1:DA(LV-LVI)) .. S TX=$$GET^DDSVAL($P(FINFO(LVI),U),.NDA,.01,"","E") K NDA . ; . I LV-LVI S TX="'"_TX_"' (#"_DA(LV-LVI)_")" . E S TX="'"_TX_"' (#"_DA_")" . I LVI S TX=TX_" of " . I $L(NA(NA))+$L(TX)>240 S NA=NA+1,NA(NA)="" . S NA(NA)=NA(NA)_TX ; I $G(ERR) K NA Q S NA=NA(0) K NA(0) Q ; ;======================== ; FINFO(File#,.FileInfo) ;======================== ;Get (sub)file info ;In: ; FIL = File or subfile # ;Out: ; FINFO = n (level) ; FINFO(0) = file#^^fileName^fileRootw/DA ; FINFO(n) = subfile#^mfield#^mfieldName^^subfileRootw/DA ;Example: ; FINFO = 3 ; FINFO(0) = 1000^^My File^^DIZ(1000,DA(3)) ; FINFO(1) = 1000.01^100^Mult1^^DIZ(1000,DA(3),10,DA(2)) ; FINFO(2) = 1000.02^200^Mult2^^DIZ(1000,DA(3),10,DA(2),20,DA(1)) ; FINFO(3) = 1000.03^300^Mult3^^DIZ(1000,DA(3),10,DA(2),20,DA(1),30,DA) ; FINFO(FIL,FINFO) ; Q:'$G(FIL) K FINFO ; ;If top level, set FINFO and quit I $D(^DIC(FIL,0,"GL"))#2 D Q . S FINFO=0,FINFO(0)=FIL_U_U_$P(^DIC(FIL,0),U)_U_^DIC(FIL,0,"GL")_"DA)" ; ;Must be a subfile level, get mult nodes, and level N A,ERR,I,L,MFLD,ND,PAR,ROOT,SUB S SUB=FIL F L=0:1 S PAR=$G(^DD(SUB,0,"UP")) Q:'PAR D Q:$G(ERR) . S MFLD=$O(^DD(PAR,"SB",SUB,"")) I 'MFLD S ERR=1 Q . I $D(^DD(PAR,MFLD,0))[0 S ERR=1 Q . S FINFO(L)=SUB_U_MFLD_U_$P(^DD(PAR,MFLD,0),U) . ; . S ND=$P($P(^DD(PAR,MFLD,0),U,4),";") . S:ND'=+$P(ND,"E") ND=""""_ND_"""" . S ND(L+1)=ND . S SUB=PAR I $G(ERR) K FINFO,L Q S FIL=SUB I $D(^DIC(FIL,0))[0 K FINFO,L Q S FINFO(L)=FIL_U_U_$P(^DIC(FIL,0),U) ; ;Build global roots S ROOT=$G(^DIC(FIL,0,"GL")) I ROOT="" K FINFO,L Q F I=L:-1:1 D . S ROOT=ROOT_"DA("_I_")" . S FINFO(I)=FINFO(I)_U_ROOT_")" . S ROOT=ROOT_","_ND(I)_"," S FINFO(0)=FINFO(0)_U_ROOT_"DA)" S FINFO=L ; ;Invert the FINFO array K A M A=FINFO K FINFO S FINFO=A F A=0:1:FINFO S FINFO(A)=A(FINFO-A) Q ; ;#202 The input parameter that identifies the |1| is missing or invalid. ;#301 The passed flag(s) '|1|' are unknown or inconsistent. ;#401 File #|FILE| does not exist. ;#406 File #|FILE| has no .01 field definition. ;#407 A word-processing field is not a file. ;#501 File #|FILE| does not contain a field |1|. DIKCU2 DIKCU2 ;SFISC/MKO-ARRAY COMPARE, TEXT MANIPULATION ;2:40 PM 28 Jan 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;=============================== ; $$GCMP(ArrayName1,ArrayName2) ;=============================== ;Compare the contents of two arrays ;In: ; DIKCU2A0 = Name of array 1 ; DIKCU2B0 = Name of array 2 ;Returns: 1 if equal, 0 if unequal ; GCMP(DIKCU2A0,DIKCU2B0) ; N DIKCU2A,DIKCU2B,DIKCU2DA,DIKCU2DB,DIKCU2E S DIKCU2A=$G(DIKCU2A0),DIKCU2B=$G(DIKCU2B0) Q:DIKCU2A=""!(DIKCU2B="") 0 ; S DIKCU2DA=$D(@DIKCU2A),DIKCU2DB=$D(@DIKCU2B) Q:DIKCU2DA'=DIKCU2DB 0 I DIKCU2DA=0,DIKCU2DB=0 Q 1 I DIKCU2DA#2,DIKCU2DB#2,@DIKCU2A'=@DIKCU2B Q 0 ; S DIKCU2E=1 S DIKCU2A0=$$OREF^DILF(DIKCU2A0),DIKCU2B0=$$OREF^DILF(DIKCU2B0) F S DIKCU2A=$Q(@DIKCU2A),DIKCU2B=$Q(@DIKCU2B) D Q:'DIKCU2E!(DIKCU2A="")!(DIKCU2B="") . I DIKCU2A=""!($P(DIKCU2A,DIKCU2A0)]""),DIKCU2B=""!($P(DIKCU2B,DIKCU2B0)]"") Q . I DIKCU2A=""!(DIKCU2B="") S DIKCU2E=0 Q . I $P(DIKCU2A,DIKCU2A0,2,999)'=$P(DIKCU2B,DIKCU2B0,2,999) S DIKCU2E=0 Q . I @DIKCU2A'=@DIKCU2B S DIKCU2E=0 Q Q DIKCU2E ; ;================================================== ; XRINFO(Xref#,.UIR,.LDif,.MaxL,.RFile,.IRoot,.SS) ;================================================== ;Get info about an index ;In: ; XR = ien of entry in Index file ;Out: ; .UIR = Closed root of index w/ X(n) ; .LDIF = Level difference between file and root file ; .MAXL(ord#) = maximum length of subscript with this order # ; .IROOT = Closed root of index (up to name) ; .RFILE = Root file # ; .SS = # of field-type subscripts ; .SS(ss#) = file#^field#^maxLen ;Example: a whole file xref defined 3 levels down; the xref resides ; on the subfile 2 levels down. ; UIR = ^DIZ(1000,DA(3),10,DA(2),20,"WF",$E(X(1),1,30),X(2)) ; RFILE = 1000.03 ; IROOT = ^DIZ(1000,DA(3),10,DA(2),20,"WF") ; XRINFO(XR,UIR,LDIF,MAXL,RFILE,IROOT,SS) ; K UIR,LDIF,MAXL,SS Q:$D(^DD("IX",XR,0))[0 N CRV,FIL,FILE,FLD,ML,NAME,ORD,TYPE,S ; S FILE=$P(^DD("IX",XR,0),U),NAME=$P(^(0),U,2),TYPE=$P(^(0),U,8),RFILE=$P(^(0),U,9) Q:NAME=""!'FILE!'RFILE ; I FILE'=RFILE D . S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE) Q:LDIF="" . S UIR=$$FROOTDA^DIKCU(FILE,LDIF_"O") Q:UIR="" E D . S LDIF=0 . S UIR=$$FROOTDA^DIKCU(FILE,"O") Q:UIR="" Q:$G(UIR)="" S UIR=UIR_""""_NAME_"""",IROOT=UIR_")" ; S S=0 F S S=$O(^DD("IX",XR,11.1,"AC",S)) Q:'S S CRV=$O(^(S,0)) D:CRV . Q:$D(^DD("IX",XR,11.1,CRV,0))[0 S ORD=$P(^(0),U),FIL=$P(^(0),U,3),FLD=$P(^(0),U,4),ML=$P(^(0),U,5) . Q:'ORD . I ML S UIR=UIR_",$E(X("_ORD_"),1,"_ML_")",MAXL(ORD)=ML . E S UIR=UIR_",X("_ORD_")" . I FIL,FLD S SS=$G(SS)+1,SS(S)=FIL_U_FLD_$S(ML:U_ML,1:"") ; S UIR=UIR_")" Q ; ;=============================== ; WRAP(.Text,Width,Width1,Code) ;=============================== ;Wrap the lines in array T ;In: ; .T = array of text; 1st line can be in T or T(0) ; subsequent lines are in T(1),...,T(n) ; WID = maximum length of each line (default = IOM[or 80]-1) ; if < 0 : IOM-1+WID ; WID1 = maximum length of line 1 (optional) ; if "" : WID ; if < 0 : IOM-1+WID1 ; COD = 1, if lines should NOT wrap on word boundaries ; WRAP(T,WID,WID1,COD) ;Wrap the lines in the T array Q:'$D(T) N E,J,P,T0,W ; S WID=$G(WID)\1 S:WID<1 WID=$G(IOM,80)-1+WID S:WID<1 WID=79 ; S W=$S($G(WID1):WID1\1,$G(WID1)=0:$G(IOM,80)-1,1:WID) S:W<1 W=$G(IOM,80)-1+W S:W<1 W=79 ; I $D(T(0))[0 S T0=1,T(0)=T ; ;Wrap at word boundaries I '$G(COD) F J=0:1 Q:'$D(T(J)) D . S:J=1 W=WID . S:J T(J)=$$LD(T(J)) . ; . ;Line must be split . I $L(T(J))>W D .. D DOWNT .. F P=$L(T(J)," "):-1:0 Q:$L($P(T(J)," ",1,P))'>W .. I 'P S T(J+1)=$E(T(J),W+1,999),T(J)=$E(T(J),1,W) .. E S T(J+1)=$$LD($P(T(J)," ",P+1,999)),T(J)=$$TR($P(T(J)," ",1,P)) . ; . ;Or line must be joined with next . E I $L(T(J))W .. S T(J)=$$TR(T(J)_$P(T(J+1)," ",1,P-1)) .. S T(J+1)=$$LD($P(T(J+1)," ",P,999)) .. I T(J+1)="" D UPT S J=J-1 ; ;Or wrap to width E F J=0:1 Q:'$D(T(J)) D . S:J=1 W=WID . ; . ;Line must be split . I $L(T(J))>W D .. D DOWNT .. S T(J+1)=$E(T(J),W+1,999) .. S T(J)=$E(T(J),1,W) . ; . ;Or joined with next . E I $L(T(J))0+1),";",$G(FLG)["U"+1)_"ile #"_FIL Q $P($$EZBLD^DIALOG(8098),U,$G(^DD(FIL,0,"UP"))>0*2+1+($G(FLG)["U"))_" #"_FIL ; ;================ ; PRTMSG(index#) ;================ ;Print message that DIXR can't be deleted because it's the ;Uniqueness Index for a key. ;In: ; DIXR = index # ; PRTMSG(DIXR) ; N KEYID,I,INDID,MSG ; S KEYID=$O(^DD("KEY","AU",DIXR,0)) Q:'KEYID S KEYID=$G(^DD("KEY",KEYID,0)) Q:KEYID?."^" S KEYID="Key '"_$P(KEYID,U,2)_"' on File #"_$P(KEYID,U) ; S INDID="Index '"_$P($G(^DD("IX",DIXR,0)),U,2)_"'" S MSG(0)=INDID_" cannot be deleted. It is the uniqueness index for "_KEYID_"." D WRAP^DIKCU2(.MSG) ; W $C(7) F I=0:1 Q:'$D(MSG(I)) W !,MSG(I) Q ; ;================ ; BLDLOG(index#) ;================ ;Build and file the logic of the cross reference. ;In: ; DIXR = index # ; ;Called from EDIT^DIKCUTL after an Index is edited. ;The reason for this call is if the user deletes some Cross-Reference ;Values, and then Quits the form, the Set/Kill logic may not reflect ;the deleted Values. ; BLDLOG(DIXR) ; N CNT,CRV,CRV0,DIERR,FCNT,FDA,FILE,IX0,KILL,L,LDIF,MAXL,MSG N NAME,ORD,ROOT,RTYPE,RFILE,SBSC,SET,VAL,WKILL ; ;Get index data S IX0=$G(^DD("IX",DIXR,0)) Q:IX0?."^" I $P(IX0,U,4)="MU" D UPDEXEC(DIXR) Q S FILE=$P(IX0,U),NAME=$P(IX0,U,2),RTYPE=$P(IX0,U,8),RFILE=$P(IX0,U,9) ; ;Build root of index and the 'Kill Entire Index Code' I FILE'=RFILE Q:RTYPE'="W" S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE) E S LDIF=0 S ROOT=$$FROOTDA^DIKCU(FILE,LDIF_"O")_""""_NAME_"""" S WKILL="K "_ROOT_")" ; ;Loop through Cross-Reference Values multiple ;Build SBSC(subscript#)=order#^maxLength array S CRV=0 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D . S CRV0=$G(^DD("IX",DIXR,11.1,CRV,0)) Q:CRV0?."^" . S ORD=$P(CRV0,U) Q:'ORD . S:$P(CRV0,U,2)="F" FCNT=$G(FCNT)+1 . S CNT=$G(CNT)+1 . S SBSC=$P(CRV0,U,6) Q:'SBSC . S MAXL=$P(CRV0,U,5) . S SBSC(SBSC)=ORD_U_MAXL ; ;Loop through SBSC array and build the root w/ X(n) array S SBSC=0 F S SBSC=$O(SBSC(SBSC)) Q:'SBSC D . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2) . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X") . E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")") . S ROOT=ROOT_","_VAL ; ;Append DA(n) to root F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")" S ROOT=ROOT_",DA)" ; ;Build and file the Set and Kill Logic and the Execution I '$O(SBSC(0)) S (SET,KILL)="Q",WKILL="" E S SET="S "_ROOT_"=""""",KILL="K "_ROOT K FDA S FDA(.11,DIXR_",",1.1)=SET S FDA(.11,DIXR_",",2.1)=KILL S FDA(.11,DIXR_",",2.5)=WKILL S FDA(.11,DIXR_",",.4)=$S($G(FCNT)>1:"R",1:"F") D FILE^DIE("","FDA","MSG") Q ; UPDEXEC(DIXR) ;Update Execution based on number of field-type xref values N CRV,CRV0,DIERR,FCNT,FDA,MSG S CRV(1)=DIXR,CRV=0 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D . S CRV0=$G(^DD("IX",DIXR,11.1,CRV,0)) Q:'CRV0 . S:$P(CRV0,U,2)="F" FCNT=$G(FCNT)+1 S FDA(.11,DIXR_",",.4)=$S($G(FCNT)>1:"R",1:"F") D FILE^DIE("","FDA","MSG") Q DIKCUTL3 DIKCUTL3 ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;10:00 AM 12 Nov 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;============================================== ; KSC(topFile#,.oldLogic,.newLogic,.fieldList) ;============================================== ;Run old kill logic and/or new set logic. ;Recompile input templates and xrefs. ;In: ; DIKCTOP = top level file # ; .DIKCOLD = old kill logic (as loaded by LOADXREF^DIKC1) ; .DIKCNEW = new set logic (") ; .DIKCFLIS = list of fields for input template compilation ; ;Called from CREATE^DIKCUTL1 after a new Index is created and edited. ;Called from ^DIKKUTL1 if a Uniqueness Index is created or modified. ; KSC(DIKCTOP,DIKCOLD,DIKCNEW,DIKCFLIS) ; D:$D(DIKCOLD)>1 KOLD(DIKCTOP,.DIKCOLD) D:$D(DIKCNEW)>1 SNEW(DIKCTOP,.DIKCNEW) D:$D(DIKCFLIS)>1 DIEZ(DIKCTOP,.DIKCFLIS) D DIKZ(DIKCTOP) Q ; ;=========================== ; DIEZ(topFile#,.fieldList) ;=========================== ;Loop through file/fields in DIKCFLIS input array. ;For each of those fields loop through the ^DIE("AF") index which ; contains the iens of the compiled input templates that use that ; field. Recompile those templates. ;In: ; DIKCTOP = top level file # ; DIKCFLIS(file#,field#) = "" ; DIEZ(DIKCTOP,DIKCFLIS) ; N DA,DI,DIKCFD,DIKCFL,DIKCIT,DMAX,DNM,X,Y ; S DIKCFL=0 F S DIKCFL=$O(DIKCFLIS(DIKCFL)) Q:'DIKCFL D . S DIKCFD=0 F S DIKCFD=$O(DIKCFLIS(DIKCFL,DIKCFD)) Q:'DIKCFD D .. S DIKCIT=0 F S DIKCIT=$O(^DIE("AF",DIKCFL,DIKCFD,DIKCIT)) Q:DIKCIT'>0 D ... Q:$D(DIKCIT(DIKCIT))#2 S DIKCIT(DIKCIT)="" ... S X=$G(^DIE(DIKCIT,"ROUOLD")) ... I X'?1(1A,1"%").7AN D I X'?1(1A,1"%").7AN D UNC^DIEZ(DIKCIT) Q .... S X=$P($G(^DIE(DIKCIT,"ROU")),U,2) ... K ^DIE("AF",DIKCFL,DIKCFD,DIKCIT),^DIE(DIKCIT,"ROU") ... S DMAX=$G(^DD("ROU")),Y=DIKCIT ... D EN^DIEZ .. ; .. I $D(^DD(DIKCFL,DIKCFD)),$P($G(^DIC(DIKCTOP,"%A")),U,2)-DT D ... S ^DD(DIKCFL,DIKCFD,"DT")=DT Q ; ;================ ; DIKZ(topFile#) ;================ ;Recompile cross references on file Y. ;In: ; Y = top level file # ; DIKZ(Y) ; Q:'$G(Y) N DMAX,X S X=$G(^DD(Y,0,"DIK")) Q:X="" S DMAX=^DD("ROU") D EN^DIKZ W ! Q ; ;=========================== ; KOLD(topFile#,.xrefLogic) ;=========================== ;Determine whether to execute old kill logic; if yes, execute. ;In: ; DIKCTOP = top file # ; DIKCOLD(file#,xref#) = array as built by LOADXREF^DIKC1 ; KOLD(DIKCTOP,DIKCOLD) ; Q:'$D(DIKCOLD) N DIKCFILE,DIKCMSG,DIKCTYP,DIKCUC,DIXR N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y ; S DIKCFILE=$O(DIKCOLD(0)) Q:'DIKCFILE S DIXR=$O(DIKCOLD(DIKCFILE,0)) Q:'DIXR S DIKCTYP=$P(DIKCOLD(DIKCFILE,DIXR),U,4) ; ;Ask before removing Regular index or running kill logic of MUMPS xref I DIKCTYP="R" D . S DIKCMSG=" Removing old index ..." . S DIR("A")="Do you want to delete the data in the old index now" . S DIR("B")="YES" . S DIR("?",1)=" Enter 'YES' to delete the data in the old index now." . S DIR("?",2)="" . S DIR("?",3)=" You might answer 'NO' if you know that there is no data in the index, or" . S DIR("?",4)=" in order to remove the index, FileMan must loop through a large number" . S DIR("?",5)=" of entries, and you would rather wait until a non-peak time to perform" . S DIR("?",6)=" deletion. Note, however, that FileMan will use the WHOLE KILL LOGIC to" . S DIR("?")=" remove the index, so the looping time may not be an issue." E D . S DIKCMSG=" Executing old kill logic ..." . S DIR("A")="Do you want to execute the old kill logic now" . S DIR("?",1)=" Enter 'YES' to execute the original kill logic now." . S DIR("?")=" Otherwise, enter 'NO'." S DIR(0)="Y" F W ! D ^DIR Q:'$D(DUOUT) W $C(7)," Up-arrow not allowed." K DIR Q:'Y!$D(DTOUT) ; ;Write message and call INDEX^DIKC to execute the kill logic W !,DIKCMSG S DIKCUC="K"_$S(DIKCTOP'=DIKCFILE:"W"_DIKCFILE,1:"") S DIKCUC("LOGIC")="DIKCOLD" D INDEX^DIKC(DIKCTOP,"","",DIXR,.DIKCUC) W " DONE!" Q ; ;=========================== ; SNEW(topFile#,.xrefLogic) ;=========================== ;Determine whether to execute new set logic; if yes, execute. ;In: ; DIKCTOP = top file # ; DIKCNEW(file#,xref#) = array as built by LOADXREF^DIKC1 ; SNEW(DIKCTOP,DIKCNEW) ; Q:'$D(DIKCNEW) N DIKCFILE,DIKCMSG,DIKCTYP,DIKCUC,DIXR N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y ; S DIKCFILE=$O(DIKCNEW(0)) Q:'DIKCFILE S DIXR=$O(DIKCNEW(DIKCFILE,0)) Q:'DIXR S DIKCTYP=$P(DIKCNEW(DIKCFILE,DIXR),U,4) ; ;Ask before building Regular index or running set logic of MUMPS xref I DIKCTYP="R" D . S DIKCMSG=" Building new index ..." . S DIR("A")="Do you want to build the index now" . S DIR("B")="YES" . S DIR("?",1)=" Enter 'YES' to loop through all entries in the file and build the index" . S DIR("?",2)=" now." . S DIR("?",3)="" . S DIR("?",4)=" You might answer 'NO' if you know that there is no data in any of the" . S DIR("?",5)=" fields being indexed, or if the file has a large number of entries, and" . S DIR("?",6)=" you would rather wait until a non-peak time to build the index on a" . S DIR("?")=" live system." E D . S DIKCMSG=" Executing new set logic ..." . S DIR("A")="Do you want to cross reference existing data now" . S DIR("?",1)=" Enter 'YES' to execute the new set logic now." . S DIR("?")=" Otherwise, enter 'NO'." S DIR(0)="Y" F W ! D ^DIR Q:'$D(DUOUT) W $C(7)," Up-arrow not allowed." K DIR Q:'Y!$D(DTOUT) ; W !,DIKCMSG S DIKCUC="S"_$S(DIKCTOP'=DIKCFILE:"W"_DIKCFILE,1:"") S DIKCUC("LOGIC")="DIKCNEW" D INDEX^DIKC(DIKCTOP,"","",DIXR,.DIKCUC) W " DONE!" Q ; EOP ;Issue Press Return to continue prompt N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="E",DIR("A")="Press RETURN to continue" S DIR("?")="Press the RETURN or ENTER key." W ! D ^DIR Q DIKD DIKD ;SFISC/MKO-DELETE A CROSS REFERENCE ;11JUN2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; DELIX(DIFIL,DIFLD,DIXR,DIFLG,DIKDOUT,DIKDMSG) ;Delete traditional xref DELIXX ;Come here from DELIX^DDMOD N %,DIC,X,Y,DIF,DIFINFO,DIQUIT ; ;Init I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIFLG=$G(DIFLG) S DIF=$E("D",DIFLG'["d") I DIFLG'["c" D CHK G:$G(DIQUIT) END D FINFO^DIKCU1(DIFIL,.DIFINFO) ; ;Delete data in index D:DIFLG["K" KILL^DIKD1(DIFIL,DIFLD,DIXR,$E("W",DIFLG["W")_DIF_"c") ; ;Audit, delete xref, recompile D AUDIT ;:$G(^DD(+DIFINFO(0),0,"DDA"))["Y" D DELDEF(DIFIL,DIFLD,DIXR,DIFLG) D DIEZ(DIFIL,DIFLD,DIFLG,$G(DIKDOUT)) D DIKZ(+DIFINFO(0),DIFLG,$G(DIKDOUT)) ; END ;Move error message if necessary and quit D:$G(DIKDMSG)]"" CALLOUT^DIEFU(DIKDMSG) Q ; DELDEF(DIFIL,DIFLD,DIXR,DIFLG) ;Delete index definition N DIK,DA,DITYP S DITYP=$P($G(^DD(DIFIL,DIFLD,1,DIXR,0)),U,3) K:DITYP="SOUNDEX" ^DD(DIFIL,0,"LOOK"),^("QUES") ; W:$G(DIFLG)["W" !,"Deleting cross-reference definition ..." S ^DD(DIFIL,DIFLD,1,0)="^.1" S DIK="^DD("_DIFIL_","_DIFLD_",1," S DA(2)=DIFIL,DA(1)=DIFLD,DA=DIXR D ^DIK Q ; DIEZ(DIFIL,DIFLD,DIFLG,DIKDOUT,DIKTEML) ;Recompile input templates containing field N DIERR,DITEM,DIMAX,DIRNM S DIMAX=$$ROUSIZE^DILF S DITEM=0 F S DITEM=$O(^DIE("AF",DIFIL,DIFLD,DITEM)) Q:'DITEM D . N DIERR,DIEZMSG . Q:$D(DIKTEML(DITEM))#2 S DIKTEML(DITEM)="" . K ^DIE("AF",DIFIL,DIFLD,DITEM),^DIE(DITEM,"ROU") . S DIRNM=$G(^DIE(DITEM,"ROUOLD")) Q:DIRNM="" . D EN2^DIEZ(DITEM,$E("T",$G(DIFLG)["W"),DIRNM,"","DIEZMSG") . I '$G(DIERR),$G(DIKDOUT)]"" D .. S @DIKDOUT@("DIEZ",DITEM)=$P(^DIE(DITEM,0),U)_U_$P(^(0),U,4)_U_DIRNM Q ; DIKZ(Y,DIFLG,DIKDOUT) ;Recompile xrefs Q:'$G(Y) N DIERR,DIKZMSG,DMAX,DIRNM S DIRNM=$G(^DD(Y,0,"DIK")) Q:DIRNM="" S DMAX=$$ROUSIZE^DILF D EN2^DIKZ(Y,$E("T",$G(DIFLG)["W"),DIRNM,"","DIKZMSG") I '$G(DIERR),$G(DIKDOUT)]"" S @DIKDOUT@("DIKZ")=DIRNM Q ; AUDIT ;Audit DD change N %,%D,%T,A0,A1,A2,B0,B1,B2,B3,DA,DDA,DL,DQ,J,N S DDA="D",N=DIFINFO,J(0)=+DIFINFO(0),J(N)=DIFIL,DL=DIFLD,DQ=DIXR D XA^DICATTA S:$G(DIKDOUT)]"" @DIKDOUT@("DDAUD")=1 Q ; CHK ;Check input parameters I '$G(DIFIL) D:DIF["D" ERR^DIKCU2(202,"","","","FILE") D QUIT I '$G(DIFLD) D:DIF["D" ERR^DIKCU2(202,"","","","FIELD") D QUIT I '$G(DIQUIT),'$$VFNUM^DIKCU1(DIFIL,DIF) D QUIT I '$G(DIQUIT),'$$VFLD^DIKCU1($G(DIFIL),$G(DIFLD),DIF) D QUIT ; I $G(DIXR)="" D . D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT E I '$G(DIQUIT) D . I DIXR=+DIXR D .. I $D(^DD(DIFIL,DIFLD,1,DIXR,0))[0 D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT . E D .. N I,XR .. S I=0 F S I=$O(^DD(DIFIL,DIFLD,1,I)) Q:'I S:$P($G(^(I,0)),U,2)=DIXR XR=$G(XR)+1,XR(XR)=I .. I $G(XR)=1 S DIXR=XR(XR) .. E D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT ; D:'$$VFLAG^DIKCU1(DIFLG,"KWcd",DIF) QUIT Q ; QUIT ;Set flag to quit S DIQUIT=1 Q DIKD1 DIKD1 ;SFISC/MKO-DELETE XREF DATA ;1:03 PM 20 Aug 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; KILL(DIFIL,DIFLD,DIXR,DIFLG,DIKDMSG) ;Delete xref data N DA,DIDEC,DIF,DIFILR,DIKILL,DIMF,DINAM,DIQUIT,DIROOT,DITOPF,DITYP ; ;Init I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIFLG=$G(DIFLG) S DIF=$E("D",DIFLG'["d") I DIFLG'["c" D CHK G:$G(DIQUIT) END D INIT G:$D(DIQUIT) END ; ;Fire the kill logic D:$G(DIFLG)["W" . I DITYP="BULLETIN"!(DITYP="MUMPS")!(DITYP="TRIGGER") D .. W !,"Executing kill logic ..." . E W !,"Removing index ..." D FIRE(DITOPF,DIROOT) ; END ;Move error message if necessary and quit D:$G(DIKDMSG)]"" CALLOUT^DIEFU(DIKDMSG) Q ; FIRE(DIFILE,DIROOT) ;Fire the kill logic N DICNT,DILAST,DIMULTF,DISBROOT,X ; ;If we're at the level where the index resides, ;check whether we can delete the entire index with one kill I DIFILE=DIFILR,DINAM?1.E,DITYP'="MNEMONIC",DITYP'="MUMPS" D . K @DIROOT@(DINAM) ; ;Else, if we're at the level where the index is defined, ;execute the kill logic for each entry E I DIFILE=DIFIL S (DICNT,DA)=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D . N X . S DICNT=DICNT+1 . X DIDEC X:X]"" DIKILL ; ;Else, for all entries, descend into multiple E S DIMULTF=$O(DIMF(DIFILE,0)) I DIMULTF S (DICNT,DA)=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D . S DICNT=DICNT+1 . S DISBROOT=$NA(@DIROOT@(DA,DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT) . D PUSHDA^DIKCU(.DA) . D FIRE(DIMF(DIFILE,DIMULTF,0),DISBROOT) . D POPDA^DIKCU(.DA) ; I $D(DICNT),$D(@DIROOT@(0))#2 D . S DILAST=$O(@DIROOT@(" "),-1) . S:'DILAST DILAST="" S:'DICNT DICNT="" . S $P(@DIROOT@(0),U,3,4)=DILAST_U_DICNT Q ; CHK ;Check input parameters I '$G(DIFIL) D:DIF["D" ERR^DIKCU2(202,"","","","FILE") D QUIT I '$G(DIFLD) D:DIF["D" ERR^DIKCU2(202,"","","","FIELD") D QUIT I '$G(DIQUIT),'$$VFLD^DIKCU1($G(DIFIL),$G(DIFLD),DIF) D QUIT I '$G(DIXR) D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT D:'$$VFLAG^DIKCU1(DIFLG,"Wcd",DIF) QUIT Q ; INIT ;Get xref info and subfile info N DIXR0 S DIXR0=$G(^DD(DIFIL,DIFLD,1,DIXR,0)) G:DIXR0="" QUIT S DIFILR=$P(DIXR0,U),DINAM=$P(DIXR0,U,2),DITYP=$P(DIXR0,U,3) G:DITYP="BULLETIN" QUIT ; S DIKILL=$G(^DD(DIFIL,DIFLD,1,DIXR,2)) G:DIKILL="Q"!(DIKILL?."^") QUIT ; D SBINFO^DIKCU(DIFIL,.DIMF) I '$D(DIMF) S DITOPF=DIFIL E S DITOPF=0 F S DITOPF=$O(DIMF(DITOPF)) Q:'$G(^DD(DITOPF,0,"UP")) ; S DIROOT=$$CREF^DILF($G(^DIC(DITOPF,0,"GL"))) S DIDEC=$$DEC^DIKC2(DIFIL,DIFLD) G:DIROOT=""!(DIDEC="") QUIT Q ; QUIT ;Set flag to quit S DIQUIT=1 Q DIKD2 DIKD2 ;SFISC/MKO-DELETE A NEW-STYLE INDEX ;4JAN2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; DELIXN(DIFIL,DIXR,DIFLG,DIKDOUT,DIKDMSG) ;Delete new-style index DELIXNX ;Come here from DELIXN^DDMOD N %,DIC,DIF,DIFLIST,DIINDEX,DIQUIT,DITOP,X,Y ; ;Init I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU S DIFLG=$G(DIFLG) S DIF=$E("D",DIFLG'["d") I DIFLG'["c" D CHK G:$G(DIQUIT) END S DITOP=DIFIL F Q:'$D(^DD(DITOP,0,"UP")) S DITOP=^("UP") D GETFLIST^DIKCUTL(DIXR,.DIFLIST) D LOADXREF^DIKC1("","","K",DIXR,"","DIINDEX") ; ;Delete data in index D:DIFLG["K" KILL(DITOP,.DIINDEX,DIFLG) ; ;Delete index, recompile D DELDEF(DIXR) D DIEZ(.DIFLIST,DIFLG,$G(DIKDOUT)) D DIKZ^DIKD(DITOP,DIFLG,$G(DIKDOUT)) ; END ;Move error message if necessary and quit D:$G(DIKDMSG)]"" CALLOUT^DIEFU(DIKDMSG) Q ; DELDEF(DIXR) ;Delete index definition N DIK,DA W:$G(DIFLG)["W" !,"Deleting index definition ..." S DIK="^DD(""IX"",",DA=DIXR D ^DIK Q ; DIEZ(DIFLIST,DIFLG,DIKDOUT) ;Recompile input templates containing field N DIFIL,DIFLD,DIKTEML S DIFIL=0 F S DIFIL=$O(DIFLIST(DIFIL)) Q:'DIFIL D . S DIFLD=0 F S DIFLD=$O(DIFLIST(DIFIL,DIFLD)) Q:'DIFLD D .. D DIEZ^DIKD(DIFIL,DIFLD,DIFLG,$G(DIKDOUT),.DIKTEML) Q ; CHK ;Check input parameters I '$G(DIFIL) D:DIF["D" ERR^DIKCU2(202,"","","","FILE") D QUIT I $G(DIXR)]"" D .N I F I=0:0 S I=$O(^DD("IX","IX",DIXR,I)) Q:'I I +$G(^DD("IX",I,0))=$G(DIFIL) Q .I 'I K DIXR I $G(DIXR)="" D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT D:'$$VFLAG^DIKCU1(DIFLG,"KWcd",DIF) QUIT Q:$G(DIQUIT) S DIXR=$O(^DD("IX","BB",DIFIL,DIXR,0)) D:'DIXR QUIT Q ; QUIT ;Set flag to quit S DIQUIT=1 Q ; KILL(DITOP,DIINDEX,DIFLG) ;Delete index data N DIFIL,DITYP,DICTRL,DIXR ; Q:'$D(DIINDEX) S DIFIL=$O(DIINDEX(0)) Q:'DIFIL S DIXR=$O(DIINDEX(DIFIL,0)) Q:'DIXR S DITYP=$P(DIINDEX(DIFIL,DIXR),U,4) ; I $G(DIFLG)["W" D . I DITYP="R" W !,"Removing index ..." . E W !,"Executing kill logic ..." ; ;Call INDEX^DIKC to execute the kill logic S DICTRL="K"_$S(DITOP'=DIFIL:"W"_DIFIL,1:"") S DICTRL("LOGIC")="DIINDEX" D INDEX^DIKC(DITOP,"","",DIXR,.DICTRL) Q DIKK DIKK ;SFISC/MKO-CHECK KEY INTEGRITY ;9:14 AM 23 Feb 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; INTEG(DIFILE,DIREC,DIFLD,DIKKEY,DICTRL,DIKPROC) ; N DA,DIF,DIKERR,DIKFIL,DIKKQUIT,DIMF,DIROOT,DITAR ; ;If called as an extrinsic, manipulate DICTRL S DIKPROC=$G(DIKPROC) I 'DIKPROC N DICTRL1,DIKKTAR M DICTRL1=DICTRL S DICTRL("TAR")="DIKKTAR" ; S DIF=$E("D",$G(DICTRL)'["d") I DIF["D",'$D(DIQUIET) N DIQUIET S DIQUIET=1 I DIF["D",'$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU ; ;Check input params, initialize variables, clean output array D INIT^DIKK2 G:$G(DIKERR)]"" MOVE I 'DIKPROC S:$G(DICTRL)'["Q" DICTRL=$G(DICTRL)_"Q" ; ;Load key info into ^TMP("DIKK",$J), and multiple info into DIMF K ^TMP("DIKK",$J) I $G(DIKKEY)?."^" D . I $G(DIFLD) D .. D LOADFLD^DIKK1(DIKFIL,DIFLD) . E D LOADALL^DIKK1(DIKFIL,$E("s",$G(DICTRL)["s"),.DIMF) E D LOADKEY^DIKK1(DIKKEY) G:'$O(^TMP("DIKK",$J,0)) EXIT D:DIKFIL'=DIFILE SBINFO^DIKCU(DIKFIL,.DIMF) ; ;Check one or all records in file DIFILE I DA D . D CHECK(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT) E D CHECKALL(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT) ; EXIT ;Cleanup ^TMP and quit K ^TMP("DIKK",$J) ; MOVE ;Move error messages if necessary I DIF["D",$G(DIERR),$G(DICTRL("MSG"))]"" D CALLOUT^DIEFU(DICTRL("MSG")) I 'DIKPROC K DICTRL M DICTRL=DICTRL1 Q $D(DIKKTAR)=0&($G(DIKERR)="") Q ; CHECK(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check one record I $D(^TMP("DIKK",$J,"UIR",DIFILE)) D CHECK^DIKK2(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT) D:$D(DIMF(DIFILE)) CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT) Q ; CHECKALL(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Check all records I $D(^TMP("DIKK",$J,"UI",DIFILE)) D UICHK(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT) I '$D(^TMP("DIKK",$J,DIFILE)),'$D(DIMF(DIFILE)) Q ; ;Loop through all records in file, check for null key fields S DA=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D Q:$G(DIKKQUIT) . I $D(^TMP("DIKK",$J,DIFILE)) D NULLCHK(DIFILE,.DA,DITAR,.DIKKQUIT) Q:$G(DIKKQUIT) . D:$D(DIMF(DIFILE)) CHECKSUB(DIFILE,.DA,DIROOT,.DIMF,DITAR,.DIKKQUIT) Q ; CHECKSUB(DIFILE,DA,DIROOT,DIMF,DITAR,DIKKQUIT) ;Process all records in subfiles N DIMULTF,DISBFILE,DISBROOT D PUSHDA^DIKCU(.DA) ; ;Loop through the DIMF array and make recursive call to check all ;subrecords S DIMULTF=0 F S DIMULTF=$O(DIMF(DIFILE,DIMULTF)) Q:'DIMULTF D Q:$G(DIKKQUIT) . S DISBROOT=$NA(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT) . S DISBFILE=DIMF(DIFILE,DIMULTF,0) . D CHECKALL(DISBFILE,.DA,DISBROOT,.DIMF,DITAR,.DIKKQUIT) ; D POPDA^DIKCU(.DA) Q ; NULLCHK(KFIL,DA,DITAR,DIKKQUIT) ;Check whether any of the key fields at ;KFIL file level are null for a given record. N FIL,FLD,IENS,LDIF,X ; S FIL=0 F S FIL=$O(^TMP("DIKK",$J,KFIL,FIL)) Q:'FIL D Q:$G(DIKKQUIT) . S LDIF=+$G(^TMP("DIKK",$J,KFIL,FIL)) . S FLD=0 F S FLD=$O(^TMP("DIKK",$J,KFIL,FIL,FLD)) Q:'FLD D Q:$G(DIKKQUIT) .. X ^TMP("DIKK",$J,KFIL,FIL,FLD) Q:X]"" .. S IENS=$$IENS(.DA) .. S:LDIF IENS=$P(IENS,",",LDIF+1,999) .. D SETN(FIL,IENS,FLD,DITAR,.DIKKQUIT) Q ; UICHK(FILE,DA,OUT,DIKKQUIT) ;Walk through uniqueness index and check for duplicates N IX0,IX1,IX2,IXV1,IXV2,KEY,KFIL,LDIF,NS,S,SS,UI ; S UI=0 F S UI=$O(^TMP("DIKK",$J,"UI",FILE,UI)) Q:'UI D Q:$G(DIKKQUIT) . ;Get info about uniqueness index . S KEY=$G(^TMP("DIKK",$J,"UI",FILE,UI)) . I $P(KEY,U,2)]"" D .. S KFIL=$P(KEY,U,2),LDIF=$P(KEY,U,3),KEY=$P(KEY,U) .. S IX0=^TMP("DIKK",$J,"UI",FILE,UI,"UIR") M SS=^("SS") . E D .. D XRINFO^DIKCU2(UI,"",.LDIF,"",.KFIL,.IX0,.SS) .. ; .. ;Remove elements from the SS array that have no max length. .. ;For those that have max length, set SS(S)=data extraction code .. S S=0 F S S=$O(SS(S)) Q:'S D ... I '$P(SS(S),U,3) K SS(S) Q ... S SS(S)=^TMP("DIKK",$J,KFIL,$P(SS(S),U),$P(SS(S),U,2)) .. ; .. ;Remember info for next time . S KEY=+KEY . S ^TMP("DIKK",$J,"UI",FILE,UI)=KEY_U_KFIL_U_LDIF,^(UI,"UIR")=IX0 . M ^TMP("DIKK",$J,"UI",FILE,UI,"SS")=SS . ; . ;If necessary, push the DA array . D:LDIF PUSHDA^DIKCU(.DA,LDIF) . ; . ;Walk down the uniqueness index and look for duplicates . S (IX0,IX1,IX2)=$NA(@IX0),NS=$QL(IX0) . F S IX2=$Q(@IX2) Q:IX2="" Q:$NA(@IX2,NS)'=IX0 D Q:$G(DIKKQUIT) .. S IXV1=$NA(@IX1,NS+SS),IXV2=$NA(@IX2,NS+SS) .. I IXV1'=IXV2 S IX1=IX2 Q .. D DUPL(KEY,UI,FILE,KFIL,.DA,IX1,IX2,IXV1,NS,.SS,.DIKKQUIT) .. S (IX1,IX2)=$NA(@IXV1@("~")) . ; . ;Pop the DA array . D:LDIF POPDA^DIKCU(.DA,LDIF) Q ; DUPL(KEY,UI,UIFIL,UIRFIL,DA,IX1,IX2,IXV,NS,SS,DIKKQUIT) ;Process duplicate ;indexes N DUPL,IENSDONE,I,IENS1,IENS2,L,ML,NEXTIX1,S,V1,X ; ;Set ML(subsc)=SS(subsc) for those subscripts that are >= maxlength S S=0 F S S=$O(SS(S)) Q:'S S:$L($QS(IXV,NS+S))'<$P(SS(S),U,3) ML(S)=SS(S) ; DLOOP ;Compare IX1 with IX2 and subsequent indexes K NEXTIX1 ; ;Set iens and DA array for 1st index S IENS1=$E(IX1,$L(IXV)+1,$L(IX1)-1),L=$L(IENS1,",") S DA=$P(IENS1,",",L) F I=1:1:L-1 S DA(I)=$P(IENS1,",",L-I) S IENS1=$$IENS(.DA) ; ;If any subsc >= maxlen, set V1(subsc) = value array for 1st index I $D(ML) K V1 S S=0 F S S=$O(ML(S)) Q:'S X ML(S) S V1(S)=X ; F D S IX2=$Q(@IX2) Q:IX2="" Q:$NA(@IX2,NS+SS)'=IXV!$G(DIKKQUIT) . ;Set iens and DA array for the 2nd index . S IENS2=$E(IX2,$L(IXV)+1,$L(IX2)-1),L=$L(IENS2,",") . S DA=$P(IENS2,",",L) F I=1:1:L-1 S DA(I)=$P(IENS2,",",L-I) . S IENS2=$$IENS(.DA) . ; . ;If no subsc >= maxlen, there's a duplicate . I '$D(ML) D SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT) S DUPL=1 Q . ; . ;Otherwise, compare with actual data . Q:$D(IENSDONE(IENS2)) . S S=0 F S S=$O(ML(S)) Q:'S X ML(S) I X'=V1(S) Q . I S S:'$D(NEXTIX1) NEXTIX1=IX2 . E D SETK(UIRFIL,IENS2,KEY,DITAR,.DIKKQUIT) S DUPL=1,IENSDONE(IENS2)="" ; D:$G(DUPL) SETK(UIRFIL,IENS1,KEY,DITAR,.DIKKQUIT) Q:'$D(NEXTIX1) ; S IX1=NEXTIX1,IX2=$Q(@IX1) Q:IX2="" G:$NA(@IX1,NS+SS)=$NA(@IX2,NS+SS) DLOOP Q ; SETN(DIFIL,DIIENS,DIFLD,DITAR,DIKKQUIT) ; S @DITAR@(DIFIL,DIIENS,DIFLD)="" ;S @DITAR@("N",DIFIL,DIIENS,DIFLD)="" S:$G(DIKKQUIT)]"" DIKKQUIT=1 Q ; SETK(DIRFIL,DIIENS,DIKEY,DITAR,DIKKQUIT) ; S @DITAR@(DIRFIL,DIIENS,"K",DIKEY)="" ;S @DITAR@("K",DIRFIL,DIIENS,DIKEY)="" S:$G(DIKKQUIT)]"" DIKKQUIT=1 Q ; IENS(DA) ;Return IENS from DA array N I,IENS S IENS=$G(DA)_"," F I=1:1:$O(DA(" "),-1) S IENS=IENS_DA(I)_"," Q IENS DIKK1 DIKK1 ;SFISC/MKO-CHECK KEY INTEGRITY ;9:19 AM 5 Feb 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;======================== ; LOADALL(File,Flag,.MF) ;======================== ;Load info about all keys on a file. Use the "B" xref on the Key file. ;In: ; KFIL = File # [.31,.01] ; FLAG [ "s" : don't include subfile under file ;Out: ; ^TMP("DIKK",$J,keyFile#,file#) = levDif(keyfile,file) (if > 0) ; ^openRootDA ; ... file#,field#) = S X=$P($G(...),U,n) ; or S X=$E($G(...),m,n) ; ; ^TMP("DIKK",$J,"UI",file[.01],ui#) = key# ; ^TMP("DIKK",$J,"UIR",rFile[.51],ui#) = key# ; ; MF(file#,mField#) = multiple node ; MF(file#,mField#,0) = subfile# ; LOADALL(KFIL,FLAG,MF) ; N FLD,KEY,ROOT ; ;Get info for all keys on this file S KEY=0 F S KEY=$O(^DD("KEY","B",KFIL,KEY)) Q:'KEY D LOADKEY(KEY,.ROOT) Q:$G(FLAG)["s" ; ;Make a recursive call to get subfiles under KFIL N CHK,FIL,MFLD,PAR,SB D SUBFILES^DIKCU(KFIL,.SB,.MF) S SB=0 F S SB=$O(SB(SB)) Q:'SB D . D LOADALL(SB,"s") Q:'$D(^TMP("DIKK",$J,SB)) . ; . ;Set CHK(subfile)="" for subfile and its antecedents . S PAR=SB F Q:$D(CHK(PAR)) S CHK(PAR)=1,PAR=$G(SB(PAR)) Q:PAR="" ; ;Use the CHK array to get rid of unneeded elements in MF S FIL=0 F S FIL=$O(MF(FIL)) Q:'FIL D . S MFLD=0 F S MFLD=$O(MF(FIL,MFLD)) Q:'MFLD D .. K:'$D(CHK(MF(FIL,MFLD,0))) MF(FIL,MFLD) Q ; ;===================== ; LOADFLD(File,Field) ;===================== ;Load info for all keys of which a field is a part. ; LOADFLD(FIL,FLD) ; N KEY S KEY=0 F S KEY=$O(^DD("KEY","F",FIL,FLD,KEY)) Q:'KEY D LOADKEY(KEY) Q ; ;=================== ; LOADKEY(Key,Root) ;=================== ;Load info about a key. ;In: ; KEY = Key # ; .OROOT = Open root of File of Key [.31,.01] (optional) (also output) ;Out: ; .OROOT = Open root of File of Key [.31,.01] ; ^TMP (see LOADALL above) ; LOADKEY(KEY,OROOT) ; N DEC,FIL,FLD,FLDN,KFIL,LDIF,UI,UIFIL,UIRFIL ; ;Get key data S KFIL=$P($G(^DD("KEY",KEY,0)),U),UI=$P($G(^(0)),U,4) Q:'KFIL!'UI ; ;Get info about UI S UIFIL=$P($G(^DD("IX",UI,0)),U),UIRFIL=$P(^(0),U,9) Q:'UIFIL!'UIRFIL Q:$D(^TMP("DIKK",$J,"UI",UIFIL,UI)) S ^(UI)=KEY S ^TMP("DIKK",$J,"UIR",UIRFIL,UI)=KEY ; ;Get root of file [.31,.01] I $G(OROOT)="" S OROOT=$$FROOTDA^DIKCU(KFIL,"O")_"DA," Q:OROOT="DA," ; ;Loop through fields in key; get data extraction code S FLDN=0 F S FLDN=$O(^DD("KEY",KEY,2,FLDN)) Q:'FLDN D . Q:'$D(^DD("KEY",KEY,2,FLDN,0)) S FLD=$P(^(0),U),FIL=$P(^(0),U,2) . Q:'FLD!'FIL Q:$D(^TMP("DIKK",$J,KFIL,FIL,FLD))#2 . ; . I FIL'=KFIL N OROOT D Q:$G(OROOT)="" .. I $D(^TMP("DIKK",$J,KFIL,FIL))#2 S LDIF=+^(FIL),OROOT=U_$P(^(FIL),U,2,999) .. E D ... S LDIF=$$FLEVDIFF^DIKCU(FIL,KFIL) Q:'LDIF ... S OROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O") Q:OROOT="" ... S OROOT=OROOT_"DA("_LDIF_")," ... S ^TMP("DIKK",$J,KFIL,FIL)=LDIF_OROOT . ; . S DEC=$$DEC(FIL,FLD,OROOT) Q:DEC="" . S ^TMP("DIKK",$J,KFIL,FIL,FLD)=DEC ; Q ; ;============================== ; $$DEC(File#,Field#,OpenRoot) ;============================== ;Return code that sets X=data from file; examples: ; S X=$P($G(^DIZ(1000,DA(2),"m1",DA(1),"m2",DA,0)),U,3) ; S X=$E($G(^DIZ(1000,DA(2),"m1",DA(1),"m2",DA,0)),1,245) ;In: ; FIL = File # ; FLD = Field # ; OROOT = Open root of record (with DA strings) (optional) ; DEC(FIL,FLD,OROOT) ;Get data extraction code N ND,PC S PC=$P($G(^DD(FIL,FLD,0)),U,4) S ND=$P(PC,";"),PC=$P(PC,";",2) Q:ND?." " "" Q:"0 "[PC "" S:ND'=+$P(ND,"E") ND=""""_ND_"""" ; I $G(OROOT)="" S OROOT=$$FROOTDA^DIKCU(FIL,"O")_"DA," Q:OROOT="DA," "" I PC Q "S X=$P($G("_OROOT_ND_")),U,"_PC_")" E Q "S X=$E($G("_OROOT_ND_")),"_+$E(PC,2,999)_","_$P(PC,",",2)_")" ; DIKK2 DIKK2 ;SFISC/MKO-CHECK INPUT PARAMETERS TO INTEG^DIKK ;2:20 PM 15 Jul 1999 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;====== ; INIT ;====== ;Check input parameters to INTEG^DIKK and initialize variables. ;Out: ; DA = DA array ; DIFILE = File # ; DIKFIL = Root (Key) File # (passed in via the W# parameter in DICTRL) ; or DIFILE ; DIROOT = Closed root of file DIFILE ; DITAR = Closed root of ouptut array [default: ^TMP("DIKKTAR",$J)] ; DIKERR = 1 : if there's a problem ; DIKKQUIT = 0 : if DICTRL["Q" (indicates we should quit when the ; first problem is encountered) ; INIT ;Check and setup N DILEV,DIIENS ; ;Get and clean output array S DITAR=$G(DICTRL("TAR")) S:DITAR="" DITAR=$NA(^TMP("DIKKTAR",$J)) K @DITAR ; ;File is required I $G(DIFILE)="" D:DIF["D" ERR^DIKCU2(202,"","","","FILE") G ERR ; ;Check DIREC and set DA array I $G(DIREC)'["," M DA=DIREC S DIIENS=$$IENS(.DA) E S DIIENS=DIREC_$E(",",DIREC'?.E1",") D DA^DILF(DIIENS,.DA) S:'$G(DA) DA="" G:'$$VDA^DIKCU1(.DA,DIF) ERR ; ;Set DIFILE and DIROOT I DIFILE=+$P(DIFILE,"E") D . S DIROOT=$$FROOTDA^DIKCU(DIFILE,DIF,.DILEV) I DIROOT="" D ERR Q . I $L(DIIENS,",")-2'=DILEV D Q .. D:DIF["D" ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE) D ERR . S:DILEV DIROOT=$NA(@DIROOT) . S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q E D . S DIROOT=DIFILE . S:"(,"[$E(DIROOT,$L(DIROOT)) DIROOT=$$CREF^DILF(DIFILE) . S DIFILE=$$FNUM^DIKCU(DIROOT,DIF) I DIFILE="" D ERR Q . S DILEV=$$FLEV^DIKCU(DIFILE,DIF) I DILEV="" D ERR Q . I $L(DIIENS,",")-2'=DILEV D Q .. D:DIF["D" ERR^DIKCU2(205,"",$$IENS(.DA),"",DIFILE) D ERR Q:$G(DIKERR) ; ;Check DICTRL parameter I $G(DICTRL)]"",'$$VFLAG^DIKCU1(DICTRL,"QWds",DIF) G ERR ; ;Set DIKFILE = key (root) file I $G(DIKKEY) D Q:$G(DIKERR) . S DIKFIL=$P($G(^DD("KEY",DIKKEY,0)),U) . I 'DIKFIL D:DIF["D" ERR^DIKCU2(202,"","","","KEY") D ERR E S DIKFIL=+$P($G(DICTRL),"W",2) I 'DIKFIL S DIKFIL=DIFILE E G:'$$VFNUM^DIKCU1(DIKFIL,DIF) ERR ; K DIKKQUIT S:$G(DICTRL)["Q" DIKKQUIT=0 Q ; ERR ;Set error flag S DIKERR=1 Q ; CHECK(RFIL,DA,DITAR,DIKKQUIT) ;Check key integrity for one record N FIL,FLD,IENSC,KEY,ML,NULL,S,SS,UI,UIR,VAL,X S IENSC=$$IENS(.DA) ; S UI=0 F S UI=$O(^TMP("DIKK",$J,"UIR",RFIL,UI)) Q:'UI S KEY=^(UI) D Q:$G(DIKKQUIT) . ;Get info about uniqueness index . D XRINFO^DIKCU2(UI,.UIR,"","","","",.SS) . ; . ;Set UIR=root incl X(n); VAL(n)=X(n) if >= maxlen; SS(n)=dec . K NULL,VAL,X . S S=0 F S S=$O(SS(S)) Q:'S D Q:$G(DIKKQUIT) .. S FIL=$P(SS(S),U),FLD=$P(SS(S),U,2),ML=$P(SS(S),U,3) .. S SS(S)=^TMP("DIKK",$J,RFIL,FIL,FLD) .. X SS(S) I X="" D SETN^DIKK(FIL,IENSC,FLD,DITAR,.DIKKQUIT) S NULL=1 .. Q:$G(NULL) .. I ML,$L(X)'0 K X E S X=+$P(Y,"E") Q ; EHFLD ;Executable help for field Q:'$D(DA) Q:'$D(DA(1)) N DIKKFILE S DIKKFILE=$$GETFILE(.DA) Q:'DIKKFILE ; N %,D,D0,DA,DDD,DIC,DICR,DIX,DO,DP,Y S DIC="^DD("_DIKKFILE_",",DIC(0)="",D="B" S DIC("S")="I '$P(^(0),U,2)" S:$G(X)="??" DZ=X D DQ^DICQ Q ; GETFILE(DA) ; Q:'$D(DA) Q:'$D(DA(1)) N DIKKFILE I $D(DDS) S DIKKFILE=$$GET^DDSVAL(.31,DA(1),.01) E S DIKKFILE=$P($G(^DD("KEY",DA(1),0)),U) Q DIKKFILE DIKKFORM DIKKFORM ;SFISC/MKO-ENTRY POINTS FOR THE 'DIKC EDIT' FORM ;11:34 AM 16 Nov 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;========================== ; [DIKK EDIT] entry points ;========================== ; PRIOVAL ;Validation on Priority (#1) Q:$P(^DD("KEY",DA,0),U,3)=X N PK I X="P" D . S PK=$O(^DD("KEY","AP",$$GET^DDSVAL(.31,DA,.01),"P",0)) Q:'PK . S DDSERROR=1 . D HLP^DDSUTL($C(7)_"Primary Key '"_$P(^DD("KEY",PK,0),U,2)_"' is already defined on this file.") Q ; UIVAL ;Validation on Uniqueness Index (#3) ;Index must be Regular, used for Lookup/Sorting, have no set/kill ;conditions, and consist only of field-type cross reference values ;with no transforms. Q:X="" N CRV,FIL,FLD,LN0,SS ; ;Check that Index is regular and has no set/kill condition I $P($G(^DD("IX",X,0)),U,4)'="R" D UIERR("Selected index is not a Regular index.") Q I $P($G(^DD("IX",X,0)),U,14)'="LS"!($E($P($G(^(0)),U,2))="A") D UIERR("Selected index is not used for Lookup.") Q D:$G(^DD("IX",X,1.4))'?."^" UIERR("Selected index has a Set Condition.") D:$G(^DD("IX",X,2.4))'?."^" UIERR("Selected index has a Kill Condition.") ; ;Check Cross Reference Values S CRV=0 F S CRV=$O(^DD("IX",X,11.1,CRV)) Q:'CRV D . S LN0=$G(^DD("IX",X,11.1,CRV,0)) . I $P(LN0,U,2)'="F" D UIERR("Selected index has a computed value.") Q . I $G(^DD("IX",X,11.1,CRV,2))'?."^" D UIERR("Selected index has a value with a transform.") Q Q ; UIERR(MSG) ;Set DDSERROR=1 and print MSG N X S DDSERROR=1 D HLP^DDSUTL($C(7)_$G(MSG)) Q ; FORMDV ;Form-Level Data Validation ;In the Fields multiple, check that Sequence Numbers are unique and ;consecutive from 1. ;(Duplicate file/field combinations are checked automatically ;because they're key fields.) N DIKKDA,DIKKI,DIKKLIST,DIKKSQ ; ;Build list ; DIKKLIST(seq#,ien) ;while checking for duplicates ; S DIKKDA(1)=DA S DIKKDA=0 F S DIKKDA=$O(^DD("KEY",DA,2,DIKKDA)) Q:'DIKKDA D . S DIKKSQ=$$GET^DDSVAL(.312,.DIKKDA,1) . I $D(DIKKLIST(DIKKSQ)) D .. D:'$D(DDSERROR) MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES") .. S DDSERROR=1 .. D MSG^DDSUTL("The sequence number "_DIKKSQ_" is used more than once.") . E S DIKKLIST(DIKKSQ,DIKKDA)="" ; ;If no duplicates, check that sequence numbers are consecutive from 1 I '$D(DDSERROR) D . S DIKKSQ=0 . F DIKKI=1:1 S DIKKSQ=$O(DIKKLIST(DIKKSQ)) Q:'DIKKSQ!$G(DDSERROR) D:DIKKSQ'=DIKKI .. S DDSERROR=1 .. D MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES") .. D MSG^DDSUTL("Sequence numbers must be consecutive numbers starting with 1.") Q ; NAMEPAC ;Post-Action on Change for Name of Key N DIKKSD,DIKKUI ; S DIKKUI=$$GET^DDSVAL(.31,DA,3) Q:'DIKKUI S DIKKSD=$$GET^DDSVAL(.11,DIKKUI,.11) Q:DIKKSD'?1"Uniqueness Index for Key '"1A1"'".E ; S $E(DIKKSD,27)=X D PUT^DDSVAL(.11,DIKKUI,.11,DIKKSD) Q DIKKP DIKKP ;SFISC/MKO-PRINT KEYS ;9:52 AM 3 Mar 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;============================== ; PRINT(File,Field,Flag,.Page) ;============================== ;Print Keys defined a file ;In: ; FIL = File # ; FLD = Field # (optional) (ignored if FLAG [ M) ; FLAG [ Cn : column tab stop from left margin ; [ Ln : left margin (def=0) ; [ M : include subfiles (multiples) under File ; [ S : suppress line feed before listing ; PAGE("H") = Header text or M code that begins with a write statement ; PAGE("B") = Bottom margin ;Out: ; PAGE(U) = Returns as 1, if timeout or ^ at eop ; PRINT(FIL,FLD,FLAG,PAGE) ;Print keys Q:'$G(FIL) N FILETXT,LM,SB,SUB,TS,WID ; ;Initialize variables D INIT ; ;M flag, get and print keys for file and subfiles I FLAG["M" D . D SUBFILES^DIKCU(FIL,.SB) . S SUB="" . F D Q:PAGE(U) S:SUB="" SUB="SUB",FIL=0 S FIL=$O(SB(FIL)) Q:'FIL .. Q:'$D(^DD("KEY","B",FIL)) .. S FILETXT=SUB_"FILE #"_FIL .. I SUB]""!(FLAG'["S") D WRLN("",0,.PAGE) Q:PAGE(U) .. D WRLN(FILETXT,LM,.PAGE,2) Q:PAGE(U) .. D WRLN($TR($J("",$L(FILETXT))," ","-"),LM,.PAGE) Q:PAGE(U) .. D PRFILE(FIL,"",FLAG,.PAGE) Q:PAGE(U) ; ;Otherwise, print keys for one file E D . I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U) . D PRFILE(FIL,$G(FLD),FLAG,.PAGE) Q ; PRFILE(FIL,FLD,FLAG,PAGE) ;Print keys for a file Q:'$G(FIL) N KEY,NAM,SP I $G(FLAG)'["i" N LM,TS,WID D INIT ; I $G(FLD)="" D . S NAM="" F S NAM=$O(^DD("KEY","BB",FIL,NAM)) Q:NAM="" D Q:PAGE(U) .. S KEY=0 F S KEY=$O(^DD("KEY","BB",FIL,NAM,KEY)) Q:'KEY D Q:PAGE(U) ... I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U) ... D PRKEY(KEY,FLAG,.PAGE) ... S SP=1 ; E S KEY=0 F S KEY=$O(^DD("KEY","F",FIL,FLD,KEY)) Q:'KEY D Q:PAGE(U) . I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U) . D PRKEY(KEY,FLAG,.PAGE) . S SP=1 Q ; PRKEY(KEY,FLAG,PAGE) ;Print one key Q:'$G(KEY) N FIL,FLD,FLDN,LN,LUI,LUIN,NAM,PRI,SEQ,TAB1,TXT,UI,UI0 I $G(FLAG)'["i" N LM,TS,WID D INIT ; ;Print Priority, Key Name and Number Q:$G(^DD("KEY",KEY,0))?."^" S NAM=$P(^DD("KEY",KEY,0),U,2),PRI=$P(^(0),U,3),UI=$P(^(0),U,4) S:PRI]"" PRI=$$EXTERNAL^DILFD(.31,1,"",PRI) S TXT=PRI_" KEY: " S TXT=TXT_$J("",TS-$L(TXT))_NAM_" (#"_KEY_")" D WRLN(TXT,LM,.PAGE) Q:PAGE(U) ; ;Print Uniqueness Index I UI D . S UI0=$G(^DD("IX",UI,0)) . K TXT S TXT=0,TXT(0)=$P(UI0,U,2)_" (#"_UI_")" . D:$P(UI0,U)'=$P(UI0,U,9) ADDSTR(" WHOLE FILE (#"_$P(UI0,U)_")",.TXT) . D WRAP^DIKCU2(.TXT,WID) . D WRLN("Uniqueness Index: "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U) . F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U) ; ;Print Lookup Indexes K TXT S TXT=0,TXT(0)="" S LUIN=0 F S LUIN=$O(^DD("KEY",KEY,3.1,LUIN)) Q:'LUIN D . S LUI=$P($G(^DD("KEY",KEY,3.1,LUIN,0)),U) Q:'LUI . S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_", " . D ADDSTR($P($G(^DD("IX",LUI,0)),U,2)_" (#"_LUI_")",.TXT) I TXT(0)]"" D Q:PAGE(U) . D WRAP^DIKCU2(.TXT,WID) . D WRLN("Lookup Index(es): "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U) . F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U) ; ;Print Fields K TXT S TXT=0,TXT(0)="" S SEQ=0 F S SEQ=$O(^DD("KEY",KEY,2,"S",SEQ)) Q:'SEQ D Q:PAGE(U) . S FLD=0 F S FLD=$O(^DD("KEY",KEY,2,"S",SEQ,FLD)) Q:'FLD D Q:PAGE(U) .. S FIL=0 F S FIL=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL)) Q:'FIL D Q:PAGE(U) ... S FLDN=0 F S FLDN=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL,FLDN)) Q:'FLDN D Q:PAGE(U) .... Q:$G(^DD("KEY",KEY,2,FLDN,0))?."^" .... S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_" " .... D ADDSTR(SEQ_")"_$C(0)_$P($G(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",.TXT) I TXT(0)]"" D Q:PAGE(U) . D WRAP^DIKCU2(.TXT,WID) . D WRLN("File, Field: "_TXT(0),LM+TS-13,.PAGE) Q:PAGE(U) . F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U) Q ; ADDSTR(X,TXT) ;Add string X to the TXT array I $L(TXT(TXT))+$L(X)>200 S TXT=TXT+1,TXT(TXT)="" S TXT(TXT)=TXT(TXT)_X Q ; INIT ;Initialize module-wide variables Q:$G(FLAG)["i" S FLAG=$G(FLAG)_"i" S LM=$P(FLAG,"L",2)\1 S TS=$P(FLAG,"C",2)\1 S:'TS TS=20 S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1 S PAGE(U)="" Q ; ;=================================== ; WRLN(Text,Tab,.Page,KeepWithNext) ;=================================== ;Write a single line of text, precede with a !, do paging if necessary ;In: ; TXT = Text to write; $C(0) replaced with spaces. ; TAB = ?Tab before writing text (def=0) ; PAGE("H") = Header text or M code that begins with a write statement ; If not passed in, no paging. ; PAGE("B") = Bottom margin ; KWN = Additional padding on bottom margin ("keep with next") ;Out: ; PAGE(U) = Returns as 1, if timeout or ^ at eop ; WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text N X S PAGE(U)="" ; ;Do paging, if necessary I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U) . I PAGE("H")?1"W ".E X PAGE("H") Q . I $E($G(IOST,"C"))="C" D Q:PAGE(U) .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1 . W @$G(IOF,"#"),PAGE("H") ; ;Write text W !?$G(TAB),$TR($G(TXT),$C(0)," ") Q DIKKUTL DIKKUTL ;SFISC/MKO-UTILITY OPTION TO DEFINE A KEY ;8:13 AM 7 Jun 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. MOD ;Create/Modify/Edit a Key ;In: ; DI = selected top level file# ; DIU = global root of file DI N DIKKCNT,DIKKFILE,DIKKEY,DIKKQUIT,DIKKROOT,DIKKTOP N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; ;Get subfile S DIKKROOT=DIU,DIKKTOP=DI,DIKKFILE=$$SUB^DIKCU(DI) S:'$G(DIKKFILE) DIKKFILE=DIKKTOP ; REMOD ;Get and list keys on file DIKKFILE I $G(DIKKQUIT) W ! Q D GET^DIKKUTL2(DIKKFILE,.DIKKCNT) W ! D LIST^DIKKUTL2(.DIKKCNT) ; ;Prompt for action I 'DIKKCNT S Y="C" E S Y=$$RD Q:Y="" ; ;Delete I Y="D" D G REMOD . S DIKKEY=$$CHOOSE^DIKKUTL2(.DIKKCNT,"delete") Q:'DIKKEY . D DELETE(DIKKEY,DIKKTOP,DIKKFILE) ; ;Edit I Y="E" D G REMOD . S DIKKEY=$$CHOOSE^DIKKUTL2(.DIKKCNT,"edit") Q:'DIKKEY . D EDIT(DIKKEY,DIKKTOP,DIKKFILE) ; ;Create I Y="C" D G REMOD . S DIR(0)="Y",DIR("B")="No" . S DIR("A")="Want to create a new Key for this file" . D ^DIR K DIR I $D(DIRUT)!'Y S:'DIKKCNT DIKKQUIT=1 Q . D CREATE^DIKKUTL1(DIKKTOP,DIKKFILE) ; ;Verify I Y="V" D G REMOD . S DIKKEY=$$CHOOSE^DIKKUTL2(.DIKKCNT,"verify") Q:'DIKKEY . D VERIFY^DIKKUTL3(DIKKEY,DIKKTOP,DIKKFILE) Q ; DELETE(DIKKEY,DIKKTOP,DIKKFILE) ;Delete a Key N DIKKID,DIKKUI,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; ;Confirm deletion S DIR(0)="Y" S DIR("A")="Are you sure you want to delete the Key" S DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT)!'Y ; ;Delete S DIKKUI=$P($G(^DD("KEY",DIKKEY,0)),U,4) S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE) D DELKEY(DIKKEY,DIKKID) ; ;Ask/Delete Uniqueness Index I DIKKUI,'$D(^DD("KEY","AU",DIKKUI)) D . D DELUI(DIKKUI,DIKKTOP,DIKKFILE,DIKKID) Q ; EDIT(DIKKEY,DIKKTOP,DIKKFILE) ;Edit a Key N DIKKCH,DIKKFLD,DIKKID,DIKKNO,DIKKOLD,DIKKUI0,DIKKUI1,DIKKUFLD N DA,DDSFILE,DR ; REEDIT ;Come back here, if user chooses to re-edit the key S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE) ; ;Save original UI, and set and kill logic of original UI ;Invoke form to edit key ;Set new UI S DIKKUI0=$P($G(^DD("KEY",DIKKEY,0)),U,4) K DIKKOLD D:DIKKUI0 LOADXREF^DIKC1(DIKKFILE,"","K",DIKKUI0,"","DIKKOLD") S DDSFILE=.31,DA=DIKKEY,DR="[DIKK EDIT]" D ^DDS K DDSFILE,DA,DR S DIKKUI1=$P($G(^DD("KEY",DIKKEY,0)),U,4) ; ;If UI was edited, rebuild it I DIKKUI0,DIKKUI0=DIKKUI1 D . N DIKKNEW,DIKKFLIS . Q:$G(DIKKOLD(DIKKFILE,DIKKUI0,"K"))=$G(^DD("IX",DIKKUI1,2)) . W !,$C(7)_"The definition of the Uniqueness Index was modified." . D LOADXREF^DIKC1(DIKKFILE,"","S",DIKKUI0,"","DIKKNEW") . D GETFLIST^DIKCUTL(DIKKUI0,.DIKKFLIS) . D KSC^DIKCUTL3(DIKKTOP,.DIKKOLD,.DIKKNEW,.DIKKFLIS) K DIKKOLD ; ;If there was an old UI, and it's '= to new UI, ask/delete old UI I DIKKUI0,DIKKUI0'=DIKKUI1 D . D DELUI(DIKKUI0,DIKKTOP,DIKKFILE,DIKKID,DIKKEY) ; ;Quit if key was deleted. Q:$D(^DD("KEY",DIKKEY,0))[0 ; ;Get fields in key and new UI D GETFLD^DIKKUTL2(DIKKEY,DIKKUI1,.DIKKFLD,.DIKKUFLD) ; ;If key has no fields and no UI, ask reedit/delete key I 'DIKKFLD,'DIKKUI1 D G:DIKKCH<2 REEDIT Q . S DIKKCH=$$EORD^DIKKUTL4(DIKKID) Q:DIKKCH'=2 . D DELKEY(DIKKEY,DIKKID) ; ;If key has fields but no UI, create one. I DIKKFLD,'DIKKUI1 D G:DIKKCH=1 REEDIT Q:DIKKCH=2 G EDITEND . F D Q:DIKKCH'=3 .. S DIKKCH=0 .. D UICREATE^DIKKUTL1(DIKKEY,DIKKTOP,DIKKFILE,.DIKKNO) .. Q:'$G(DIKKNO) .. ; .. ;User aborted Uniqueness Index creation; .. ;Ask edit key/delete key/create UI .. W ! S DIKKCH=$$EDORC^DIKKUTL4 Q:DIKKCH'=2 .. D DELKEY(DIKKEY,DIKKID) ; ;If neither key nor UI has fields, ask reedit/delete key I 'DIKKFLD,'DIKKUFLD D G:DIKKCH<2 REEDIT Q . S DIKKCH=$$EORD^DIKKUTL4(DIKKID,1) Q:DIKKCH'=2 . D DELKEY(DIKKEY,DIKKID) ; ;Compare fields in Key with fields in Uniqueness Index; quit if same G:$$GCMP^DIKCU2("DIKKFLD","DIKKUFLD") EDITEND ; ;Key has a UI but no fields; or fields and UI don't match. ;Prompt re-edit/make key fields match UI/or make UI match key fields S DIKKCH=$$RORM^DIKKUTL4(DIKKUFLD,DIKKFLD) ; ;Re-edit I DIKKCH=1 G REEDIT ; ;Make key fields match UI E I DIKKCH=2 D . ;Delete all fields in Key . W !!," Modifying fields in Key ..." . N DA,DIK . S DIK="^DD(""KEY"","_DIKKEY_",2,",DA(1)=DIKKEY . S DA=0 F S DA=$O(^DD("KEY",DIKKEY,2,DA)) Q:'DA D ^DIK . K DA,DIK . ; . ;Add fields to Key . N DIKKFDA,DIKKIENS,DIKKSEQ . S DIKKSEQ=0 F S DIKKSEQ=$O(DIKKUFLD(DIKKSEQ)) Q:'DIKKSEQ D .. S DIKKIENS="+"_DIKKSEQ_","_DIKKEY_"," .. S DIKKFDA(.312,DIKKIENS,.01)=$P(DIKKUFLD(DIKKSEQ),U,2) .. S DIKKFDA(.312,DIKKIENS,.02)=$P(DIKKUFLD(DIKKSEQ),U) .. S DIKKFDA(.312,DIKKIENS,1)=DIKKSEQ . D UPDATE^DIE("","DIKKFDA") . I '$D(DIERR) W " DONE!" . E D MSG^DIALOG(),EOP ; ;Make UI match key fields E I DIKKCH=3 D UIMOD^DIKKUTL1(DIKKUI1,DIKKEY,DIKKTOP,DIKKFILE) ; EDITEND ; S DIKKCH=$$CHECK Q:'DIKKCH ; W !!,"Checking key integrity ..." I $$INTEG^DIKK(DIKKTOP,"","",DIKKEY) W " NO PROBLEMS" D EOP Q ; S DIKKCH=$$EDORI^DIKKUTL4 I DIKKCH=2 G REEDIT I DIKKCH=1 D DELETE(DIKKEY,DIKKTOP,DIKKFILE) Q ; DELUI(DIKKUI,DIKKTOP,DIKKFILE,DIKKID,DIKKEY) ;Delete the Uniqueness Index N I,MSG N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; ;If DIKKEY is passed in, quit if any key other than DIKKEY uses ;this index as a Uniqueness Index. (Index can't be deleted.) I $G(DIKKEY) D Q:I . S I=0 F S I=$O(^DD("KEY","AU",DIKKUI,I)) Q:'I Q:I'=DIKKEY ; S MSG(0)="Do you want to delete the "_$$UIID(DIKKUI,DIKKTOP,DIKKFILE)_" previously used by "_$S($G(DIKKID)]"":DIKKID,1:"the Key") D WRAP^DIKCU2(.MSG) S DIR(0)="Y" F I=0:1 Q:'$D(MSG(I+1)) S DIR("A",I+1)=MSG(I) S DIR("A")=MSG(I) W ! D ^DIR K DIR S:$D(DTOUT) Y=1 Q:$D(DUOUT)!'Y D DELETE^DIKCUTL(DIKKUI,DIKKTOP,DIKKFILE) Q ; DELKEY(DA,DIKKID) ;Call DIK to delete the key N DIK S DIK="^DD(""KEY""," D ^DIK W !!?2,$G(DIKKID)_" deleted." Q ; UIID(UI,TOP,FILE) ;Return text that identifies uniqueness index Q:$D(^DD("IX",UI,0))[0 "" Q "'"_$P(^DD("IX",UI,0),U,2)_"' Uniqueness Index (#"_UI_") on "_$S(TOP'=FILE:"Subf",1:"F")_"ile #"_$P(^(0),U) ; KEYID(KEY,TOP,FILE) ;Return string of text that identifies the key Q "Key '"_$P(^DD("KEY",KEY,0),U,2)_"' of "_$S(TOP'=FILE:"Subf",1:"F")_"ile #"_$P(^(0),U) ; RD() ;Prompt for action N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="SAO^V:VERIFY;E:EDIT;D:DELETE;C:CREATE" S DIR("A")="Choose V (Verify)/E (Edit)/D (Delete)/C (Create): " S DIR("?",1)="Enter 'V' to verify the integrity of a Key." S DIR("?",2)=" 'E' to edit an existing Key" S DIR("?",3)=" 'D' to delete an existing Key" S DIR("?",4)=" 'C' to create a new Key." W ! D ^DIR S:$D(DIRUT) Y="" Q Y ; EOP ;Issue Press Return to continue prompt N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="E",DIR("A")="Press RETURN to continue" S DIR("?")="Press the RETURN or ENTER key." W ! D ^DIR Q ; CHECK() ;Prompt whether to check key integrity N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR("A")="Do want to check the integrity of this key now" S DIR("?")="Enter 'Y' to run the key integrity checker." S DIR(0)="Y" W ! D ^DIR Q $S($D(DIRUT):0,1:Y) DIKKUTL1 DIKKUTL1 ;SFISC/MKO-KEY CREATION ;10:08 AM 12 Jan 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; CREATE(DIKKTOP,DIKKFILE) ;Create a new key N DIKKEY,DIKKFDA,DIKKNAME,DIKKIEN ; ;Prompt for name S DIKKNAME=$$NAME(DIKKFILE) Q:DIKKNAME=-1 ; ;Add new entry to Key file W !," Creating new Key '"_DIKKNAME_"' ..." S DIKKFDA(.31,"+1,",.01)=DIKKFILE S DIKKFDA(.31,"+1,",.02)=DIKKNAME S DIKKFDA(.31,"+1,",1)=$S($D(^DD("KEY","AP",DIKKFILE,"P")):"S",1:"P") D UPDATE^DIE("","DIKKFDA","DIKKIEN") I $D(DIERR) D MSG^DIALOG() Q ; S DIKKEY=DIKKIEN(1) K DIKKIEN D EDIT^DIKKUTL(DIKKEY,DIKKTOP,DIKKFILE) Q ; UIMOD(DIXR,DIKKEY,DIKKTOP,DIKKFILE) ;Modify the UI to match the Key N DIKKERR,DIKKFLD,DIKKFLIS,DIKKID,DIKKMSG,DIKKNEW,DIKKOLD S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE) ; ;Write message W !!," Modifying Uniqueness Index ..." ; ;Get list of fields and original kill logic D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS) D LOADXREF^DIKC1(DIKKFILE,"","K",DIXR,"","DIKKOLD") ; ;Get list of fields in key D GETFLD(DIKKEY,.DIKKFLD) ; ;Stuff values into Uniqueness Index and fields into CRV multiple D STUFF(DIXR,$P(^DD("IX",DIXR,0),U),DIKKFILE,$P(^(0),U,2),.DIKKFLD,DIKKID) D DELCRV(DIXR) D ADDCRV(DIXR,.DIKKFLD) W " DONE!" ; ;Get list of fields and new set logic. ;Kill old and set new index, and recompile input templates and xrefs. D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS) D LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW") D KSC^DIKCUTL3(DIKKTOP,.DIKKOLD,.DIKKNEW,.DIKKFLIS) Q ; UICREATE(DIKKEY,DIKKTOP,DIKKFILE,DIKKNO) ;Create a new UI for key ;Returns DIKKNO=1 if the Index could not be created. N DIERR,DIKKERR,DIKKFDA,DIKKFLIS,DIKKID,DIKKMSG,DIKKNAM,DIKKNEW,DIXR,I ; K DIKKNO S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE) ; ;Write message K DIKKMSG S DIKKMSG(0)="I'm going to create a new Uniqueness Index to support "_DIKKID_"." D WRAP^DIKCU2(.DIKKMSG) W ! F I=0:1 Q:'$D(DIKKMSG(I)) W !,DIKKMSG(I) K I,DIKKMSG ; ;Get Index Name and list of fields S DIKKNAM=$$NAME^DIKCUTL1(DIKKFILE,"LS") I DIKKNAM=-1 S DIKKNO=1 Q D GETFLD(DIKKEY,.DIKKFLD) ; ;Add uniqueness index to Index file, and fields into CRV multiple D ADDUI(DIKKFILE,DIKKNAM,.DIXR) I DIXR=-1 S DIKKNO=1 Q D STUFF(DIXR,DIKKFILE,DIKKFILE,DIKKNAM,.DIKKFLD,DIKKID) D ADDCRV(DIXR,.DIKKFLD,.DIKKERR) I $G(DIKKERR) S DIKKNO=1 Q ; ;Set Uniqueness Index pointer in Key file S DIKKFDA(.31,DIKKEY_",",3)=DIXR D FILE^DIE("","DIKKFDA") I $D(DIERR) D MSG^DIALOG() S DIKKNO=1 Q K DIKKFDA ; ;Get new field list and set logic. ;Set new index and recompile input templates and xrefs. D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS) D LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW") D KSC^DIKCUTL3(DIKKTOP,"",.DIKKNEW,.DIKKFLIS) Q ; ADDUI(DIKKFILE,DIKKNAM,DIXR) ;Add new entry to Index file N DIKKFDA,DIKKIEN W !!," One moment please ..." S DIKKFDA(.11,"+1,",.01)=DIKKFILE S DIKKFDA(.11,"+1,",.02)=DIKKNAM D UPDATE^DIE("","DIKKFDA","DIKKIEN") I $D(DIERR) D MSG^DIALOG() Q S DIXR=DIKKIEN(1) Q ; STUFF(DIXR,DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKID) ;Stuff other values into ;index N DIERR,DIKKFDA,DIKKILL,DIKKSET,DIKKWKIL ; ;Build logic D BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,.DIKKFLD,.DIKKSET,.DIKKILL,.DIKKWKIL) ; ;Stuff values into other fields in Index file entry S DIKKFDA(.11,DIXR_",",.11)="Uniqueness Index for "_DIKKID S DIKKFDA(.11,DIXR_",",.2)="R" S DIKKFDA(.11,DIXR_",",.4)=$S(DIKKFLD>1:"R",1:"F") S DIKKFDA(.11,DIXR_",",.41)="IR" S DIKKFDA(.11,DIXR_",",.42)="LS" S DIKKFDA(.11,DIXR_",",.5)=$S(DIKKF01=DIKKFILE:"I",1:"W") S DIKKFDA(.11,DIXR_",",.51)=DIKKFILE S DIKKFDA(.11,DIXR_",",1.1)=DIKKSET S DIKKFDA(.11,DIXR_",",2.1)=DIKKILL S DIKKFDA(.11,DIXR_",",2.5)=DIKKWKIL D FILE^DIE("","DIKKFDA") I $D(DIERR) D MSG^DIALOG() Q ; ADDCRV(DIXR,DIKKFLD,DIKKERR) ;Add fields to Cross-Reference Values multiple N DA,DD,DIC,DIERR,DIKKFDA,DIKKSS,DINUM,DO,X,Y ; S DIC("P")=$P(^DD(.11,11.1,0),U,2) F DIKKSS=1:1 Q:$D(DIKKFLD(DIKKSS))[0 D Q:$G(DIKKERR) . ;Add subentry . S DIC="^DD(""IX"","_DIXR_",11.1,",DIC(0)="QL",DA(1)=DIXR . S (X,DINUM)=DIKKSS . K DD,DO D FILE^DICN K DA,DIC,DINUM . I Y=-1 S DIKKERR=1 Q . ; . ;Stuff other values . S DIKKFDA(.114,DIKKSS_","_DIXR_",",.5)=DIKKSS . S DIKKFDA(.114,DIKKSS_","_DIXR_",",1)="F" . S DIKKFDA(.114,DIKKSS_","_DIXR_",",2)=$P(DIKKFLD(DIKKSS),U,2) . S DIKKFDA(.114,DIKKSS_","_DIXR_",",3)=$P(DIKKFLD(DIKKSS),U) . D FILE^DIE("","DIKKFDA") . I $D(DIERR) D MSG^DIALOG() S DIKKERR=1 Q ; DELCRV(DIXR) ;Delete all entries in CRV multiple N DA,DIK S DIK="^DD(""IX"","_DIXR_",11.1,",DA(1)=DIXR S DA=0 F S DA=$O(^DD("IX",DIXR,11.1,DA)) Q:'DA D ^DIK Q ; GETFLD(KEY,FLD) ;Get list fields in key ;In: ; KEY = key # ;Out: ; FLD = # subscripts ; FLD(subscript#) = field^file ; N DA,FD,FI,SQ K FLD S (FLD,SQ)=0 F S SQ=$O(^DD("KEY",KEY,2,"S",SQ)) Q:'SQ D . S FD=$O(^DD("KEY",KEY,2,"S",SQ,0)) Q:'FD . S FI=$O(^DD("KEY",KEY,2,"S",SQ,FD,0)) Q:'FI . S DA=$O(^DD("KEY",KEY,2,"S",SQ,FD,FI,0)) Q:'DA . Q:$D(^DD("KEY",KEY,2,DA,0))[0 . S FLD=FLD+1,FLD(FLD)=FD_U_FI Q ; BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKSET,DIKKILL,DIKKWKIL) ; ;Build the logic of the xref N DIKKLDIF,DIKKROOT,DIKKSS,L I 'DIKKFLD S (DIKKSET,DIKKILL)="Q",DIKKWKIL="" Q ; ;Build index root and entire kill logic I DIKKF01'=DIKKFILE S DIKKLDIF=$$FLEVDIFF^DIKCU(DIKKF01,DIKKFILE) E S DIKKLDIF=0 S DIKKROOT=$$FROOTDA^DIKCU(DIKKF01,DIKKLDIF_"O")_""""_DIKKNAM_"""" S DIKKWKIL="K "_DIKKROOT_")" ; ;Build root for set/kill logic F DIKKSS=1:1 Q:$D(DIKKFLD(DIKKSS))[0 D . S DIKKROOT=DIKKROOT_","_$S($G(DIKKFLD)=1:"X",1:"X("_DIKKSS_")") ; ;Append DA(n) to root F L=DIKKLDIF:-1:1 S DIKKROOT=DIKKROOT_",DA("_L_")" S DIKKROOT=DIKKROOT_",DA)" ; ;Build set/kill logic S DIKKSET="S "_DIKKROOT_"=""""",DIKKILL="K "_DIKKROOT Q ; NAME(DIKKFILE) ;Get next available Key name N DIKKNAME N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; S DIKKNAME=$O(^DD("KEY","BB",DIKKFILE,""),-1) S DIKKNAME=$S(DIKKNAME="":"A",1:$C($A(DIKKNAME)+1)) ; S DIR(0)=".31,.02" S DIR("A")="Enter a Name for the new Key" S DIR("B")=DIKKNAME W ! F D Q:$D(X)!$D(DIRUT) . D ^DIR Q:$D(DIRUT) . Q:'$D(^DD("KEY","BB",DIKKFILE,X)) . D NAMERR("A key already exists with this name.") Q $S($D(DIRUT):-1,1:X) ; NAMERR(MSG) ;Invalid Index Name error W !!,$C(7)_$G(MSG),! K X Q ; KEYID(KEY,TOP,FILE) ;Return string of text that identifies the key Q "Key '"_$P(^DD("KEY",KEY,0),U,2)_"' of "_$S(TOP'=FILE:"Subf",1:"F")_"ile #"_$P(^(0),U) ; DIKKUTL2 DIKKUTL2 ;SFISC/MKO-KEY DEFINITION, SOME UTILITIES ;1:25 PM 17 Jul 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;================== ; GET(file,.count) ;================== ;Returns: ; CNT = # keys^file# ; CNT(keyName) = key# ; CNT(keyName,0) = file#^Name^Priority^UniqIndex ; CNT(keyName,seq#) = field#^file#^seq# ; GET(FIL,CNT) ;Get information about keys on file FIL N FLD,KEY,NAM N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; K CNT S CNT=0 S NAM="" F S NAM=$O(^DD("KEY","BB",FIL,NAM)) Q:NAM="" S KEY=$O(^(NAM,0)) Q:'KEY D . I $G(^DD("KEY",KEY,0))?."^" D Q .. K ^DD("KEY","B",FIL,KEY),^DD("KEY","BB",FIL,NAM,KEY) . S CNT=CNT+1 . S CNT(NAM)=KEY . S CNT(NAM,0)=^DD("KEY",KEY,0) . S FLD=0 F S FLD=$O(^DD("KEY",KEY,2,FLD)) Q:'FLD D .. I $D(^DD("KEY",KEY,2,FLD,0))#2,+$P(^(0),U,3) S CNT(NAM,$P(^(0),U,3))=^(0) S $P(CNT,U,2)=FIL Q ; ;===================== ; LIST(.count,header) ;===================== ;List the keys in the CNT array ;In: ; CNT = Array of keys to print (obtained by GET call above) ; HDR = Text to print before listing ; (default is 'Current Indexes[ on [sub]file #xxx]:') ; LIST(CNT,HDR) ; I '$G(CNT) D Q . W !,"There are no Keys defined on "_$$FSTR^DIKCUTL2($P(CNT,U,2))_"." ; N DIERR,FIL,FILE01,FLD,KEY,MSG,NAM,PRIO,SN,TAG,UI,UITXT ; ;Write header S:$G(HDR)="" HDR="Keys defined on "_$$FSTR^DIKCUTL2($P(CNT,U,2))_":" W !,HDR ; ;Loop through keys in CNT array S NAM="" F S NAM=$O(CNT(NAM)) Q:NAM="" D . S KEY=CNT(NAM) . S FILE01=$P(CNT(NAM,0),U),PRIO=$P(CNT(NAM,0),U,3) . S UI=$P(CNT(NAM,0),U,4) . I UI]"" D .. S UI=$G(^DD("IX",UI,0)) .. S UITXT=$P(UI,U,2) .. S:$P(UI,U)'=$P(UI,U,9) UITXT=UITXT_"; Whole File (#"_$P(UI,U)_")" . W !!?2,NAM,?5,$$EXTERNAL^DILFD(.31,1,"",PRIO,"MSG")_" KEY" . W:UI]"" ?20,"Uniqueness Index: "_UITXT . ; . ;Loop through fields in key . S TAG="Field(s): " . I $O(CNT(NAM,0)) S SN=0 F S SN=$O(CNT(NAM,SN)) Q:'SN D .. S FLD=$P(CNT(NAM,SN),U),FIL=$P(CNT(NAM,SN),U,2) .. W !?9,TAG_SN_") "_$P($G(^DD(FIL,FLD,0)),U)_" (#"_FLD_$S(FIL=FILE01:")",1:", from File #"_FIL) .. S TAG=$J("",11) Q ; ;========================= ; $$CHOOSE(.count,prompt) ;========================= ;Prompt for a key from the DIKKCNT array ;In: ; .DIKKCNT = Array contain key data (obtained by GET call above) ; DIKCPR = Action to include with the prompt ;Returns: ; Key ien (or 0, if none selected) ; CHOOSE(DIKKCNT,DIKKPR) ;Choose a key Q:'$G(DIKKCNT) 0 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="FAO^1:30^K:$D(DIKKCNT(X))[0 X" S DIR("A")="Which Key do you wish to "_DIKKPR_"? " S:+DIKKCNT=1 DIR("B")=$O(DIKKCNT(0)) S DIR("?")="^D LIST^DIKKUTL2(.DIKKCNT)" W ! D ^DIR I $D(DIRUT) Q 0 Q DIKKCNT(Y) ; ;=================================================== ; GETFLD(key#,uniqIndex#,.keyField,.uniqIndexField) ;=================================================== ;Get the fields in key and uniqueness index ;In: ; KEY = key ien ; UI = uniqueness index ien ;Out: ; KEYFLD = # items in array ; KEYFLD(I) = file^field ; UIFLD = # items in array ; UIFLD(I) = file^field ; GETFLD(KEY,UI,KEYFLD,UIFLD) ; N I,FIL,FLD,ORD,S ; ;Loop through "S" index on Sequence Number of the Field multiple ;of the Key and set the KEYFLD array S I=0 K KEYFLD I $G(KEY),$D(^DD("KEY",KEY,0))#2 D . S S=0 F S S=$O(^DD("KEY",KEY,2,"S",S)) Q:'S D .. S FLD=$O(^DD("KEY",KEY,2,"S",S,0)) Q:'FLD S FIL=$O(^(FLD,0)) Q:'FIL .. S I=I+1,KEYFLD(I)=FIL_U_FLD S KEYFLD=I ; ;Loop through the "AC" index on Subscript Number of the Cross- ;Reference Values multiple of the Index file and set the UIFLD ;array S I=0 K UIFLD I $G(UI),$D(^DD("IX",UI,0))#2 D . S S=0 F S S=$O(^DD("IX",UI,11.1,"AC",S)) Q:'S D .. S ORD=$O(^DD("IX",UI,11.1,"AC",S,0)) Q:'ORD .. S FIL=$P($G(^DD("IX",UI,11.1,ORD,0)),U,3),FLD=$P($G(^(0)),U,4) .. Q:'FIL Q:'FLD .. S I=I+1,UIFLD(I)=FIL_U_FLD S UIFLD=I Q DIKKUTL3 DIKKUTL3 ;SFISC/MKO-VERIFY KEY INTEGRITY ;3:10 PM 27 Oct 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; VERIFY(DIKKEY,DIKKTOP,DIKKFILE) ;Verify key integrity N DIKKTEMP,POP,%ZIS ; ;Ask whether to save records in a template S DIKKTEMP=$$ASKTEMP(DIKKTOP) ; ;Select Device S %ZIS=$S($D(^%ZTSK):"Q",1:"") W ! D ^%ZIS Q:$G(POP) K %ZIS,POP ; ;Queue report I $D(IO("Q")) D Q . N I,ZTSK . S ZTRTN="MAIN^DIKKUTL3" . S ZTDESC="KEY INTEGRITY CHECK" . F I="DIKKEY","DIKKTOP","DIKKFILE","DIKKTEMP" S ZTSAVE(I)="" . D ^%ZTLOAD . I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),! . E W !,"Report canceled!",! . S IOP="HOME" D ^%ZIS ; U IO ; MAIN ;Queued tasks enter here N DIKKHLIN,DIKKFIL,DIKKNAME,DIKKPAGE,DIKKTAB,DIKKUI,DIKKUIFL,DIKKUINM N DIKKIENS,DIKKFLD,DIKKFNAM,DIKKROOT,DIKKSUPP K ^TMP("DIKKUTL",$J) ; ;Check key integrity D INTEG^DIKK(DIKKTOP,"","",DIKKEY,"",1) I $D(DIERR) D MSG^DIALOG() Q ; ;Initialize "global" variables for report S DIKKPAGE=0 S %H=$H D YX^%DTC S DIKKHLIN=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)_" PAGE " S DIKKTAB(1)=9,DIKKTAB(2)=41 S DIKKNAME=$P($G(^DD("KEY",DIKKEY,0)),U,2) S DIKKUI=$P($G(^DD("KEY",DIKKEY,0)),U,4) S DIKKUINM=$P($G(^DD("IX",+DIKKUI,0)),U,2),DIKKUIFL=$P($G(^(0)),U) ; ;Print first header W:$E(IOST,1,2)="C-" @IOF D HDR I '$D(^TMP("DIKKTAR",$J)) W !!," ** NO PROBLEMS **" G END ; ;Loop through target error and list problems S DIKKFIL=0 F S DIKKFIL=$O(^TMP("DIKKTAR",$J,DIKKFIL)) Q:'DIKKFIL!$D(DIRUT) D . D COLHDR . S DIKKROOT=$$FROOTDA^DIKCU(DIKKFIL) . S DIKKIENS=" " . F S DIKKIENS=$O(^TMP("DIKKTAR",$J,DIKKFIL,DIKKIENS)) Q:DIKKIENS=""!$D(DIRUT) D .. D:$D(^TMP("DIKKTAR",$J,DIKKFIL,DIKKIENS,"K",DIKKEY)) KEYERR(DIKKFIL,DIKKIENS,DIKKEY,DIKKROOT) .. S (DIKKSUPP,DIKKFLD)=0 .. F S DIKKFLD=$O(^TMP("DIKKTAR",$J,DIKKFIL,DIKKIENS,DIKKFLD)) Q:'DIKKFLD!$D(DIRUT) D FLDERR(DIKKFIL,DIKKIENS,DIKKFLD,DIKKROOT,.DIKKSUPP) .. Q:$D(DIRUT) .. D W() ; END D:'$D(DIRUT) EOPREAD ; ;Save in template, cleanup, and quit D:$G(DIKKTEMP) SAVETEMP(DIKKTEMP) K ^TMP("DIKKTAR",$J) I $D(ZTQUEUED) S ZTREQ="@" E X $G(^%ZIS("C")) Q ; KEYERR(RFIL,IENS,KEY,ROOT) ; D WRREC(RFIL,IENS,DIKKTAB(1),.ROOT) Q:$D(DIRUT) W ?DIKKTAB(2),"Duplicate Key "_$P($G(^DD("KEY",KEY,0)),U,2)_" (#"_KEY_")" Q ; FLDERR(FIL,IENS,FLD,ROOT,SUPP) ; I '$G(SUPP) D Q:$D(DIRUT) . D WRREC(FIL,IENS,DIKKTAB(1),.ROOT) Q:$D(DIRUT) . W ?DIKKTAB(2),"Missing Key Field(s):" D W($P($G(^DD(FIL,FLD,0)),U)_" ["_FIL_","_FLD_"]",DIKKTAB(2)+1) S SUPP=1 Q ; WRREC(FILE,IENS,TAB,ROOT) ;Write the record info N DA,DIERR,ENAM,MSG S:$G(ROOT)="" ROOT=$$FROOTDA^DIKCU(FILE) D DA(IENS,.DA) Q:$D(DIRUT) S ENAM=$P($G(@ROOT@(DA,0)),U) S:ENAM]"" ENAM=$$EXTERNAL^DILFD(FILE,.01,"",ENAM,"MSG") W ?TAB,$S(ENAM]"":ENAM,1:"Unknown record name") Q ; W(STR,TAB,KWN) ;Write STR I $Y+3+$G(KWN)'0 ^DIBT(+Y,"QR")=DT_U_CNT Q ; DA(IENS,DA) ;Given IENS, write ien's and setup DA array N I D W("","",$L(IENS,",")-2) Q:$D(DIRUT) K DA F I=$L(IENS,",")-1:-1:2 S DA(I-1)=$P(IENS,",",I) W DA(I-1),! S DA=$P(IENS,",") W DA Q ; DIKKUTL4 DIKKUTL4 ;SFISC/MKO-KEY DEFINITION, READER PROMPTS ;10:01 AM 15 Jul 1998 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ;================== ; $$RORM(ufld,fld) ;================== ;Prompt for method to resolve difference between fields in key ;and fields in uniqueness index. ; Called from EDIT when key fields and UI fields don't match. ;In: ; $G(DIKKUFLD) : include option 2 (there are UI fields) ; $G(DIKKFLD) : include option 3 (there are key fields) ;Returns: ; 1 : Re-edit the key ; 2 : Make key match UI (default on ^, timeout when UI fields exist) ; 3 : Make UI match key (default on ^, timeout when no UI fields) ; RORM(DIKKUFLD,DIKKFLD) ; N DIKKOPT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y W !!,"The Key fields and the fields in the Uniqueness Index don't match." S DIR(0)="S^1:Re-Edit the Key",DIKKOPT=1 S:$G(DIKKUFLD) DIKKOPT=2,DIR(0)=DIR(0)_";2:Make Key match Uniqueness Index (also selected on up-arrow)" S:$G(DIKKFLD) DIKKOPT=DIKKOPT+1,DIR(0)=DIR(0)_";"_DIKKOPT_":Make Uniqueness Index match Key"_$S(DIKKOPT=2:" (also selected on up-arrow)",1:"") D ^DIR I '$G(DIKKUFLD) Q $S($D(DIRUT):3,Y=2:3,1:Y) Q $S($D(DIRUT):2,1:Y) ; ;=========================== ; $$EDORD(KeyIdString,flag) ;=========================== ;Prompt edit or delete the key. ; Called from EDIT^DIKKUTL when there are no key fields and ; either no Uniqueness Index or no UI fields. ;In: ; DIKKID = string that identifies the key -- used in message ; DIKKFL = controls message (there are neither key nor UI fields) ;Returns: ; 1 : Re-edit the key ; 2 : Delete the key (default on ^, timeout) ; EORD(DIKKID,DIKKFL) ;Choose to edit or delete the key. N DIKKMSG,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,X,Y ; ;Write message that key definition is incomplete I '$G(DIKKFL) S DIKKMSG(0)=$C(7)_"NOTE: "_DIKKID_" has neither fields nor a Uniqueness Index defined." E S DIKKMSG(0)=$C(7)_"NOTE: "_DIKKID_" and its Uniqueness Index have no fields defined." D WRAP^DIKCU2(.DIKKMSG,-7,0) W ! F I=0:1 Q:'$D(DIKKMSG(I)) W !,@$S(I:"?6",1:"?0"),DIKKMSG(I) ; ;Prompt 'Re-edit' or 'Delete' S DIR(0)="S^1:Re-edit the Key;2:Delete the Key (also selected on up-arrow)" D ^DIR Q $S($D(DIRUT):2,1:Y) ; ;========== ; $$EDORC ;========== ;Prompt whether edit key, delete key, or create a Uniqueness Index. ; Called from EDIT^DIKKUTL when the user chose to create a new UI ; but failed to provide a name for that Index. ;Returns: ; 1 : Re-edit the key ; 2 : Delete the key (default on ^, timeout) ; 3 : Create a new Uniqueness Index ; EDORC() ;Choose to edit key, delete key, or create a Uniqueness Index N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; W !,$C(7)_"NOTE: All Keys must have a Uniqueness Index defined." S DIR(0)="S^1:Re-edit the Key;2:Delete the Key (also selected on up-arrow);3:Create a Uniqueness Index" S DIR("?")="All Keys must have a Uniqueness index defined." D ^DIR Q $S($D(DIRUT):2,1:Y) ; ;========== ; $$EDORI ;========== ;Prompt whether to delete, re-edit, or ignore ; Called from EDIT^DIKKUTL when the key fails integrity check. ;Returns: ; 1 : Delete the Key ; 2 : Re-Edit the Key ; 3 : Ignore problem ; EDORI() ;Choose to edit key, delete key, or create a Uniqueness Index N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; W !!,$C(7)_"ERROR: The key is not unique and/or some records have key field values missing." S DIR(0)="S^1:Delete the Key (also selected on up-arrow);2:Re-Edit the Key;3:Ignore problem (Be sure to fix later)" S DIR("?")="The Key is invalid because it is not unique and/or some records have missing key field values." D ^DIR Q $S($D(DIRUT):1,1:Y) DIKZ DIKZ ;SFISC/XAK-XREF COMPILER ;1JUN2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; I $G(DUZ(0))'="@" W:$D(^DI(.84,0)) $C(7),$$EZBLD^DIALOG(101) Q EN1 N DIKJ,%X D:'$D(DISYS) OS^DII I '$D(^DD("OS",DISYS,"ZS")) W $C(7),$$EZBLD^DIALOG(820) Q S U="^" S:'$G(DTIME) DTIME=300 D SIZ^DIPZ0(8036) G:$D(DTOUT)!($D(DUOUT))!('X) Q1 S DMAX=X FILE K DIC S DMAX=X,DIC="^DIC(",DIC(0)="AEQ" D ^DIC G Q1:Y'>0 N DIPZ S DIPZ=+Y D RNM^DIPZ0(8036) G:$D(DTOUT)!($D(DUOUT))!(X="") Q1 S DNM=X W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G:'Y!($D(DIRUT)) Q1 S X=DNM,Y=DIPZ K DIPZ EN ; S Y(1)=$$EZBLD^DIALOG(8036),Y(3)=Y D BLD^DIALOG(8024,.Y,"","DIR") W:'$G(DIKZS) !!,DIR,! K Y(1),Y(3) K ^UTILITY($J),^UTILITY("DIK",$J) N DIK,DIFILENO S DNM=X,(DH,DIFILENO)=+Y I $D(^DIC(+Y,0,"GL")) S DIK2=^("GL") I '$D(DIK2)!(DMAX<2400) G Q S X=DH D DELETROU^DIEZ(DNM),A^DIU21,WAIT^DICD:'$G(DIKZS),DT^DICRW ;DELETE OLD ROUTINES, DELETE "DIK" NODES S (DRN,DIKZQ,T)=0,DMAX=DMAX-100 ; ;Load indexes defined in Index file N DIXRLIST,DIKMF K ^TMP("DIKC",$J) D LOADALL^DIKC1(DIFILENO,"KS","R","",$NA(^TMP("DIKC",$J)),"",.DIKMF) ; ; compile kill logic S (DIKA,A)=1,X=2,DIKVR="DIKILL",DIK=DIK2 D Q2,NEWR S ^UTILITY($J,0,3)=" S DIKZK="_X S DIKGO="^"_DNM_1 ;starting ROUTINE name D ^DIKZ0 G:DIKZQ Q D RTE ; ; compile set logic S (DIKA,A)=1,X=1,DIKVR="DISET",DIK=DIK2 D Q2,NEWR S ^UTILITY($J,0,3)=" S DIKZK="_X S DIKGO=DIKGO_",^"_DNM_DRN D ^DIKZ0 G:DIKZQ Q D RTE ; ; compile driver code D Q2,^DIKZ1 ; ; finish up S:'DIKZQ ^DD(DIFILENO,0,"DIKOLD")=DNM Q I DIKZQ S X=DH(1) D A^DIU21 Q1 K DH,X,Y,DIK4,DIKQ,DIKC,T,DV,DIK8,DU,DW,DW1,DIKGO,DRN,DNM,DTOUT,DIRUT,DIROUT,DUOUT,DIC,A,%,%H,%Y K DIKVR,DIK6,DIKA,DIKR,DMAX,DIK2,DIKCT,DIK1,DIK0,^UTILITY($J),^("DIK"),DIK,DIKZQ,DIKZZ,DIKZZ1,DIKZOVFL K ^TMP("DIKC",$J) Q2 K DIKRT,DIKLW,DIKL2 Q SV ; transfer the accumulated code in ^UTILITY($J,#) to ^UTILITY($J,0,#) ; (the routine buffer) and call SAVE to flush the buffer into a routine ; whenever it's full. Flush the buffer one more time when done. S DNM(1)=DNM_DRN F DIKR=0:0 S DIKR=$O(^UTILITY($J,DIKR)) Q:DIKR'>0 S %=^(DIKR) K ^(DIKR) D:T+$L(%)>DMAX S ^UTILITY($J,0,DIKR)=%,T=T+$L(%)+2 . N DIKZMORE S DIKZMORE=1 D SAVE D SAVE Q SAVE ; save the accumulated code in ^UTILITY($J,0,#) as a routine I DIKR,$E($P(%," ",2))="." F D Q:$E($P(%," ",2))'="." . S ^UTILITY($J,DIKR)=% . S DIKR=$O(^UTILITY($J,0,DIKR),-1),%=^(DIKR) K ^(DIKR) I $D(DIKLW),'DIKR S ^UTILITY($J,0,997)=" G:'$D(DIKLM) "_$C(64+DIKCT)_$S(DNM_DRN'=DNM(1):"^"_DNM(1),1:"")_" Q:$D("_DIKVR_")" I $D(DIKLW),DIKR S ^UTILITY($J,0,998)=" G ^"_DNM_(DRN+1) S ^UTILITY($J,0,999)="END "_$S($D(DIKRT)&'DIKR:"Q",1:"G "_$S(DIKR&($D(DIKLW)):"END",1:"")_U_DNM_(DRN+1)) N X,DIR S X=DNM_DRN X ^DD("OS",DISYS,"ZS") S X(1)=X D BLD^DIALOG(8025,.X,"","DIR") W:'$G(DIKZS) !,DIR S:$G(DIKZRLA)]"" @DIKZRLA@(DNM_DRN)="",DIKZRLAF=1 D NEWR:'$D(DIKRT)!$G(DIKZMORE) Q:DIKZQ S ^DD(DH,0,"DIK")=DNM K DIKL2 Q NEWR ; I '$D(DIKRT),T,$D(%),T+$L(%)>DMAX S DIKZDH=+$P(^UTILITY($J,0,1),"#",2) K ^UTILITY($J,0) S DIKR=4,T=0,DRN=DRN+1 I $L(DNM_DRN)>8 W:'$G(DIKZS) $C(7),!,DNM_DRN_$$EZBLD^DIALOG(1503) S:$G(DIKZRLA)]"" DIKZRLAF=0 S DIKZQ=1 Q S ^UTILITY($J,0,1)=DNM_DRN_" ; COMPILED XREF FOR FILE #"_$S($D(DIKZDH):DIKZDH,1:DH)_" ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),^(2)=" ; " K DIKZDH Q RTE ; N DIKFIL,DIKSUB,DIKLIST,DIKP ;Build DIKSUB(file)=subfile1,subfile2,... list S DIKFIL=0 F S DIKFIL=$O(DIK(X,DIKFIL)) Q:'DIKFIL D . S DIKSUB=0 F S DIKSUB=$O(^DD(DIKFIL,"SB",DIKSUB)) Q:'DIKSUB D .. S:$D(DIK(X,DIKSUB))#2 DIKSUB(DIKFIL)=$G(DIKSUB(DIKFIL))_DIKSUB_"," ; ;Build DIKLIST(file)=subfile1,subfile2,... M DIKLIST=DIKSUB S DIKFIL=0 F S DIKFIL=$O(DIKSUB(DIKFIL)) Q:'DIKFIL D . S DIKP=0 . F D Q:DIKP'<($L(DIKLIST(DIKFIL),",")-1) .. F DIKP=DIKP+1:1:$L(DIKLIST(DIKFIL),",")-1 D ... S DIKSUB=$P(DIKLIST(DIKFIL),",",DIKP) ... S DIKLIST(DIKFIL)=DIKLIST(DIKFIL)_$G(DIKSUB(DIKSUB)) K DIKSUB ; ;Convert file numbers in DIKLIST to routine list S DIKFIL=0 F S DIKFIL=$O(DIKLIST(DIKFIL)) Q:'DIKFIL D . S $E(DIKLIST(DIKFIL),$L(DIKLIST(DIKFIL)))="" . S DIKLIST(DIKFIL)=DIKFIL_","_DIKLIST(DIKFIL) . F DIKP=1:1:$L(DIKLIST(DIKFIL),",") D .. S DIKSUB=$P(DIKLIST(DIKFIL),",",DIKP) .. S $P(DIKLIST(DIKFIL),",",DIKP)=DIK(X,DIKSUB) ; ;Move list to DIK M DIK(X)=DIKLIST K DIKFIL,DIKLIST,DIKP S DIKRT=1,A=A-1,DH=DH(1) G SV ; EN2(Y,DIKZFLGS,X,DMAX,DIKZRLA,DIKZZMSG) ;Silent or Talking with parameter passing ;and optionally return list of routines built and if successful ;FILE#,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY ;Y=FILE NUMBER (required) ;FLAGS="T"alk (optional) ;X=ROUTINE NAME (required) ;DMAX=ROUTINE SIZE (optional) ;DIKZRLA=ROUTINE LIST ARRAY, by value (optional) ;DIKZZMSG=MESSAGE ARRAY (optional) (default ^TMP) ;* ;DIKZS will be used to indicate "silent" if set to 1 ;Write statements are made conditional, if not "silent" ;* N DIKZS,DNM,DIQUIET,DIKZRIEN,DIKZRLAZ,%X,DIKJ,DIR,DIKZRLAF,DK1 N DIK,DIC,%I,DICS S DIKZS=$G(DIKZFLGS)'["T" S:DIKZS DIQUIET=1 I '$D(DIFM) N DIFM S DIFM=1 D .N Y,DIKZFLGS,X,DMAX,DIKZRLA,DIKZS .D INIZE^DIEFU I $G(Y)'>0 D BLD^DIALOG(1700,"File Number missing or invalid") G EN2E I '$D(^DD(Y,0)) D BLD^DIALOG(1700,"File Number: "_Y_" Invalid") G EN2E I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing") G EN2E I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E S DIKZRLA=$G(DIKZRLA,"DIKZRLAZ"),DIKZRIEN=Y S:DIKZRLA="" DIKZRLA="DIKZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU") S DIKZRLAF="" K @DIKZRLA D EN G:'DIKZS!(DIKZRLAF) EN2E D BLD^DIALOG(1700,"Compiling Cross-references (FILE#:"_DIKZRIEN_")"_$S(DIKZRLAF=0:", routine name too long",1:"")) EN2E I 'DIKZS D MSG^DIALOG() Q I $G(DIKZZMSG)]"" D CALLOUT^DIEFU(DIKZZMSG) Q ; ;DIALOG #101 'only those with programmer's access' ; #820 'no way to save routines on the system' ; #8020 'Should the compilation run now?' ; #8024 'Compiling template name Input template of file n' ; #8036 'Cross-References' ; #8025 'Routine filed' ; #1503 'routine name is too long...' DIKZ0 DIKZ0 ;SFISC/XAK-XREF COMPILER ;23AUG2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DIK0=" I X'=""""" D DD^DIK,A,SD Q:DIKZQ RET I $D(DK1) S A=A+1,DIKA=1,DH=0 F S DH=$O(DK1(DH)) Q:DH'>0 D E^DIK S:DH="" DH=-1 I $D(DK1) K DK1 D SD Q:DIKZQ G RET Q SD F DH=DH(1):0 S DH=$O(DU(DH)) Q:DH'>0 S:$D(^DD(DH,"SB")) DK1(DH)="" D DD1^DIK,0 Q:DIKZQ S:$D(^DD(DH,"IX"))!$D(^TMP("DIKC",$J,DH)) DIK(X,DH)="A1^"_DNM_DRN K:'$D(^DD(DH,"IX"))&'$D(^TMP("DIKC",$J,DH)) DIK(X,DH) K DU(DH) Q 0 ; D SV^DIKZ Q:DIKZQ S DIK1="" I $D(DIKA) S DIK1=" S DA("_A_")=DA"_$S(A=1:"",1:"("_(A-1)_")") F DIKL2=A-1:-1:1 S DIK1=DIK1_" S DA("_DIKL2_")=0" S ^UTILITY($J,DIKR+1)=DIK1_" S DA=0",DIKR=DIKR+2,^(DIKR)="A1 ;" D ^DIKZ2 K DIKA S DIKLW=1 S DIKR=DIKR+1,DIK=DIK2_DIK8(DH),^UTILITY($J,DIKR)=A_" ;",DIKR=DIKR+1 A ; K DIK6 F DIKQ=0:0 S DIKQ=$O(^UTILITY("DIK",$J,DH,DIKQ)) Q:DIKQ'>0 I $G(DIKVR)="DISET"!(DIKQ'=.01) S %=^(DIKQ) S:+%'=% %=""""_%_"""" D PUT I $G(DIKVR)="DIKILL",$D(^UTILITY("DIK",$J,DH,.01)) S DIKQ=.01,%=^(.01) S:+%'=% %=""""_%_"""" D PUT D INDEX K ^UTILITY("DIK",$J),DIK6 Q PUT N DIKSET I '$D(DIK6(%)) S ^UTILITY($J,DIKR)=" S DIKZ("_%_")=$G("_DIK_"DA,"_%_"))",DIK6(%)="" S DIKR=DIKR+1,(DIKSET,^UTILITY($J,DIKR))=" "_$P(^UTILITY("DIK",$J,DH,DIKQ,0),"^(X)")_"DIKZ("_%_")"_$P(^(0),"^(X)",2,9) F DIKC=0:0 S DIKC=$O(^UTILITY("DIK",$J,DH,DIKQ,DIKC)) S DIKR=DIKR+1 Q:DIKC'>0 D .S %=^(DIKC) S:$O(^(0))'=DIKC ^UTILITY($J,DIKR)=DIKSET,DIKR=DIKR+1 .I %["Q:"!(%[" Q") K DIK6 S ^UTILITY($J,DIKR)=DIK0_" X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")" Q .I %["D RCR" K DIK6 S ^UTILITY($J,DIKR)=DIK0_" D",DIKR=DIKR+2,^(DIKR-1)=" .N DIK,DIV,DIU,DIN",^UTILITY($J,DIKR)=" ."_^UTILITY("DIK",$J,DH,DIKQ,DIKC,0) Q .I %["S XMB=" S ^UTILITY($J,DIKR)=DIK0_",$D(DIK(0)),DIK(0)[""B"" S DIKZR="_DIKC_",DIKZZ="_DIKQ_" D BUL^"_DNM,DIKR=DIKR+1,^UTILITY($J,DIKR)=DIK0_",'$D(DIKOZ) "_$S($L(%)<225:%,1:"X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")") Q .S ^UTILITY($J,DIKR)=DIK0_" "_$S(%[" AUDIT":"S DH="_DH_",DV="_DIKQ_",DU="_A_" ",1:"")_%_$S(%[" AUDIT":"^DIK1",1:"") Q ; ; INDEX ;Loop through ^TMP and pick up cross references for file DH N DIKO,DIKCTAG S DIKCTAG=0 ; ;Build code for each xref S DIKC=0 F S DIKC=$O(^TMP("DIKC",$J,DH,DIKC)) Q:'DIKC D GETINDEX D:DIKCTAG LINE("CR"_(DIKCTAG+1)_" K X") Q ; GETINDEX ;Get code for one index DIKC in file DH I DIKVR="DIKILL",$G(^TMP("DIKC",$J,DH,DIKC,"K"))?."^" Q I DIKVR="DISET",$G(^TMP("DIKC",$J,DH,DIKC,"S"))?."^" Q ; N DIKF,DIKCOD,DIKO,DIK01 S DIKCTAG=DIKCTAG+1 D LINE("CR"_DIKCTAG_" S DIXR="_DIKC) ; ;Build code to set X array S DIKF=$O(^TMP("DIKC",$J,DH,DIKC,0)) Q:'DIKF D LINE(" K X") S DIKO=0 F S DIKO=$O(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:'DIKO D XARR D LINE(" S X=$G(X("_DIKF_"))") ; ;Build code to check for null subscripts S DIKCOD="",DIKO=0 F S DIKO=$O(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:'DIKO D:$G(^(DIKO,"SS")) . S DIKCOD=DIKCOD_$E(",",DIKCOD]"")_"$G(X("_DIKO_"))]""""" D LINE($S(DIKCOD]"":" I "_DIKCOD_" D",1:" D")) ;**GFT -- NOIS ISL-0604-50146 ** D LINE(" . K X1,X2 M X1=X,X2=X") ; I DIKVR="DIKILL" D . ;Adjust .01 values X2 array if we're deleting a record . I $D(DIK01) D ..S DIKCOD="",DIKO=0 F S DIKO=$O(DIK01(DIKO)) Q:'DIKO D ;**GFT -- NOIS ISL-0604-50146 ** ... S DIKCOD=DIKCOD_$E(",",DIKCOD]"")_"X2("_DIKO_")" .. Q:DIKCOD="" .. S:DIKF=$O(DIK01(0)) DIKCOD="X2,"_DIKCOD .. S:DIKCOD["," DIKCOD="("_DIKCOD_")" .. D LINE(" . S:$D(DIKIL) "_DIKCOD_"=""""") . ; . ;Get kill condition code . S DIKCOD=$G(^TMP("DIKC",$J,DH,DIKC,"KC")) . I DIKCOD'?."^" D .. D LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1") .. D LINE(" . "_DIKCOD) .. D LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR") .. D LINE(" . Q:'DIKCOND") . ;Get kill logic . D LINE(" . "_$G(^TMP("DIKC",$J,DH,DIKC,"K"))) ; I DIKVR="DISET" D . ;Get set condition code . S DIKCOD=$G(^TMP("DIKC",$J,DH,DIKC,"SC")) . I DIKCOD'?."^" D .. D LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1") .. D LINE(" . "_DIKCOD) .. D LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR") .. D LINE(" . Q:'DIKCOND") . ;Get set logic . D LINE(" . "_$G(^TMP("DIKC",$J,DH,DIKC,"S"))) K DIK6 Q ; XARR ;Build code to set X array ;Also return DIK01(order#)="" if crv is .01 field N CODE,NODE,REF,LINE,TRANS ;K DIK01 ; ;Build data extraction code S CODE=$G(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:CODE?."^" I $D(^TMP("DIKC",$J,DH,DIKC,DIKO,"F"))#2 D . S DIK01(DIKO)="" . S REF=$P($P(CODE,",",1,$L(CODE,",")-2),"(",2,999) . S NODE=$P($P(REF,",",$L(REF,",")),"))") . I '$D(DIK6(NODE)) D .. D LINE(" S DIKZ("_NODE_")="_REF) .. S DIK6(NODE)="" . S LINE=" "_$P(CODE,REF)_"DIKZ("_NODE_")"_$P(CODE,REF,2,999) E S LINE=" "_CODE ; S TRANS=$G(^TMP("DIKC",$J,DH,DIKC,DIKO,"T")) I TRANS'?."^" D . D LINE(LINE) . D DOTLINE(" I $G(X)]"""" "_TRANS) . D LINE(" S:$D(X)#2 X("_DIKO_")=X") E I $G(NODE)]"",LINE?1" S X=".E D . D LINE(" S X("_DIKO_")"_$E(LINE,5,999)) E D . D LINE(LINE) . D LINE(" S:$D(X)#2 X("_DIKO_")=X") Q ; DOTLINE(CODE) ;Add code to ^UTILITY. If the code looks like it contains ;a Quit command, put the code under a do-dot structure. I CODE[" Q"!(CODE["Q:") D . D LINE(" D") . D LINE(" . "_CODE) E D LINE(CODE) Q ; LINE(CODE) ;Add line of code to ^UTILITY, increment DIKR S ^UTILITY($J,DIKR)=CODE S DIKR=DIKR+1 Q DIKZ1 DIKZ1 ;SFISC/XAK-XREF COMPILER ;1:52 PM 7 Jan 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. NEWR ; K ^UTILITY($J) S DRN="" S ^UTILITY($J,0,1)=DNM_" ; DRIVER FOR COMPILED XREFS FOR FILE #"_DH(1)_" ; "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),^(2)=" ; " S ^UTILITY($J,0,3)=" N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2" S ^UTILITY($J,0,4)=" I '$D(DIKSAT) S DIKLK=DIK_DA_"")"" L +@DIKLK:10 K:'$T DIKLK" S ^UTILITY($J,0,5)=" D DI I '$D(DIKSAT),$D(DIKLK) L -@DIKLK" S ^UTILITY($J,0,6)=" G Q" S ^(7)="DI S DIKM1=0,DIKUM=0,DA(0)="""",DV=0 F S DV=$O(DA(DV)) Q:DV'>0 S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV)" S ^(8)=" S:DV="""" DV=-1 S DH(1)="_DH(1)_",DIKUP=DA" S ^(9)=" I $D(DIKKS) D:DIKZ1=DH(1) "_$P(DIKGO,",")_" S DA=DIKUP D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q" S ^(10)=" I $D(DIKIL) D:DIKZ1=DH(1) "_$P(DIKGO,",")_" S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q" S ^(11)=" I $D(DIKST) D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET D DA Q" S ^(12)=" I $D(DIKSAT) D SET1 D DA Q" S ^(13)=" Q" S ^(14)="DA K DA F DV=1:1 Q:'$D(DIKUP(DV)) S DA(DV)=DIKUP(DV)" S ^(15)=" S DA=DIKUP Q" S ^(16)="SET1 S (DA,DCNT)=0" S ^(17)=" S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK["","":DU_"")"",1:DU) L +@DIKLK:10 K:'$T DIKLK" S ^(18)="C I @(""$O(""_DIK_""DA))'>0"") S DA=$$C1(DA),^(0)=$P(@(DIK_""0)""),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q" S ^(19)=" S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"""" S DU=1,DCNT=DCNT+1 S:DA="""" (DIKY,DA)=-1 D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C" S ^(20)=" Q" S ^(21)="C1(A) Q:$P($G(@(DIK_""A,0)"")),U)]"""" A" S ^(22)=" F S @(""A=+$O(""_DIK_""A),-1)"") Q:$P($G(@(DIK_""A,0)"")),U)]""""!(A'>0)" S ^(23)=" Q A" S ^(24)="KILL S DIKILL=1,DIKZK=2",DIKR=24,X=2 D SUB S DIKR=DIKR+1,^(DIKR)=" Q" S DIKR=DIKR+1,^(DIKR)="SET S DISET=1,DIKZK=1 K DIKPUSH",X=1 D SUB F DIK8=1:1 S DIKRT=$T(TEXT+DIK8) Q:DIKRT="" S ^(DIKR+DIK8)=$E(DIKRT,4,999) S (DRN,DIKR)="",T=0 F DIKZZ=0:0 S DIKZZ=$O(^UTILITY($J,0,DIKZZ)) Q:DIKZZ'>0 S %=^(DIKZZ),T=T+$L(%) I T>DMAX S DIKZOVFL=1 D OVFL^DIKZ11 Q S T=0 I $D(DIKZOVFL) D SAVE^DIKZ K ^UTILITY($J,0) F DIKZZ=0:0 S DIKZZ=$O(^UTILITY($J,"OVFL",DIKZZ)) Q:DIKZZ'>0 S %=^(DIKZZ) S ^UTILITY($J,0,DIKZZ)=% I $D(DIKZOVFL) S DRN=0 K ^UTILITY($J,"OVFL") G SAVE^DIKZ ; SUB F DIK8=0:0 S DIK8=$O(DIK(X,DIK8)) Q:DIK8'>0 S DIKR=DIKR+1,^(DIKR)=" I DIKZ1="_DIK8_","_$P(DIK2(DIK8),",",4)_" S "_$P(DIK2(DIK8),",",3)_" D "_DIK(X,DIK8)_" Q" Q TEXT ;; ;; Q ;;KIL1 K @(DIK_"DA)") Q:'$D(^(0)) ;; S Y=^(0),DH=$S($O(^(0))'>0:0,1:$P(Y,U,4)-1),X=$P($P(Y,U,3),U,DH>0) D 3:X=DA ;; S ^(0)=$P(Y,U,1,2)_U_X_U_DH ;; Q ;;Q K DIKGP,DIKZ1 Q ;; ; ;;3 I X>1,$D(^(X-1)) S X=X-1 Q ;; S DV=1 F X=X:1 S X=X+DV,DV=DV+1 I $O(^(X))'>0 S DU=X-2,DV=1 Q ;;L S X=$O(^(DU)) Q:X>0 S DU=DU-DV,DV=DV+1 S:DU<0 DU=0 G L ;; Q ;;BUL S DIKOZ=1,DIKZA=$P("CREA^DELE",U,DIKZK)_"TE VALUE" ;; I $D(^DD(DIKZ1,DIKZZ,1,DIKZR,DIKZA)) W "...(`",^(DIKZA),"` BULLETIN WILL NOT BE TRIGGERED) " Q DIKZ11 DIKZ11 ;SFISC/DCM-XREF COMPILER ;9/3/93 13:44 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. OVFL ; S ^UTILITY($J,"OVFL",1)=DNM_0_" ; DRIVER FOR COMPILED XREFS FOR FILE !"_DH(1)_" (cont); "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),^(2)=" ; " S ^UTILITY($J,0,7)=" I $D(DIKKS) D:DIKZ1=DH(1) "_$P(DIKGO,",")_" S DA=DIKUP D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET"_U_DNM_0_" D DA Q" S ^UTILITY($J,0,9)=" I $D(DIKST) D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET"_U_DNM_0_" D DA Q" S ^UTILITY($J,0,17)=" S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"""" S DU=1,DCNT=DCNT+1 S:DA="""" (DIKY,DA)=-1 D:DIKZ1=DH(1) "_$P(DIKGO,",",2)_" D:DIKZ1'=DH(1) SET"_U_DNM_0_" D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C" F DIKZZ=0:0 S DIKZZ=$O(^UTILITY($J,0,DIKZZ)) Q:DIKZZ="" S %=^(DIKZZ) I $E(%,1,4)="SET " D OVFL1 Q Q OVFL1 S DIKZZ1=4,^UTILITY($J,"OVFL",DIKZZ1)=% K ^UTILITY($J,0,DIKZZ) F S DIKZZ=$O(^UTILITY($J,0,DIKZZ)) Q:DIKZZ="" S %=^(DIKZZ) Q:$E(%,1,5)="KIL1 " S DIKZZ1=DIKZZ1+1,^UTILITY($J,"OVFL",DIKZZ1)=% K ^UTILITY($J,0,DIKZZ) Q DIKZ2 DIKZ2 ;SFISC/XAK-XREF COMPILER ;1:52 PM 7 Jan 2000 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. S DIKR=DIKR+1 S DIK1=" I $D("_DIKVR_") K DIKLM S:DIKM1="_A_" DIKLM=1" I A>1 D . S DIK1=DIK1_" S:DIKM1'="_A_"&'$G(DIKPUSH("_A_")) DIKPUSH("_A_")=1," . F DIK4=A:-1:2 S DIK8=DIK4-1,DIK1=DIK1_"DA("_DIK4_")=DA("_DIK8_")," . S DIK1=DIK1_"DA(1)=DA,DA=0" . F DIK4=2:1:A-1 S DIK1=DIK1_" S:DIKM1<"_DIK4_" DA("_(A-DIK4)_")=0" S ^UTILITY($J,DIKR)=DIK1_" G @DIKM1" S DIKR=DIKR+1,DIKCT=0 I A>1 D DAR S ^UTILITY($J,DIKR)=A-1_" ;",DIKR=DIKR+1 D:DIKVR="DIKILL" WFK S DIKCT=DIKCT+1,DIKL2=A-1,DIK1=$C(64+DIKCT)_" S DA=$O("_DIK2_DIK8(DH)_"DA))" S ^UTILITY($J,DIKR)=DIK1_" I DA'>0 S DA=0 "_$S(DIKL2=0:"",1:"Q:DIKM1="_DIKL2_" ")_"G "_$S(A'<2:$C(64+A-1),1:"END"),DIKR=DIKR+1 K DIK6 Q CRT ; I '$D(^DD(DV,"IX")),'$D(^TMP("DIKC",$J,DV)) K DU(DV) Q S DIK(X,DV)="",DIK4(DV)=DW,DIK2(DV)="DA("_A_"),,DIKM1="_A_",DIKUM'<"_A I A=1 S DIK8(DV)=$P(DIK2(DV),",",1,2)_DIK4(DV)_"," E I $D(DIK2(DH)) S DIKC=DV,DIK8(DV)="" F DIK8=1:1:A D . S DIK8(DV)="DA("_DIK8_"),"_DIK4(DIKC)_","_DIK8(DV) . S DIKC=^DD(DIKC,0,"UP") Q DAR ; S (DIKC,DIK1,%,DIKL2)=1,DIKQ=0 F DIK8=A-1:-1:1 S DIKC=DIKC+2,DIKCT=DIKCT+1,DIK4=" S DA("_DIK8_")=$O("_DIK2_$P(DIK8(DH),",",1,DIKC)_"))" S:'$D(%) ^UTILITY($J,DIKR)=DIKL2_" ;",DIKR=DIKR+1,DIKL2=DIKL2+1 K % D DAR2 K DIK1 Q DAR2 ; S ^UTILITY($J,DIKR)=$C(64+DIKCT)_DIK4_" I DA("_DIK8_")'>0 S DA("_DIK8_")=0 "_$S($D(DIK6)&('$D(DIK1)):"Q:DIKM1="_DIKQ_" ",1:"")_"G "_$S($D(DIK1):"END",1:$C(64+DIKCT-1)),DIKR=DIKR+1,DIKQ=DIKQ+1,DIK6=1 Q ; WFK ;Get whole file kill xrefs N DIKXR,DIKKW,DIKKW0,DIKCODE S DIKXR=0 F S DIKXR=$O(^TMP("DIKC",$J,"KW",DH,DIKXR)) Q:'DIKXR D . S DIKKW=$G(^TMP("DIKC",$J,"KW",DH,DIKXR)) . Q:DIKKW?."^"!(DIKKW="Q") . S DIKKW0=$G(^TMP("DIKC",$J,"KW",DH,DIKXR,0)) . I DIKKW0="" D DOTLINE^DIKZ0(" "_DIKKW) Q . Q:$P(DIKKW0,U)'="W" . ; . ;Build code to push down DA array . S DIKCODE=$$BCPDA(A,$P(DIKKW0,U,2)) . I DIKCODE]"" D LINE^DIKZ0(" "_DIKCODE) . D DOTLINE^DIKZ0(" "_DIKKW) . I DIKCODE]"" D LINE^DIKZ0(" K DA M DA=DIKSVDA") Q ; BCPDA(LEV,RFILE) ;Build code to push down DA array N DIFF,COD,I,RLEV S RLEV=$$FLEV^DIKCU(RFILE) S DIFF=RLEV-LEV Q:DIFF<1 "" ; S COD="" F I=RLEV:-1:DIFF S COD=COD_"DA("_I_")=DA("_(I-DIFF)_")," F I=DIFF-1:-1:0 S COD=COD_"DA("_I_")=0," I COD]"" D . S COD=$E(COD,1,$L(COD)-1) . F Q:COD'["DA(0)" S COD=$P(COD,"DA(0)")_"DA"_$P(COD,"DA(0)",2,999) . S COD="K DIKSVDA M DIKSVDA=DA S "_COD Q COD DIL DIL ;SFISC/GFT/XAK-TURN PRINT FLDS INTO CODE ;31DEC2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. LOOP F DD=1:1 S W=$P(R,$C(126),DD) G Q:W="" S:DIWL DIWL=9 D DM I DIO D S DIO=0 .S DN=-8 Q:DIO=1 .I DIO=3 D UN .S DIWR(DM)=DX,Y=" D 0^DIWW" D PX ; DM I DM G UP:$P(W,F)]"" S W=$P(W,F,2,999) I W[";Y" S DE="" D W:DG S I=+$P(W,";Y",2),DG=0,Y=DE_" F Y=0:0 Q:$Y>"_$S(I>0:I-2,1:"(IOSL"_(I-2)_")")_" W !" S:I>0 M(DP)=I D PX S O=999 G ^DIL1:'W,^DIL11:W?.NP1",".E,^DIL1:$P(W,";",1)'=+W K DPQ(DP,+W) D DE,^DIL0 G T:DU=DN I $P(X,U,2)["C" S DN=-2 G PX S DN=DU,Y=" S X=$G("_DI_C_DN_"))"_Y PX ; I DHT G PX^DIPZ1:DHT<0 S ^UTILITY($J,DV)=$E(Y,2,999),Y="",DV=DV+1 Q S DX=DX+1 G PX:$D(^UTILITY($J,99,DX)) S ^(DX)=$E(Y,2,999) D DX(DX) S O=0 Q Q ; DE S DE="" I W[";S" D W:DG S I=+$P(W,";S",2),DG=0 S:'I I=1 S M(DP)=M(DP)+I,DE=DE_" D T Q:'DN " F I=I:-1:1 S DE=DE_" D N" I $P(W,";C",2) S DIC=$P(W,";C",2) S:DIC<0 DIC=IOM+DIC+1 D W:DIC"_DG_" Q:'DN " S DE=DE_" W ?"_DG Q W ; D DIWR^DIL0:$D(DIWR) A ;FROM DIP5 AND DIPZ & above S M(DP)=M(DP)+1 I DHD D COLHEADS(.DHD) I $D(DIOSUBHD) S:DIOSUBHD<2 DIOSUBHD=2 D COLHEADS(.DIOSUBHD) Q ; ; COLHEADS(DHD) ;TAKE COLUMN HEADERS AND STORE THEM AS WRITE STATEMENTS, STARTING AT ^UTILITY($J,DHD) N V,I,Z,% S I=99,V="" F S V=$O(^UTILITY("DIL",$J,V)) Q:V="" S Z=$O(^(V,0)) I I>Z S I=Z F I=I:1:99 S Z="W !" D I Z'="W !" D U .S V="" F S V=$O(^UTILITY("DIL",$J,V)) Q:V="" I $D(^(V,I)) S %=$G(^($O(^(0))-I+99)) D ..F Q:%'?1" ".E S V=V+1,%=$E(%,2,999) ..I $L(Z)+$L(%)>245 D U ..S Z=Z_",?"_V_","""_%_"""" K ^UTILITY("DIL",$J) Q U S ^UTILITY($J,DHD)=Z,DHD=DHD+1,Z="W """"" Q ; ; SUBHEADS ; N X S X=$$EZBLD^DIALOG(7095) ;"PAGE" W:$X+30>IOM ! W ?IOM-30,$$NOW^DIUTL," " I $G(DC) W ?IOM-$L(X)-4,X," ",DC F X=1.5:0 S X=$O(^UTILITY($J,X)) Q:X>50!'X X ^(X) Q ; D ; D PX:DHT<1 S F(DM)=DX,R(DX)=DP(DM),R(DX,1)=M(DP(DM)),F=F_W_",",DM=DM+1,DIL=DIL+1,DD=DD-1 I DHT+1 S DX=$S('DHT:900,1:DX) D:DHT PX Q G DE^DIPZ1 ; UP D UN G DM ; UNSTACK ; D UN Q:'DM G UNSTACK ; UN ; D DIWR^DIL0:$D(DIWR(DM)) D:DHT<0 UP^DIPZ1 S O=999,DN=-8,DM=DM-1,DIL=DIL-1,DP=DP(DM),DX=+$S(DM:F(DM),1:0),F=$P(F,",",1,DM)_$E(",",DM>0),DY=DY(DM),DI=DI(DM) I $D(DIL(DM)) S Y=" K J("_DIL0_"),I("_DIL0_")",DIL=DIL(DM),DIL0=DIL(DM,0) K DIL(DM) F X=DIL0:1 S %=X#100,V="I("_X_",0)",Y=Y_" S:$D("_V_") D"_%_"="_V I X=DIL G PX Q ; O ; D DE,DN^DIL0 T ; G PX:'$D(^UTILITY($J,99,DX))!DIO,PX:$L(^(DX))+$L(Y)+O>240 S ^(DX)=^(DX)_Y Q ; DX(DX) ;If we're in sub-fields, another UTILITY node needs to invoke node DX Q:'DM N Y S Y=F(DM-1) D IF S ^(Y)=^UTILITY($J,99,Y)_$S($T:",^UTILITY($J,99,",1:" X ^UTILITY($J,99,")_DX_")" I $T,$L(^UTILITY($J,99,Y))>99 F O=500:1 I '$D(^(O)) S ^(Y)=$E(^(Y),1,$L(^(Y))-1-$L(DX))_O_")",F(DM-1)=O,^(O)="X ^UTILITY($J,99,"_DX_")" Q Q IF I ^UTILITY($J,99,Y)?.E1"^UTILITY($J,99,".N1")" Q DIL0 DIL0 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;24JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D XDUY S %=$P(X,U,2) S:%["Cm"&(W[";W") %="w"_% G WP:%["W",M:%["m",STATS^DIL1:$D(DCL(DP_U_+W)),N:W[";N" I W[";W" D S D1=$S(%["C":Y,1:$P(" S Y=",U,Y'?1" ".E)_Y_" S X=Y") D W S Y=Y_D1_" D ^DIWP" Q .N %,DNP S DNP=1 D EN^DILL(DP,+W,1) D EN^DILL(DP,+W,1) DN ; I W[";X" D Q .S DE=$S(W[";C"!(W[";S"):DE,$A(Y)-32:" W ?0",1:"") .I $L(DE)+$L(Y)>250 D ..S %=Y,Y=DE,DE=% D PX^DIL S Y=DE .E S Y=DE_Y .I $D(DIWR(DM)) D DIWR DNW D H:DHD!$G(DIOSUBHD) I DG+DLN>IOM,DG K ^UTILITY("DIL",$J,DG) S DG='%*DM*2+2,DE=$P(W,";C",2),DG=$S(DE>0:DE-1,DE<0:IOM+DE,DG+DLN'>IOM!(W[";W"):DG,DLN>IOM:0,1:IOM-DLN),DE=" D T Q:'DN W ?"_DG D W^DIL,H:DHD!$G(DIOSUBHD) S DG=2+DLN+DG Q:$D(DNP) I $L(DE)+$L(Y)>250 S %=Y,Y=DE,DE=% D PX^DIL S Y=DE Q S Y=DE_Y Q ; H S V=$P(X,U),Z=99,I=$P(W,";""",2) I I]"" S V=$$CONVQQ^DILIBF($P(I,"""",1,$L(I,"""")-1)) HEAD Q:V="" S I=$P(V," ") I $L(I)>DLN S DLN=$L(I) ;Column width may have to be increased for a long word XD S V=$P(V," ",2,99),D=$P(V," ") I D]"",$L(I)+$L(D)20:%,1:IOM)-2 S:W[";X" $P(X,U)="" D DNW S %=$P(DE,"W ?",2)+1,Y=DLN+%-1,DIO=2,%=" S DIWL="_%_",DIWR="_$S(IOM12" ;**CCO/NI .I $D(DCL(DP_U_0)) D DE^DIL,STATS Q .D EN^DILL(DP,.001,1),DE^DIL,DN^DIL0 S DN=$E(W,$L(W)),X=$P(W,";") K DLN I DM,$A(X)=94 S W=F_W G UP^DIL COMP D D T^DIL Q .N V,DILDATE,DILCUT .S DILCUT=0 .I W[";d" S DILDATE="D" .I X?.E1" W X K Y" S DILCUT=8 .I X?.E1" W X K DIP" S DILCUT=10 .I X?.E1" D DT K DIP" S DILCUT=11,DILDATE="D" .I X?.E1" D DT K Y" S DILCUT=9,DILDATE="D" .S X=$E(X,1,$L(X)-DILCUT)_" K DIP K:DN Y" DITTO .I W[";N" S DCL=DCL+1,X=X_" S X=$$DITTO^DIO2("_DCL_",X)",DITTO(DCL)="" .S Y=" "_X,X="^^^^"_X,%=DN,DN=-3 .I W[";m" D W D Q ..S X="D "_$E("L",W'[";w"&(W'[";W"))_"^DIWP",V=$F(Y,"D ^DIWP") ..I V S Y=$E(Y,1,V-8)_X_$E(Y,V,999) ..E S Y=" S DICMX="""_X_""""_Y .I DILCUT S V=$G(DILDATE) D CLC^DILL .I 'DILCUT D W^DILL .S:'$D(DLN) DLN=9 .I W[";W" D W S Y=Y_" D ^DIWP" Q .I "+#&!*"'[% D DE^DIL,DN^DIL0 Q .S X="^C"_$G(DILDATE)_"^^^"_$E(Y,2,999),W=-1_";"_$P(W,";",2,9),DCL(DP_U_-1)=% .D DE^DIL,STATS ; W D DE^DIL,WR^DIL0 S Y=Y_" "_$E(X,5,999) Q ; WR S D1=" S Y="_$P(Y,"W ",2,999),Y="" D W^DIL0 F D1=D1," S X=Y D ^DIWP" S:$L(Y)+$L(D1)'>250 Y=Y_D1 I $F(Y,D1)-1'=$L(Y) D PX^DIL S Y=D1 D T^DIL Q ; STATS ; N TYPE I DG<10!(DG>900),'$G(DIONOSUB) S DG=10 D DE^DIL I DE'["!" S DE=" W:$X>8 !"_DE ;LEAVE FIRST 8 CHARS ON OUTPUT LINE FOR "SUBTOTAL" S TYPE=$P(X,U,2),V=DP_U_+W,I=DCL(V),D=+I I D S DSUM="" G E S (D,DCL)=DCL+1,DCL(V)=D_I S DXS=$S(I["*":"C",I["#":"S",I["&":"A",I["+":"P",1:1),V=TYPE,%=":Y"_$S(TYPE["C":"'?.""*""",Y["$E":"'?."" """,1:"]""""") I DXS S DSUM=" S"_%_" N("_D_")=N("_D_")+1",N(D)=0 G E G @DXS ; C S CP(D)="" S S Q(D)=0,L(D)=9999999999,H(D)=-L(D) I $P(TYPE,"I",2) S DLN=+$P(TYPE,"I",2) P S N(D)=0 A S (S(D),DRJ)=0 S DSUM=",C="_D_" D "_DXS_% E I TYPE["C" D .D EN^DILL(DP,+W) S Y=Y_" S Y=X"_DSUM,DXS=$S($D(^DD(DP,+W,9.02)):^(9.02),1:0) E S DXS=DSUM,Y=" S Y="_Y_DXS,I="",DXS="Y" D EN^DILL(DP,+W) UTIL K DSUM S ^UTILITY($J,"T",DG)=DLN_U_D_U_DRJ_U_$P(X,U,2)_U_I D D DN^DIL0 Q .I DXS?1E Q .S ^(DG)=^UTILITY($J,"T",DG)_U_DXS,DN=^DD(DP,+W,9.01) .I '$D(DNP) S V=$L(Y)+$L(DE) S:V<250 Y=DE_Y I V>249 S V=Y,Y=DE D PX^DIL S Y=V .S DE=X,V=DLN N X,DLN,DNP S X=DE,DLN=V,DNP="" ;'Do Not Print' hidden fields LOOP .F S DE="",V=$P(DN,";"),W=$P(V,U,2),DN=$P(DN,";",2,99) Q:V="" D:'$D(DCL(V)) ..D PX^DIL,XDUY^DIL0,EN^DILL(DP,W,1) ..I $P(X,U,2)'["C" S Y=",X=$G("_DI_C_DU_"))"_$P(",Y=",U,Y'[" S Y=")_Y ..E S Y=Y_" S Y=X" ..S (D,DCL)=DCL+1,S(D)=0,DCL(DP_U_+W)=D,Y=" S C="_D_Y_" D A" DIL11 DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;16OCT2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; DOWN ;INTO A MULTIPLE I W>0,'$D(^DD(DP,+W,0)) Q ;IN CASE FIELD IS NOW GONE FOR SOME REASON! S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI I W>0 D M G D^DIL F ; S DP=-W,X=$P(W,U,2),DD=DD+1,M(DP)=1,DIL(DM)=DIL,DIL(DM,0)=DIL0,Y=0,DIL0=DIL0+100,%=X["(" I % S (X,DI)=U_X,DIL=DIL0 E S DI=DI(DM)_","""_X_""",",DIL=DIL+101 QT S Y=$F(X,"""",Y) I Y S X=$E(X,1,Y-1)_$E(X,Y-1,999),Y=Y+1 G QT S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP S X=" "_$P($P(W,U,4,99),";") S DY="D"_(DIL-DIL0),DI=DI_DY,DIL=DIL-1 I $P(W,U,3)="" S W=+W,Y=Y_X_" S D0=D(0) I D0>0" G D^DIL S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=","_%_X I DHT=-1 D DREL^DIPZ1 G END ;WE'RE COMPILING A PRINT TEMPLATE F %=900:1 I '$D(^UTILITY($J,99,%)) S ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I D T:$X>"_DG_" Q:'DN "_Y,Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X,W=+W D D^DIL K R(DX) Q END S (F(DM-1),DX)=%,R(%)=DP(DM-1),R(%,1)=M(DP(DM-1)) Q ; ; M N %,DILEVEL,DIB1,DIBO,D,DY,X ;BUILD A "Y" STRING S DILEVEL=DIL-DIL0+1 S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";") S:+DU'=DU DU=""""_DU_"""" S DI=DI_","_DU_",",DY="D"_DILEVEL B I W'[";B" S %=":0 Q:$O("_DI_DY_"))'>0 ",DIB1="" E S DIB1="DIB"_DIL,DIBO="$O("_DI_"""B"","_DIB1,DIB1=" N "_DIB1_" S "_DIB1_"="""" F S "_DIB1_"="_DIBO_")) Q:"_DIB1_"="""" Q:'DN ",%=":0 Q:"_DIBO_","_DY_"))'>0 " S DI=DI_DY S DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP_DIB1,Y=" S "_DY_"=$O(^("_DY_"))" ; W S W=$P(W,",") I $P(^DD(DP,.01,0),U,2)["W" D:$P(^(0),U,2)["x"!($P(^(0),U,2)["X") G P ;**DI*22*152** .S D=D_",D"_(DIL+1)_"=$G(DIWF) N DIWF S DIWF=D"_(DIL+1)_"_""X""" I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP)) DPP S Y=Y_" Q:"_DY_"'>0 " I DIB1="" S Y=" X $G(DSC("_DP_")) "_Y ;DSC will switch the naked reference, so we can get thru the subentries faster! I DIB1]"" S Y=Y_" I 1 X $G(DSC("_DP_")) I " ;DSC will do an IF I DHT+1,"@"[$P(DPP(X),U,4),$P(DPP(X),U,2)=0 S DPP(X,U)="" G R:$D(DPP(X,"F")) S Y=Y_" " P S Y=D_" F "_DY_"=0"_%_Y_$S($D(DIARP(DP)):" X DIARP("_DP_") I $T",1:"") G S R S V=$P(DPP(X,"T"),U),Y=D_" F "_DY_"="_$P(DPP(X,"F"),U)_%_Y_$S(V:"!("_DY_">"_V_") ",1:" ") ;RANGE FROM AND TO SORTING BY SUB-IEN S S:($G(DDXP)'=4) %=" D:$X>"_DG,Y=Y_%_$S($D(DIWR):" NX^DIWW",1:" T Q:'DN ") ;ADD A LINE FEED UNLESS WE ARE 'EXPORTING' I DHT>0 S ^UTILITY($J,DV)="I "_DY_"'>0 S "_DY_"=0 "_$P(Y," ",2,99),DV=DV+1 ;HEADER TEMPLATE Q DIL2 DIL2 ;SFISC/GFT,XAK,TKW-PROCESS HDRS AND TRAILERS ;11:39 AM 13 Feb 2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; D T:$D(^UTILITY($J,"T")) S:DIPT $P(^DIPT(DIPT,0),U,7)=DT S:$D(DIBT) $P(^DIBT(DIBT,0),U,7)=DT S:$G(DISV) $P(^DIBT(DISV,0),U,7)=DT F X=0:0 S X=$O(R(X)) Q:X="" I X<500,$O(^UTILITY($J,99,X))>499 S DX=X S X=$S($D(DNP):"",$D(DIWR):" D ^DIWW",($G(DIAR)=4!($G(DIAR)=6)):" W "".""",1:" D T")_$S(DIWL:" K DIWF",1:"")_$S($D(CP):" D CP",1:"")_$P(" S DJ=DJ+1",U,$D(DIS)>9&(L!($D(DISTEMP))))_$S($D(DHIT):" X DHIT",1:"") I X'["D T" S X=X_" S DISTP=DISTP+1 D:'(DISTP#100) CSTP^DIO2" S:$D(DISV) X=X_" S ^DIBT("_DISV_",1,D0)=""""" S:X]"" DX=DX+1,^UTILITY($J,99,DX)=$E(X,2,999) HEAD K DIOT S DW=2,(DQI,DV)=DHD,M=M(DP(0)) I DV?.P1"[".E1"]" D HT(DV?1"-".E) G 0 I 'DV G 0:DV?1"W ".E,0:$G(DIFIXPT)=1,0:$G(IOST)?1"C".E S ^UTILITY($J,99,0)="Q" G G I $D(DIPZ) S ^UTILITY($J,1)=^UTILITY($J,1)_" X ^UTILITY($J,2) D HEAD"_^DIPT(DIPZ,"ROU")_^("LAST") G 0 S DHTDXS="",X="",$P(X,"-",$S(IOM<244:IOM,1:244))="-" D O S ^UTILITY($J,DV)="W !,"""_X_""",!!",^(1)=^(1)_O 0 S ^UTILITY($J,99,0)="I DC["","""_$S(DIPT=.01:"!($Y>"_(DIOSL-5)_")",1:"")_" X ^UTILITY($J,1)" G S DX(0)=^UTILITY($J,99,0) K ^UTILITY($J,0),DXIX,DHTDXS I $D(DPP(0)) S DJ=DPP(0,"IX"),DPQ=$O(DPP(DPP(0)))]"",DJK=0 G ^DIO S DPQ=$P(DPP(1),U,4)["-"!($D(DPP(1,"CM"))&('$D(DPP(1,"PTRIX")))) F R=2:1:DPP S:'$D(DPP(R,U)) DPQ=1 S:$P(DPP(1),U,5)[";L" DPQ=1 S DJK=1 I DPQ S %=0 F R=1:1:DPP I +$G(DPP(R,"SER"))>% S %=+DPP(R,"SER"),DJK=R I $D(DPP(DJK,"IX")) S DJ=DPP(DJK,"IX") G ^DIO S DJ=DK_DK_U_1 I $O(DPP(DJK,-1))>0!$P(DPP(DJK),U,2) S DPQ=1 S:'DPQ DPP(1,"IX")="" G ^DIO ; O S O=DHTDXS_" F DE="_DW_":1:"_DHD_" X ^UTILITY($J,DE)" Q ; T ; F DG=-1:0 S DG=$O(^UTILITY($J,"T",DG)) Q:DG="" S Z="""",I=$P(^(DG),U,6,99) I I]"" F W=2:1 Q:$P(I,Z,W,99)="" S V=$P(I,Z,W) I V]"",$D(DCL(V)) S I=$P(I,Z,1,W-1)_+DCL(V)_$P(I,Z,W+1,99),W=W-1,^(DG)=$P(^(DG),U,1,5)_U_I Q ; HT(DILTRAIL) S DLP=DX,DCC=M,DV=DW D . N DISMIN D INIT^DIP5 F %=0:0 S %=$O(^DIPT("B",$P($P(DHD,"[",2),"]",1),%)) G TT:%="" I $D(^DIPT(%,0)),$P(^(0),U,4)=""!($P(^(0),U,4)=DP) S $P(^(0),U,7)=DT Q S DHTDXS=$S($D(^("DXS")):" N DXS M DXS=^DIPT("_%_",""DXS"") ",1:"") S DHT=$G(^DIPT(%,"ROU")) I DHT[U,$D(^("IOM")),^("IOM")'>IOM S ^UTILITY($J,DV)=DHTDXS_"D "_DHT,DV=DV+1 G EHT S DX=-1,DHD="^DIPT("_%_",""F"",DHT)" F DHT=0:0 S DHT=$O(@DHD) Q:DHT'>0 S R=^(DHT) D D UNSTACK^DIL:DM . N DNP D ^DIL I $L(Y)>1 D PX^DIL EHT S DX=DLP,DHD=DV-1,M=M(DP(0)) D O S DW=DV,O=" N X,DIP"_O I DILTRAIL S M=M+1,DILIOSL=IOSL-M,^(1)="X DIOT "_^UTILITY($J,1)_" K DIOT(2)",DIOT="I DC?.N,$Y N DA S DA=D0 N D0 S D0=+$G(DIOT(""D0""),DA) X DIOT(1)"_O,DIOT(1)="S DIOT(2)=1 F W ! Q:$Y>"_DILIOSL_"!($G(DDBRZIS))",M=M+DCC Q S M=DCC,^(1)=^UTILITY($J,1)_O TT S DHD=$P(DQI,"]",2) I DHD]"" D HT(1) Q DILF DILF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;7:08 AM 25 Apr 2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q ; ; LOCK(REF) ; ; LOCK the REFerence. $T must be checked upon return **147 I '$D(DILOCKTM) S DILOCKTM=$G(^DD("DILOCKTM"),1) I $D(@REF) ;TO GET NAKED BACK LOCK @("+"_REF_":DILOCKTM") Q ; ; ; CREF(X) G ENCREF^DIQGU ; OREF(X) G ENOREF^DIQGU ; FDA(DIEFF,DIEFDAS,DIEFFLD,DIEFFLG,DIEFVAL,DIEFAR,DIEFOUT) ; G LOADX^DIEF1 ; CLEAN ; G CLEAN^DIEFU ; IENS(DIEFDA) ; G IENX^DIEFU ; DA(DAIEN,DATARG) ; G DAX^DIEFU ; DT(DIEFDT,DIEFX,DIEFY,DIEFDT0,DIOUTAR) ; G DTX^DIEFU ; VALUES(DILFILE,DILFLD,DILFDA,DILOUT) ; I $G(DILFILE)=""!($G(DILFLD)="")!($G(DILFDA)="") S DILOUT=0 Q K DILOUT N DILCNT,DILIEN S DILIEN="" D VALLOOP S DILOUT=DILCNT Q ; VALLOOP ; S DILCNT=0 F S DILIEN=$O(@DILFDA@(DILFILE,DILIEN)) Q:DILIEN="" D . I $D(@DILFDA@(DILFILE,DILIEN,DILFLD)) D . . S DILCNT=DILCNT+1 . . S DILOUT(DILCNT)=@DILFDA@(DILFILE,DILIEN,DILFLD) . . S DILOUT(DILCNT,"IENS")=DILIEN Q ; VALUE1(DILFILE,DILFLD,DILFDA) ; I $G(DILFILE)=""!($G(DILFLD)="")!($G(DILFDA)="") Q "^" N DILIEN S DILIEN=$O(@DILFDA@(DILFILE,"")) I DILIEN="" Q "^" I $D(@DILFDA@(DILFILE,DILIEN,DILFLD)) Q @DILFDA@(DILFILE,DILIEN,DILFLD) N DILCNT,DILOUT D VALLOOP I DILCNT Q DILOUT(1) Q "^" ; ROUSIZE() ; Q $G(^DD("ROU")) ; HTML(DISTRING,DIRECTN) ; ; ; entry point: use HTML to encode or decode ^ and & characters ; TOAD ; extrinsic function: return encoded or decoded value ; H1 N DILONG,DIRULE I $G(DIRECTN,1)=1 D Q:$G(DILONG) "" . S DIRULE(1,"&")="&",DIRULE(2,"^")="^" . N DIL S DIL=$L(DISTRING,"^")+$L(DISTRING,"&")-2 . I $L(DISTRING)-DIL+(DIL*5)>255 D ERR^DICU1(207,,,,DISTRING) S DILONG=1 Q E S DIRULE(1,"^")="^",DIRULE(2,"&")="&" Q $$TRANSL8(DISTRING,.DIRULE) ; TRANSL8(DISTRING,DIRULES) ; ; ; HTML: $TRANSLATE for substrings instead of characters ; TOAD ; extrinsic function: return translated value ; T1 N DIFRENCE,DIFROM,DILENGTH,DITO N DI S DI="" F S DI=$O(DIRULES(DI)) Q:DI="" D . S DIFROM=$O(DIRULES(DI,"")) Q:DISTRING'[DIFROM . S DITO=DIRULES(DI,DIFROM) . S DILENGTH=$L(DIFROM) . S DIFRENCE=$L(DITO)-DILENGTH . S DIAT=0 F D Q:'DIAT . . S DIAT=$F(DISTRING,DIFROM,DIAT) Q:'DIAT . . S $E(DISTRING,DIAT-DILENGTH,DIAT-1)=DITO . . S DIAT=DIAT+DIFRENCE Q DISTRING DILFD DILFD ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;11/18/94 11:05 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. Q ROOT(DIC,DA,CP,ERR) ; G ENROOT^DIQGU ; FLDNUM(DIEFF,DIEFFDNM) ; G FLDNUMX^DIEF1 ; VFILE(F,FLAG) ; G VFILEX^DIEFU ; VFIELD(F,FLD,FLAG) ; G VFIELDX^DIEFU ; RECALL(DIFILE,DIEN,DIUSER) ;SEA/TOAD G RECALLX^DICU ; EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIMSGA) ;SEA/TOAD G XTRNLX^DIDU ; PRD(DIFRFILE,DIFRPRD) ;DCL G EN^DIFROMSV ; DILIBF DILIBF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;15NOV2012 ; 12/1/12 3:12pm ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. HTFM(%H,%F) ;$H to FM N X,%,%Y,%M,%D S:'$D(%F) %F=0 S:%H[",0" %H=%H-1_",86400" S %=(%H>21608)+(%H>94657)+%H-.1,%Y=%\365.25+141,%=%#365.25\1 S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1 S X=%Y_"00"+%M_"00"+%D,%=$P(%H,",",2) S %=%#60/100+(%#3600\60)/100+(%\3600)/100 S:%&('%F) X=X_% Q X ; FMTH(X,%F) ;FM to $H N %Y,%H S:'$D(%F) %F=0 D H S:%F %H=+%H Q %H H ; N %,%M,%D,%T I X<1410000 S %H=0,%Y=-1 Q S %Y=$E(X,1,3),%M=$E(X,4,5),%D=$E(X,6,7) S %T=$E(X_0,9,10)*60+$E(X_"000",11,12)*60+$E(X_"00000",13,14) N DILEAP D . N Y S Y=%Y+1700 S:%M<3 Y=Y-1 . S DILEAP=(Y\4)-(Y\100)+(Y\400)-446 Q S %H=$P("^31^59^90^120^151^181^212^243^273^304^334","^",%M)+%D S %='%M!'%D,%Y=%Y-141 S %H=%H+(%Y*365)+DILEAP+% S:%T=86400 %H=%H+1,%T=0 S %H=%H_","_%T S %Y=$S(%:-1,1:%H+4#7) Q ; HTE(%H,%F) ;$H to external Q:%H'>0 %H N Y,%T,%R S %F=$G(%F) S Y=$$HTFM(%H,0) G T2 FMTE(Y,%F) ;FM to external Q:'$G(Y) $G(Y) S %F=$G(%F) Q:($G(DUZ("LANG"))>1) $$OUT^DIALOGU(Y,"FMTE",%F) N %T,%R T2 S %T="."_$E($P(Y,".",2)_"000000",1,7) D @("F"_$S(%F<1:1,%F>7:1,1:+%F\1)) Q %R DOW(X,Y) ;Day of Week N %Y,%M,%D,%H,%T D H I $G(Y) Q %Y Q $P("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",%Y+1)_"day" ; FMDIFF(X1,X2,X3) ;FM diff in two dates in days if x3=1 seconds if x3=2. N %H,%Y,X S:'$D(X3) X3=1 S X=X1 D H S X1=+%H,X1(1)=$P(%H,",",2),X=X2 D H D2 S X=(X1-%H) S:X3>1 X=X*86400+(X1(1)-$P(%H,",",2)) I X3=3 D . S %=X,X="" . I %'<86400 S X=(%\86400) . I %<0 S:(-%)'<86400 X=(%\86400) S %=-% . S:%#86400 X=X_" "_(%#86400\3600)_":"_$E(%#3600\60+100,2,3)_":"_$E(%#60+100,2,3) . Q Q X ; HDIFF(X1,X2,X3) ;$H diff in two dates, X3 same as FMDIFF. N X,%H,%T S:'$D(X3) X3=1 S X1(1)=$P(X1,",",2),X1=+X1,%H=X2 G D2 HADD(X,D,H,M,S) ;Add to $H date N %H,%T S %H=+X,%T=$P(X,",",2) D A2 Q %H_","_%T A2 S %H=%H+$G(D),%T=%T+($G(H)*3600)+($G(M)*60)+$G(S) S:%T'<86400 %H=%H+(%T\86400),%T=%T#86400 S:%T<0 %H=%H+(%T\86400)-1,%T=%T#86400 Q ; FMADD(X,D,H,M,S) ;Add to FM date N %H,%T S %H=$$FMTH(X,0),%T=$P(%H,",",2) D A2 Q $$HTFM(%H_","_%T) ; CONVQQ(X) ; CONVERT SINGLE TO DOUBLE QUOTES IN STRING X N Q,F S Q="""" F F=0:0 S F=$F(X,Q,F) Q:F=0 S X=$E(X,1,F-2)_Q_Q_$E(X,F,256),F=F+1 Q X ; CONVQ(X) ; CONVERT DOUBLE TO SINGLE QUOTES IN STRING X N Q,F,D S Q="""",D="""""" F F=0:0 S F=$F(X,D,F) Q:F=0 S X=$E(X,1,F-3)_Q_$E(X,F,256),F=F-1 Q X ; QUOTE(X) ; PUT QUOTES AROUND STRING S X=""""_$G(X)_"""" Q X ; FNO(X) ; gets a subfile's top level file number N Y S X=+X I $G(^DIC(X,0))]"" Q X F S Y=+$G(^DD(X,0,"UP")) D Q:'$D(X)!(Y'>0) . I $G(^DIC(Y,0))]"" K X Q . S X=Y . Q Q Y ; GLO(Z) ; gets the file number from a global root I '$D(@(Z_"0)"))#2 Q 0 N Y S Y=+$P($G(@(Z_"0)")),U,2) Q $$FNO(+Y) ; UP(X) ; convert string X to uppercase I $G(DUZ("LANG")) Q $$OUT^DIALOGU(X,"UC") E Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") ; ROUEXIST(X) ; Execute routine existence test G:X="" QRER I '$D(DISYS) N DISYS D OS^DII I $G(^%ZOSF("TEST"))]"" X ^("TEST") Q $T I $G(^DD("OS",DISYS,18))]"" X ^(18) Q $T QRER Q 0 ; ; F5 ; F1 S %R=$P($S(%F'["U":$T(M),1:$T(MU))," ",$S($E(Y,4,5):$E(Y,4,5)+2,1:0))_$S($E(Y,4,5):" ",1:"")_$S($E(Y,6,7):$S((%F\1'=5):$E(Y,6,7),1:+$E(Y,6,7))_$E(", ",1,1+(%F\1'=5)),1:"")_($E(Y,1,3)+1700) TM Q:%T'>0!(%F["D") I %F'["P" S %R=%R_$S(%F\1'=6:"@",1:" @ ")_$E(%T,2,3)_":"_$E(%T,4,5)_$S($E(%T,6,7)!(%F["S"):":"_$E(%T,6,7),1:$S(%F\1'=6:"",1:" ")) I %F["P" S %R=%R_" "_$S($E(%T,2,3)>12:$E(%T,2,3)-12,1:+$E(%T,2,3))_":"_$E(%T,4,5)_$S($E(%T,6,7)!(%F["S"):":"_$E(%T,6,7),1:"")_$S($E(%T,2,5)\1200=1:" pm",1:" am") Q M ;; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec MU ;; JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC F2 S %R=+$E(Y,4,5)_"/"_(+$E(Y,6,7))_"/"_$E(Y,2,3) G TM F3 S %R=+$E(Y,6,7)_"/"_(+$E(Y,4,5))_"/"_$E(Y,2,3) G TM F4 S %R=$E(Y,2,3)_"/"_$E(Y,4,5)_"/"_$E(Y,6,7) G TM F6 S %R=$S($E(Y,4,5):$E(Y,4,5)_"-",1:"")_$S($E(Y,6,7):$E(Y,6,7)_"-",1:"")_(1700+$E(Y,1,3)) G TM F7 S %R=$S($E(Y,4,5):+$E(Y,4,5)_"-",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_"-",1:"")_(1700+$E(Y,1,3)) G TM ; HKERR(DIFILE,DIIENS,DIFLD,DIHOOK) ; N DIEXT S DIEXT("FILE")=$G(DIFILE) S DIEXT("FIELD")=$G(DIFLD) S DIEXT("IENS")=$G(DIIENS) S DIEXT(1)=$G(DIHOOK) D BLD^DIALOG(120,DIHOOK,.DIEXT) Q ; FILENUM(DIGREF) ;Return file/subfile number from open global reference Q:$G(DIGREF)'?1"^".1"%"1U.UN1"(".E "" I $E(DIGREF,1,8)="^DIC(.2," Q .2 N F,X,DIFILE,S S DIFILE=+$P($G(@(DIGREF_"0)")),U,2) I DIFILE Q DIFILE S DIGREF=$$CREF^DILF(DIGREF) F X=$QL($NA(@DIGREF)):-2:0 S X(X)=$QS(DIGREF,X),X(X,0)=$$CREF^DILF($NA(@DIGREF,X)) S X=$O(X("")) I X="" Q "" I X(X)="^DIC" S F=1 E I X(X)="^DD" S F=0 E S S=$P($G(@X(X,0)@(0)),U,2),F=+S I S="" Q "" F X=X:0 S X=$O(X(X)) Q:X="" S DIFILE=$O(^DD(F,"GL",X(X),0,"")) Q:DIFILE="" S (F,DIFILE)=+$P($G(^DD(F,DIFILE,0)),U,2) Q:'F Q DIFILE ; ; DILL DILL ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;24JAN2013 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. EN(DILLFILE,DILLFLD,DXSET) ; Entry Point S:$G(DXSET) DXS=1 V ; S V=$P(X,U,2),DRJ=$F(V,"P") I V["O",$D(^DD(DILLFILE,DILLFLD,2)) S Y=Y_" "_^(2),DIO=1,D1="",DLN=30,DRJ=0 D SY G J G CLC:V["C",D:'DRJ S V=+$E(V,DRJ,99),D1=$P(X,U,3) I 'V S DRJ=0,@("V=$D(^"_D1_"0))") G D:'V S V=+$P(^(0),U,2) POINTR D Y S Y=Y_" S Y=$S(Y="""":Y,$D(^"_D1_"Y,0))#2:$P(^(0),U),1:Y)" I $D(^DD(V,.01,0)) S X=$P(X,U)_U_$P(^(0),U,2,9) G V D I V["V" D Y S Y=$P(Y," S Y=$S(Y="""":Y,$D(^")_" S C=$P(^DD("_DP_","_+W_",0),U,2) D Y^DIQ:Y S C="",""" I V["D" S DLN=$P($P(X,"%DT=""",2),"""",1),DLN=$S(DLN["S":21,DLN["T":18,1:11) D W S D1=" D DT" S:DLN>11&DRJ D1=" W ?("_DLN_"-$S(Y#1:18,1:11)+$X)"_D1 S:W[";W" Y=Y_" X ^DD(""DD"") S:Y[""@"" Y=$P(Y,""@"")_"" ""_$P(Y,""@"",2)" G SY I $P(X,"X>",2) S DLN=$L(+$P(X,"X>",2))+3,DRJ=1 G J S DLN=+$P(X,"$L(X)>",2) I 'DLN S D1=$P($P(X,U,4),";",2) I D1?1"E"1N.N1","1N.N S DLN=$P(D1,",",2)-D1+1 FJ I V'["S" S I=+$P(V,"J",2) S:V["F"&I DLN=I S:'DLN DLN=30 G J D W N D1,D2,D3 S D1=$P(X,U,3) S I D1]"",W[";W"!'$D(DNP) S D2=$P(D1,";"),D1=$P(D1,";",2,99),D3=$P(D2,":"),D2=$P(D2,":",2) S:$L(D2)>DLN&'$P(W,";L",2)&'$P(W,";R",2) DLN=$L(D2) G S SET S D1="$$SET^DIQ("_DILLFILE_","_DILLFLD_",Y)" S D1=$S(DRJ:"$J("_D1_","_DLN_")",DLN:"$E("_D1_",1,"_DLN_")",1:D1) S:W[";W" Y=Y_" S:Y]"""" Y="_D1 S:W'[";W" D1=" W:Y]"""" "_D1 SY D Y S Y=Y_$S($D(DNP):"",1:D1) K D1 Q ; Y I DXS S Y=" S Y="_Y,DXS="Y" Q Q ; W ; F I=";W",";L" I W[I S DRJ=0 S:$P(W,I,2)?1N.E DLN=+$P(W,I,2),I="" G Q I $P(X,U,2)["J",$P(X,U,2)'["F" S I=$P($P(X,U,2),"J",2),W=W_";R"_$P(I+1,U,I>0) I $P(X,U,2)'["O",I["," S W=W_";D"_+$P(I,",",2) I W[";R" S DRJ=1 S:$P(W,";R",2) DLN=+$P(W,";R",2) S I=$P($P(W,";D",2),";",1) S:I]"" DRJ=1,I=","_+I Q ; CLC ; S Y=" "_$P(X,U,5,99),DXS="X" I V["D" S Y=Y_" S Y=X" G D I V["p" S V=$P(V,"p",2),D1=$P($G(^DIC(+V,0,"GL")),U,2) I D1]"" S Y=Y_" S Y=X",DXS="Y" G POINTR ;computed pointer I V?.E1"J"1N.E,W'[";X",W'[";R",V'["," S W=W_";L"_+$P(V,"J",2) J D W Q:V["m"!$D(DNP) I '$D(DLN) S Y=Y_" W X" Q I 'DLN S DLN=$S(V["B":1,W[";L0":0,1:8) S D2="" I 'DRJ S V="E(",D3="1,"_DLN E S V="J(",D3=DLN_I I I]"" D Y S D2=":Y]""""" I DXS="X" S D2=":X'?.""*""" S Y=$S(DXS:",$"_V_Y,1:Y_" W"_D2_" $"_V_DXS)_","_D3_")" I $P(X,U,2)["C",$L(Y)<225 S Y=Y_" K Y("_DP_","_+W_")" I $G(DDXP)=4 S Y=$$DJTOPY^DDXP4(Y) K K D2,D3 Q DIM DIM ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Main ;22APR2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; S %X=X,%END="",%ERR=0,%LAST="" G ER:X'?.ANP ; GC ; get next command on line (*) G ER:%ERR,LAST:";"[$E(%X) F Q:$E(%X)'=" " S %X=$E(%X,2,999) G ER:"BCDEFGHIKLMNOQRSUWXZ"'[$E(%X) S %LAST=%X D SEP G ER:%ERR S %COM=$P(%ARG,":") ; command word I $L(%COM)>1 D G ER:%ERR . I $T(COMMAND)'[(";"_%COM_";"),%COM'?1"Z"1.U S %ERR=1 . E S %COM=$E(%COM) S %=$P(%ARG,":",2,99),%COM(1)=% I %ARG[":",%="" G ER ; command postcond I %]"" D ^DIM1 G ER:%ERR D SEP G ER:%ERR I %ARG="","CDGMORSUWXZ"[%COM G ER ; argument list S %END=%ARG G @%COM ; B G GC:%ARG=""&(%COM(1)=""),BK^DIM4 C G CL^DIM4 D G DG^DIM3 E G GC:%ARG=""&(%COM(1)=""),ER F G ER:%COM(1)]""!(";"[$E(%X)),GC:%ARG="",FR^DIM3 ;GFT-DON'T END WITH 'F' G G DG^DIM3 H G GC:%ARG=""&(%COM(1)="")&(%X]""),HN^DIM3:%ARG]"",ER Q I G ER:%COM(1)]"",IX^DIM4 K G GC:%ARG=""&(%COM(1)="")&(%X]""),KL^DIM3:%ARG]"",ER L G LK^DIM3 M G S N G ER:%ARG=""&(%X=""),K O G OP^DIM3 Q G ER:%ARG]"",GC:%ARG=""&(%COM(1)=""),BK^DIM4 R G RD^DIM4 S G ST^DIM4 U G OP^DIM3 W G WR^DIM4 X G IX^DIM4 Z G GC ; SEP ; remove first " "-piece of %X into %ARG: parse commands (GC) F %I=1:1 S %C=$E(%X,%I) D:%C="""" Q:" "[%C . N %OUT S %OUT=0 F D Q:%OUT!%ERR . . S %I=%I+1,%C=$E(%X,%I) I %C="" S %ERR=1 Q . . Q:%C'="""" S %I=%I+1,%C=$E(%X,%I) Q:%C="""" S %OUT=1 S %ARG=$E(%X,1,%I-1),%I=%I+1,%X=$E(%X,%I,999) Q ; COMMAND ;;BREAK;CLOSE;DO;ELSE;FOR;GOTO;HALT;HANG;IF;KILL;LOCK;MERGE;NEW;OPEN;QUIT;READ;SET;USE;WRITE;XECUTE; ; LAST ; check to ensure no trailing "," or " " at end of command (GC) S %L=$L(%LAST),$E(%LAST,%L+1-$L(%X),%L)="" I $E(%END,$L(%END))="," G ER I $E(%X)="",$E(%LAST,%L)=" " G ER G END ; ER K X END K %,%A,%A1,%A2,%ARG,%C1,%C,%COM,%END,%ERR,%H,%I,%L,%LAST,%P,%X,%Z Q DIM1 DIM1 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;13DEC2009 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; Q:%ERR N %A,%A1 S (%I,%N,%ERR,%(-1,2),%(-1,3))=0 ; GG ; expr, expratom, expritem, subscript, parameter (called everywhere) D %INC G:%C="" FINISH^DIM2 G E:%C=";"!($A(%C)>95)!($A(%C)<33) G QUOTE:%C="""",FUNC:%C="$",SUB^DIM2:%C="(",UP^DIM2:%C=")" G AR^DIM2:%C=",",SEL^DIM2:%C=":",GLO^DIM2:%C="^" EXP I %C="E",$E(%,%I-1)?1N D G E:%ERR S %I=%I-1 G GG . S %L1=$E(%,%I+1) . I %L1'?1(1N,1"+",1"-") S %ERR=1 Q . N %OUT S %OUT=0 F %I=%I+2:1 D Q:%ERR!%OUT . . S %C=$E(%,%I) . . I "<>=!&'[]+-*/\#_?,:)"[%C S %OUT=1 Q . . I %C'?1N S %ERR=1 Q I %C?1(1U,1"%") D VAR^DIM2 G E:%ERR,GG:%C="" G PAT^DIM2:%C="?",BINOP^DIM2:"=[]<>&!"[%C,MTHOP^DIM2:"/\*#_"[%C G UNOP^DIM2:"'+-"[%C,IND^DIM2:%C="@" PERIOD I %C="." D G E:%ERR . I $P($G(%(%N-1,0)),"^")="P" D Q . . N %C S %C=$E(%,%I+1) I %C?1N Q ; decimal pass by value . . I %C'="@",%C'?1U,%C'="%" S %ERR=1 ; bad pass by reference . D %INC N %L1,%P S %L1=$E(%,%I-2),%P="':=+-\/<>[](,*&!_#" . I %L1?1N,%C?1N Q ; 4.2 . I %P[%L1,%C?1N Q ; +.2 . S %ERR=1 ; illegal period I %C?1N,$E(%,%I+1)]"" G E:$E(%,%I+1)'?1(1NP,1"E") GG1 ; I %C]"","$(),:"""[%C S %I=%I-1 G GG ; QUOTE ; strlit (GG) F %J=0:0 D %INC Q:%C=""!(%C="""") G E:%C=""!("[]()><\/+-=&!_#*,;:'"""'[$E(%,%I+1)) D:$D(%(%N-1,"F")) FN:%(%N-1,"F")["FN" G E:%ERR,GG ; FUNC ; intrinsics & extrinsics, mainly intrinsic functions (GG) D %INC G EXT:%C="$",E:%C'?1U,SPV:$E(%,%I,999)'?.U1"(".E,FUNC1:%C="Z"!($E(%,%I+1)="(") S %T=$E(%,%I,$F(%,"(",%I)-2) I %T="ST"!(%T="STACK") G E ; SAC F %F1="FNUMBER^2;3","TRANSLATE^2;3","NAME^1;2","QLENGTH^1;1","QSUBSCRIPT^2;2","REVERSE^1;1" G FUNC2:$E(%F1,1,2)=%T,FUNC2:$P(%F1,"^")=%T FNC ;;,ASCII^1;2,CHAR^1;999,DATA^1;1,EXTRACT^1;3,FIND^2;3,GET^1;2,JUSTIFY^2;3,LENGTH^1;2,ORDER^1;2,PIECE^2;4,QUERY^1;1,RANDOM^1;1,SELECT^1;999,TEXT^1;1,VIEW^1;999,ZFUNC^1;999 G E:$T(FNC)'[(","_%T_"^") FUNC1 S %F1=$P($T(FNC),",",$F("ACDEFGJLOPQRSTVZ",%C)) G E:%F1="" FUNC2 S %I=$F(%,"(",%I)-1,%(%N,0)="1^"_$P(%F1,"^",2),%(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%(%N,"F")=%F1,%N=%N+1 S:$E(%F1)="S" %(%N-1,2)=1 I ",DATA,NAME,ORDER,QUERY,GET,"[(","_$P(%F1,"^")_",") G DATA^DIM2 I $E(%F1)="T",$E(%F1,2)'="R" D I %ERR G ERR^DIM2 . S %A=%I,%I=$F(%,")",%A)-1,%N=%N-1,%A=$P($E(%,%A,%I-1),"(",2,99) . I %A?1"+"1N.E S %A=$E(%A,2,999) . N %,%I,%N S %=%A D LABEL^DIM3(1) G GG ; SPV ; intrinsic special variables (FUNC) I $E(%,%I+1)?1U S %I=%I+1,%C=%C_$E(%,%I) G SPV I ",D,EC,ES,ET,K,P,Q,ST,SY,TL,TR,"[(","_%C_",") G E ; SAC I "HIJSTXYZ"[%C&(%C?1U)!(%C?1"Z".U) G GG I "[],)><=_&#!'+-*\/?"'[$E(%,%I+1) G E I ",DEVICE,ECODE,ESTACK,ETRAP,KEY,PRINCIPAL,QUIT,STACK,SYSTEM,TLEVEL,TRESTART,"[(","_%C_",") G E ; SAC I ",HOROLOG,IO,JOB,STORAGE,TEST,"[(","_%C_",") G GG E G ERR^DIM2 ; %INC S %I=%I+1,%C=$E(%,%I) Q ; FN ; literal string argument 2 of $FNUMBER (QUOTE) Q:%(%N-1,1)'=1 F %FZ=%I-1:-1 S %FN=$E(%,%FZ) Q:%FN="""" S %FN=$TR($E(%,%FZ+1,%I-1),"pt","PT") F %FZ=1:1 Q:$E(%FN,%FZ)="" I "+-,TP"'[$E(%FN,%FZ) S %ERR=1 Q Q:%ERR I %FN["P" F %FZ=1:1 Q:$E(%FN,%FZ)="" I "+-T"[$E(%FN,%FZ) S %ERR=1 Q Q ; EXT ; extrinsic functions and variables (FUNC) D %INC F %I=%I+1:1 S %C1=$E(%,%I) Q:%C1?1PC&("^%"'[%C1)!(%C1="") S %C=%C_%C1 G:%C="" E G:%C?.E1"^" E G:%C["^^" E S %C1=$P(%C,"^",2) I %C1]"",%C1'?1U.15AN,%C1'?1"%".15AN G E S %C=$P(%C,"^") I %C]"",%C'?1U.7AN,%C'?1"%".7AN,%C'?1.8N G E I $E(%,%I)="(",$E(%,%I+1)'=")" S %(%N,0)="P^",(%(%N,1),%(%N,2),%(%N,3))=0,%N=%N+1 G GG S %I=%I+$S($E(%,%I,%I+1)="()":1,1:-1) G GG:"[],)><=_&#!'+-*/\?:"[$E(%,%I+1),E DIM2 DIM2 ;SFISC/XAK,GFT,TOAD-FileMan: M Syntax Checker, Exprs ;20NOV2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;12277;4186487;4104; ; SUB ; "(": open paren situations (GG^DIM1) F %J=%I-1:-1 S %C1=$E(%,%J) Q:%C1'?1(1UN,1"%") S %C1=$E(%,%J+1,%I-1) I %C1]"",%C1'?1(1U,1"%").UN G ERR ;I %C1]"",%[("."_%C1) G ERR ;DID NOT ALLOW "W A(6)-$$X(.A)" S %(%N,0)=$S(%C1]""!($E(%,%J)="^"):"V^",$E(%,%J)="@":"@^",1:"0^") S %(%N,1)=0,%(%N,2)=0,%(%N,3)=0,%N=%N+1 G 1 ; UP ; ")": close paren situations (GG^DIM1) I %N=0 G ERR I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR I $E(%,%I+1)]"","<>_[]:/\?'+-=!&#*),"""'[$E(%,%I+1) G ERR S %N=%N-1,%(%N,1)=%(%N,1)+1,%F=$P(%(%N,0),"^") I %F D G ERR:%ERR . S %F=$P(%(%N,0),"^",2),%F1=%(%N,1) . I %F1<+%F S %ERR=1 Q ; not enough commas for this function . I %F1>$P(%F,";",2) S %ERR=1 Q ; too many commas for this function . I %(%N,2),'%(%N,3) S %ERR=1 ; we're in $S and haven't yet hit a : K %(%N+1) I '%F,%F'["V",%F'["@",%F'["P",%(%N,1)>1 G ERR G 1 ; AR ; ",": comma situations -- "P" below means "parameters" (GG^DIM1) I %N<1 G ERR I "(,"[$E(%,%I-1),$P($G(%(%N-1,0)),"^")'["P" G ERR I '%(%N-1,3),%(%N-1,2) G ERR I "@("[$E(%,1,2) G ERR S %(%N-1,1)=%(%N-1,1)+1,%(%N-1,3)=0 G 1 ; SEL ; ":": $SELECT delimiter (GG^DIM1) S %(%N-1,3)=%(%N-1,3)+1 G ERR:'%(%N-1,2)!(%(%N-1,3)>1),1 ; GLO ; "^": global reference (GG^DIM1) D %INC G ERR:$E(%,%I,999)'?1U.UN.P.E&("%("'[%C) G ERR:"=+-\/<>(,#!&*':@[]_"'[$E(%,%I-2) S %I=%I-1 G 1 ; PAT ; "?": pattern match (GG^DIM1) G ERR:%I=1,1:$E(%,%I+1)="@" D %INC,PATTERN G ERR:%ERR S %I=%I-1 G 1 ; PATTERN F D PATATOM Q:%C'?1N&(%C'=".")!%ERR Q PATATOM D REPCOUNT Q:%ERR I %C="""" D STRLIT,%INC:'%ERR Q I %C="(" D ALTRN8 Q D PATCODE Q REPCOUNT ; I %C'?1N,%C'="." S %ERR=1 Q N FROM S FROM=+$E(%,%I,999) I %C?1N D INTLIT Q:%ERR I %C="." D %INC Q:%C'?1N I +$E(%,%I,999)+-'\/()%@#&!*=_][," S %Z2="""($+-=&!^%.@'" I %C="'" S %Z2=%Z2_"<>?[]" G OPCHK ; IND ; "@": indirection (GG^DIM1) I $E(%COM)="F" G ERR S %Z1="^?@(%+-=\/#*!&'_<>[]:,.",%Z2="""(+^-'$@%" G OPCHK ; OPCHK ; ensure that the characters before and after the operator are OK S %L1=$E(%,%I-1),%L2=$E(%,%I+1) I %L1="'","[]&!<>="[%C S %L1=$E(%,%I-2) I %L1="","+-'@"'[%C G ERR ; binary: require before I %L1'?1UN,%Z1'[%L1 G ERR ; all: screen before F %F="*","]" I %C=%F,%L2=%F S %I=%I+1,%L2=$E(%,%I+1) Q I %L2="" G ERR ; all: require after I %L2'?1UN,%Z2'[%L2 G ERR ; all: screen after I %C="'","!&[]?=<>"'[%L2,%L1?1(1")",1UN) G ERR ;GFT: unary "'" may precede an operator, can't follow a variable name G 1 ; 1 ; common exit point for all of ^DIM2 G GG^DIM1 ; DATA ; glvn arguments of $D,$G,$NA,$O, & $Q functions (FUNC^DIM1) D %INC G ERR:%C="",ERR:%C=")",DATA:"^@"[%C D VAR G ERR:"@(,)"'[%C!%ERR,GG1^DIM1 ; VAR ; variables encountered while parsing exprs (DATA, GG^DIM1) N %START S %START=%I-1 I $E(%,%START)="^" S %START=%START-1 I %C="%" D %INC N OUT S OUT=0 F %J=%I:1 S %C=$E(%,%J) D Q:OUT . I ",<>?/\[]+-=_()*&#!':"[%C S OUT=1 Q . I %C="@",$E(%,%J+1)="(",$E(%,%START)="@" S OUT=1 Q . I %C'?1UN S %ERR=1 . I %C="^",$D(%(%N-1,"F")),%(%N-1,"F")["TEXT" S %ERR=0,OUT=1 Q:%ERR I %C="@" S %I=%J Q S %F=$E(%,%I,%J-1) I %F="^",$E(%,%J)'="(" S %ERR=1 I %F]"",%F'?1U.UN,$E(%,%I-1,%J-1)'?1"%".UN S %ERR=1 S %I=%J Q ; %INC S %I=%I+1,%C=$E(%,%I) Q ; ERR S %ERR=1,%N=0 FINISH G ERR:%N'=0 K %C,%,%F,%F1,%I,%J,%L1,%L2,%N,%T,%Z1,%Z2,%FN,%FZ Q Q DIM3 DIM3 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;25MAR2010 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; ; DG ; DO and GET (D^DIM and G^DIM) G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR S %L=":" D PARS1 G ER:%ERR I %C=%L G ER:%A1="" S %=%A1 D ^DIM1 I %A["@^" S %=%A D ^DIM1 G DG I %A["(",$E(%A)'="@",$E($P(%A,"^",2))'="@" D G ER:%ERR . I %COM'="D" S %ERR=1 Q . S %=%A . I %'?.E1"(".E1")" S %ERR=1 Q . S %C=$P(%,"("),%C1=$P(%C,"^",2,999),%I=$F(%,"(")-1 . I %C=""!(%C?.E1"^") S %ERR=1 Q . I %C1]"",%C1'?1U.15AN,%C1'?1"%".15AN S %ERR=1 Q . S %C=$P(%C,"^") I %C]"",%C'?1U.15AN,%C'?1"%".15AN,%C'?1.15N S %ERR=1 Q . Q:$E(%,%I,%I+1)="()" . S (%(-1,2),%(-1,3))=0,%N=1,%(0,0)="P^",(%(0,1),%(0,2),%(0,3))=0 . D GG^DIM1 E D LABEL(0) G DG ; LABEL(OFFSET) ; labelref, entryref, and $TEXT argument (DG and TEXT^DIM1) S %L="^" D PARS1 Q:%ERR I %C=%L S:%A1=""!($E(%A1)="^") %ERR=1 S %=%A1 D VV,^DIM1 Q:%ERR S %=%A D VV:%'=+%&'OFFSET,^DIM1 Q ; KL ; KILL, LOCK, and NEW (K^DIM and LK) D PARS G ER:%ERR I %A="",%C="," G ER I %A?1"^"1UP.UN,%COM'="L" G ER I %A?1"(".E1")" D G KL . S %ARG("E")=$L(%ARG) . S %A=$E(%A,2,$L(%A)-1) S %ARG=%A_$S(%ARG]"":","_%ARG,1:"") S %=%A I %COM="L","+-"[$E(%A) S $E(%A)="" I %COM="N",'$$LNAME(%) G ER I %COM="K",$D(%ARG("E")),'$$LNAME(%) G ER I $D(%ARG("E")),$L(%ARG)'>%ARG("E") K %ARG("E") D VV,^DIM1 G GC^DIM:%ARG=""!%ERR G KL ; LK ; LOCK (L^DIM) S %A=%ARG,%L=":" S:"+-"[$E(%A) %A=$E(%A,2,999) D PARS1 I %C=%L G ER:%A1="" S %=%A1 D ^DIM1 S %ARG=%A G GC^DIM:%A="",KL ; HN ; HANG (H^DIM) S %=%ARG D ^DIM1 G GC^DIM ; OP ; OPEN and USE (O^DIM and U^DIM) G GC^DIM:%ARG=""!%ERR D PARS G ER:%ERR!(%C=","&(%A="")) G US:%COM="U" S %L=":" D PARS1 S %A2=%A,%A=%A1 S:%C=%L&(%A="") %ERR=1 D PARS1 G ER:%ERR!(%C=%L&(%A1="")) F %L="%A1","%A2" S %=@%L D ^DIM1 G OP:%ERR G OP US S %L=":" D PARS1 G ER:%C=%L&(%A1="") S %=%A D ^DIM1 S %A=%A1 D PARS1 G ER:%C]"",OP ; FR ; FOR (F^DIM) S %L="=",%A=%ARG D PARS1 G ER:%ERR!(%A1="")!(%A="") S %ARG=%A1 S %=%A G ER:%A?1"^".E D VV,^DIM1 G ER:%ERR FR1 G GC^DIM:%ARG=""!%ERR D PARS S %L=":" F %A=%A,%A1 D PARS1 G ER:%ERR!(%A=""&(%C=%L)) S %=%A D ^DIM1 I %A1]"" S %=%A1 D ^DIM1 G FR1 ; PARS S (%A,%C)="" Q:%ERR S (%ERR,%I)=0 INC D %INC D QT:%C="""",PARAN:%C="(" Q:%ERR G OUT:","[%C,INC QT D %INC Q:%C="""" G QT:%C]"" S %ERR=1 Q PARAN S %P=1 F %J=0:0 D %INC D QT:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P I %C="" S %ERR=1 Q Q OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q %INC S %I=%I+1,%C=$E(%ARG,%I) Q ; PARS1 S (%A1,%C)="" Q:%ERR S (%ERR,%I)=0 INCR D %INC1 D QT1:%C="""",PARAN1:%C="(" Q:%ERR=1 G OUT1:%L[%C,INCR OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q QT1 D %INC1 Q:%C="""" G QT1:%C]"" S %ERR=1 Q PARAN1 S %P=1 F %J=0:0 D %INC1 D QT1:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P I %C="" S %ERR=1 Q Q %INC1 S %I=%I+1,%C=$E(%A,%I) Q ; VV ; variable, label, or routine name (LABEL, KL, and FR) I '%ERR,%]"",%'["@",%'?1U.15UN,%'?1U.15UN1"(".E1")",%'?1"%".15UN1"(".E1")",%'?1"%".15UN,%'?1"^"1U.15UN1"(".E1")",%'?1"^%".15UN1"(".E1")",%'?1"^(".E1")",%'?1"^"1U.15UN S %ERR=1 S:%["?@" %ERR=1 Q ; LNAME(%) ; lname (KL) I %?1(1A,1"%").7UN Q 1 I %?1"@".E Q 1 Q 0 ; ER G ER^DIM DIM4 DIM4 ;SFISC/JFW,GFT,TOAD-FileMan: M Syntax Checker, Commands ;5/6/97 09:10 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ;12279;3292224;3060; ; BK ; BREAK and QUIT (B^DIM and Q^DIM) I %ARG]"" S %=%ARG D ^DIM1 G ER:%ERR G GC^DIM ; CL ; CLOSE (C^DIM) G ER:%ERR I %ARG]"" F %Z=0:0 D S S %=%A D ^DIM1 G:%ARG=""!%ERR GC^DIM G GC^DIM ; IX ; IF and XECUTE (I^DIM and X^DIM) G GC^DIM:%ARG=""!%ERR D S S %L=":" D S1 I %C=%L S %=%A1 D ^DIM1 G ER:%A1=""!%ERR S %=%A D ^DIM1 G IX ; ST ; SET and MERGE (S^DIM and M^DIM) G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%A=""&(%C=",")) I %A?1"@".E S %=%A D ^DIM1 G ST S %L="=" D S1 G ER:(%A="")!(%A1="") S %=%A1 G ER:%COM="M"&'$$GLVN(%) D ^DIM1 G ER:%ERR I %A?1"(".E1")" S %A=$E(%A,2,$L(%A)-1) G ER:%COM="M",STM D VV G ST ; STM ; SET (x,y)=... (ST) G ST:%ERR!(%A=""),ER:%A?1",".E S %L="," D S1 G ER:%ERR!(%C=%L&(%A1="")) D VV S %A=%A1 G STM ; RD ; READ (R^DIM) G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%C=","&(%A="")) I "!#?"[$E(%A,1) S %I=0 D FRM G RD I %A?1"""".E G ER:$P(%A,"""",3)'="" S %=%A D ^DIM1 G RD I %A?1"*".E S %A=$E(%A,2,999) I $E(%A)="^","^TMP^XTMP^"'[$P(%A,"(") G ER F %L=":","#" D G ER:%ERR . D S1 Q:%ERR . I %A="" S %ERR=1 Q . I %A1="",%C=%L S %ERR=1 Q . S %=%A1 D ^DIM1 D VV G ER:%ERR,RD ; WR ; WRITE (W^DIM) G GC^DIM:%ARG=""!%ERR D S G ER:%ERR!(%A=""&(%C=",")) I "!#?/"[$E(%A) S %I=0 D FRM G WR S:%A?1"*".E %A=$E(%A,2,999) S %=%A D ^DIM1 G WR ; FRM ; format (RD and WR) S %I=%I+1,%C=$E(%A,%I) Q:%C="" G FRM:"!#"[%C S %=$E(%A,%I+1,999) I %]"",%C="?" D ^DIM1 Q I %C="/",%COM="W" S:%?1"?".E %="A"_$E(%,2,999) I %?1AN.E D ^DIM1 Q S %ERR=1 Q ; S ; split at first comma: end of first argument (*) S (%A,%C)="" Q:%ERR S (%ERR,%I)=0 INC D %INC D QT:%C="""",P:%C="(" Q:%ERR G OUT:","[%C,INC QT D %INC Q:%C="""" G QT:%C]"" S %ERR=1 Q P S %P=1 F %J=0:0 D %INC D QT:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P I %C="" S %ERR=1 Q Q OUT S %A=$E(%ARG,1,%I-1),%ARG=$E(%ARG,%I+1,999) Q %INC S %I=%I+1,%C=$E(%ARG,%I) Q ; S1 ; split at first instance of %L (*) S (%A1,%C)="" Q:%ERR S (%ERR,%I)=0 INCR D %INC1 D QT1:%C="""",P1:%C="(" Q:%ERR G OUT1:%L[%C,INCR OUT1 S %A1=$E(%A,%I+1,999),%A=$E(%A,1,%I-1) Q QT1 D %INC1 Q:%C="""" G QT1:%C]"" S %ERR=1 Q P1 S %P=1 F %J=0:0 D %INC1 D QT1:%C="""" S %P=%P+$S(%C="(":1,%C=")":-1,1:0) Q:'%P I %C="" S %ERR=1 Q Q %INC1 S %I=%I+1,%C=$E(%A,%I) Q ; VV ; glvn or setleft (ST, STM, and RD) S %=%A Q:%ERR I %]"",$$GLVN(%)=0 D .I %COM'="S" S %ERR=1 Q .I %["(",(%?1"$P".E)!(%?1"$E".E) Q .I %="$X"!(%="$Y") Q .I %="$D"!(%="$DEVICE")!(%="$K")!(%="$KEY")!(%="$EC")!(%="$ECODE")!(%="$ET")!(%="$ETRAP") S %ERR=1 Q ; SAC .S %ERR=1 D ^DIM1:'%ERR Q ; GLVN(%) ; glvn (not counting subscript syntax) I %?.1"^"1U.UN Q 1 I %?.1"^"1U.UN1"("1.E1")" Q 1 I %?.1"^"1"%".UN Q 1 I %?.1"^"1"%".UN1"("1.E1")" Q 1 I %?1"^("1.E1")" Q 1 I %?1"^$"1.U1"("1.E1")" Q 1 I %?1"@"1.E Q 1 Q 0 ; ER G ER^DIM DINIT DINIT ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ; 14NOV2012 V ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. D KL^DINIT6 N ; D VERSION N DIFROM S DIFROM=VERSION W !!,X D DT^DICRW I $G(^DD("VERSION"))]"",^DD("VERSION")_"z"]](VERSION_"z") D . W $C(7),!!,"*** WARNING!! VA FileMan version "_^DD("VERSION")_" is currently loaded on this system.",!,"This Initialization will bring in VA FileMan version "_VERSION_", an earlier version!!",!! S Y=$G(^DD("OS")) I Y,"1,2,3,4,5,6,10,11,12,13,15,"[(Y_",") W $C(7),!!,"Your defined operating system entry "_$P($G(^DD("OS",Y,0)),U)_" does not support the",!,"1995 M Standards.",!!,"You may not initialize VA FileMan V"_VERSION G KL^DINIT6 DO W !!,"Initialize VA FileMan now? NO//" R Y:60 G:Y["^"!("Nn"[$E(Y))!('$T) KL^DINIT6 I "Yy"'[$E(Y) W !,"Answer YES to begin Initializing VA FileMan" G DO NA W !!,"SITE NAME: " I $D(^DD("SITE")) W ^("SITE"),"// " R X:60 G KL^DINIT6:X="^"!'$T I X="",$D(^("SITE"))#2 S X=^("SITE") I X'?1AN.ANP W " ENTER THE NAME OF THIS INSTALLATION SITE",!! G NA S %X=X NO W !!,"SITE NUMBER: " W:$D(^DD("SITE",1)) ^(1),"// " R X:60 G KL^DINIT6:X="^"!'$T I $D(^(1)),X="" S X=^(1) S:X>0 ^DD("SITE")=%X,^DD("SITE",1)=X I X'>0 W " ENTER A NUMBER, CORRESPONDING TO YOUR INSTITUTION" G NO ;***** REMOVE AFTER V21 INIT ***** ;D ;. N DIREC F DIREC=0:0 S DIREC=$O(^DI(.84,DIREC)) Q:'DIREC Q:DIREC>10000 K ^DI(.84,DIREC,5) ;. Q ;********************************* K ^DD(0) D ^DINIT0,^DINIT11B D OSETC W ! S Y=1 D OS G KL^DINIT6:Y<0 W !!,"Now loading other FileMan files--please wait." G GO ; ; OS W ! S DIC="^DD(""OS"",",DIC(0)="IAQE",DIC("A")="TYPE OF MUMPS SYSTEM YOU ARE USING: " I $D(^DD("OS"))#2 S (DITZS,DIC("B"))=^("OS") S:DITZS=7 (DITZS,DIC("B"))=18 E S (DITZS,^DD("OS"))=100 D ^DIC K DIC G Q:Y<0 S (DITZS,^DD("OS"))=+Y I $D(^%ZTSK),$D(^%ZOSF("OS"))#2,$D(^("MGR"))#2 D . S ZTRTN="OS^%RCR",ZTUCI=^%ZOSF("MGR"),ZTDTH=$H,ZTIO="",ZTSAVE("DITZS")="" . S ZTDESC="Set Operating System" D ^%ZTLOAD Q Q K DITZS,ZTSK Q VERSION ; S VERSION=$P($T(V),";",3),X="VA FileMan V."_VERSION Q ; GO S I=$C(126),DIT=$P($H,",",2) S $P(^DIBT(0),U,1,2)="TEMPLATE^.4I",$P(^DIE(0),U,1,2)="TEMPLATE^.4I",$P(^DIPT(0),U,1,2)="TEMPLATE^.4I",^(.01,0)="CAPTIONED^",^("F",1)="S DIC=DCC,DA=D0 D EN^DIQ" S ^DIPT(.02,0)="FILE SECURITY CODES^^^1",^("F",1)=".01;L20"_I_"0;R13"_I_31_I_33_I_35_I_34_I_32_I_21_I_20 S ^DIA(0)="AUDIT^1.1I" K ^DD(.4),^(.41),^("^"),^(.403),^(.4031),^(.40315),^(.403115),^(.4032),^(.404),^(.40415),^(.4044),^(.404421),^(1.2),^(1,"B") K ^DIC(.403),^(.404),^(1.2) K ^DD(.44),^(.441),^(.4411),^(.447),^(.448),^(.411),^(.42),^(.81),^DIC(.44),^(.81) F I=.2,.4,.401,.402,.5,.6,.83,1.1,1.11,1.12,1.13 K ^DIC(I,"%D") K ^DIC(.46),^DD(.46),^(.461),^(.463) K ^DIC(.11),^(.31) F I=.11,.111,.112,.114,.31,.312 K ^DD(I) F I=1.521,1.52101,1.5211,1.5212,1.5213,1.5214,1.5215,1.5216,1.5217,1.5218,1.5219,1.52191,1.52192 K ^DIC(I),^DD(I) G ^DINIT0F0 ; OSETC ;BRING IN MUMPS OS, DIALOG & LANGUAGE DD AND DATA FOR FILEMAN N DN,R,D,DDF,DDT,DTO,DFR,DFN,DTN,DMRG,I,Z,D0 W !!,"Now loading MUMPS Operating System File" D ^DINIT21,OSDD^DINIT24 S ^DIC(.7,0)="MUMPS OPERATING SYSTEM^.7",^(0,"GL")="^DD(""OS""," D A^DINIT3 S ^DIC(.7,"%D",0)="^^5^5^2940908^" S ^DIC(.7,"%D",1,0)="This file stores operating system-specific code. Since the code to invoke" S ^DIC(.7,"%D",2,0)="some operating system utilities that FileMan uses varies among operating" S ^DIC(.7,"%D",3,0)="systems, code to perform these utilities is stored in and executed from" S ^DIC(.7,"%D",4,0)="this file. During the FileMan INIT process an operating system is" S ^DIC(.7,"%D",5,0)="selected so that FileMan knows which entry to use from this file." K ^DD("OS","B"),DA,DIK S DA(1)=.7 S DIK="^DD(.7," D X^DINIT3 K DA,DIK S DIK="^DD(""OS""," D X^DINIT3 D . N I,DA,DIK F I=1,2,3,4,5,6,7,10,11,12,13,14,15 S DA=I,DIK="^DD(""OS""," D ^DIK . Q ; K ^UTILITY(U,$J),^UTILITY("DIK",$J),^UTILITY("KX",$J) W !!,"Now loading DIALOG and LANGUAGE Files" K:$G(^DIC(.85,"%MSC"))'=3121114.111954 ^DI(.85) ; VEN/SMH If lang file dd isn't the latest one, kill data off. K ^DIC(.85),^DD(.85),^DD(.8501),^DD(.8502) ; VEN/SMH - Kill the language file old DD, DIC and data. (22.2) S DN="^DINIT" F R=1:1:39 D @(DN_$$B36(R)) W "." EGP F R=901:1:911 D @(DN_R) ;**CCO/NI BRING IN EXTRA DIALOG ENTRIES S $P(^DIC(.84,0),U,1,2)="DIALOG^.84",$P(^DI(.84,0),U,1,2)="DIALOG^.84I" I $D(^DIC(.84,0,"GL")) D A1^DINIT3 S $P(^DIC(.85,0),U,1,2)="LANGUAGE^.85",$P(^DI(.85,0),U,1,2)="LANGUAGE^.85I" I $D(^DIC(.85,0,"GL")) D A1^DINIT3 F I=.84,.841,.842,.844,.845,.847,.8471,.85,.8501,.8502 D XX^DINIT3 ; VEN/SMH - added .8501 and .8502 for new lang file ; Keys and new style indexes installer ; new in FM V22.2 N DIFRSA S DIFRSA=$NA(^UTILITY("KX",$J)) ; Tran global for Keys and Indexes N DIFRFILE S DIFRFILE=0 ; Loop through files F S DIFRFILE=$O(@DIFRSA@("IX",DIFRFILE)) Q:'DIFRFILE D . K ^TMP("DIFROMS2",$J,"TRIG") . N DIFRD S DIFRD=0 . F S DIFRD=$O(@DIFRSA@("IX",DIFRFILE,DIFRD)) Q:'DIFRD D DDIXIN^DIFROMSX(DIFRFILE,DIFRD,DIFRSA) ; install New Style Indexes . K ^TMP("DIFROMS2",$J,"TRIG") . S DIFRD=0 . F S DIFRD=$O(@DIFRSA@("KEY",DIFRFILE,DIFRD)) Q:'DIFRD D DDKEYIN^DIFROMSY(DIFRFILE,DIFRD,DIFRSA) ; install keys K @DIFRSA ; kill off tran global ; D DATA Q ; ; VEN/SMH - added kill D1 since that causes a problem with Transfer/Merge ; for keyed fields if it leaks from the symbol table. DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0 S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=0 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 K D1 Q:'$D(^(D0,0)) S Z=^(0) D I^DITR K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA ; B36(X) Q $$N1(X\(36*36)#36+1)_$$N1(X\36#36+1)_$$N1(X#36+1) N1(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%) DINIT0 DINIT0 ;SFISC/GFT,XAK-INITIALIZE VA FILEMAN ;2JUL2011 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; I '$D(^DD("SETPTCNODE")) S ^("SETPTCNODE")=$H W !! F I=0:0 S I=$O(^DD(I)) Q:'I F J=0:0 S J=$O(^DD(I,J)) Q:'J S %=+$P($P($G(^(J,0)),U,2),"p",2) I %,$D(^DD(%,0)) S ^(0,"PTC",I,J)="" ;COMPUTED POINTER DD F I=1:1 S X=$T(DD+I),Y=$P(X," ",3,99) G ^DINIT1:X?.P S @("^DD(0,"_$E($P(X," ",2),3,99)_")=Y") ;;0 ATTRIBUTE^N ;;"SB",.1,1 ;;.001,0 NUMBER^N^^ ^K:$L(X)>12 X ;;.01,0 LABEL^RF^^0;1^K:$L(X)>30!(X?1E)!(X["""")!(X["=") X ;;.01,1,0 ^.1^1^1 ;;.01,1,1,0 DA(2)^B ;;.01,1,1,1 S @(DIC_"""B"",X,DA)=""""") ;;.01,1,1,2 K @(DIC_"""B"",X,DA)") ;;.01,"DEL",.2,0 I DUZ(0)'="@",$P(^DD(DA(1),DA,0),"^",2)["X" W !,$C(7),"ONLY A PROGRAMMER CAN DELETE THIS FIELD!" ;;.01,"DEL",.3,0 W:$D(^DD("ACOMP",DA(1),DA)) !,$C(7),"WARNING-- A COMPUTED FIELD USES THIS FIELD!" I 0 ;;.01,"DEL",1,0 I DA=.01 W $C(7),"??" ;;.01,"DEL","TRB",0 S %=+$P(^DD(DA(1),DA,0),U,2) I %,$D(^DD(%,"TRB")) S DA(0)=DA,DA=% D TRIG^DIDH S DA=DA(0) ;;.01,"DEL","T",0 I $O(^DD(DA(1),DA,5,0))>0 W $C(7),!,"CAN'T DELETE A FIELD THAT HAS A 'TRIGGER' POINTING TO IT!" ;;.01,"DEL","ID",0 I $D(^DD(DA(1),0,"ID",DA)) W !,"CAN'T DELETE IDENTIFIER!" ;;.1,0 TITLE^F^^.1;E1,999^K:$L(X)>100!(+X=X) X I $D(X),$L(X)<32,@("$D("_DIC_"""B"",X,DA))") K X ;;.1,1,0 ^.1^1^1 ;;.1,1,1,0 DA(2)^B ;;.1,1,1,1 S:$L(X)<31 @(DIC_"""B"",X,DA)=1") ;;.1,1,1,2 K:$L(X)<31 @(DIC_"""B"",X,DA)") ;;.1,3 (OPTIONAL) FULL FIELD NAME (MUST BE DIFFERENT FROM LABEL) ;;.12,0 VARIABLE POINTER^.12^^V;0 ;;.2,0 SPECIFIER^F^^0;2 ;;.2,1,0 ^.1^4^4 ;;.2,1,1,0 DA(2)^SB^ (SUBFILE USED) ;;.2,1,1,1 S:X @(DIC_"""SB"",+X,DA)=""""") ;;.2,1,1,2 K:X @(DIC_"""SB"",+X,DA)") ;;.2,1,2,0 DA(2)^RQ^ ;;.2,1,2,1 S:X["R" @(DIC_"""RQ"",DA)=""""") ;;.2,1,2,2 K:X["R" @(DIC_"""RQ"",DA)") ;;.2,1,3,0 ^ ;;.2,1,3,1 S %=$P(X,"P",2) S:$A(%)=48!%&$D(^DD(+%,0)) ^(0,"PT",DA(1),DA)="" ;;.2,1,3,2 S %=$P(X,"P",2) K:$A(%)=48!% ^DD(+%,0,"PT",DA(1),DA) ;;.2,1,666,0 ^ ;;.2,1,666,1 N % S %=+$P(X,"p",2) I %,$D(^DD(%,0)) S ^(0,"PTC",DA(1),DA)="" ;COMPUTED POINTER ;;.2,1,666,2 N % S %=+$P(X,"p",2) I %,$D(^DD(%,0)) K ^(0,"PTC",DA(1),DA) ;;.2,9 ^ ;;.23,0 LENGTH^CJ3^^ ; ^S X=$S($D(@(DCC_"D0,0)")):$P(^(0),U,2),1:""),X=$P(X,"J",2),X=$S(X:+X,1:"") ;;.23,9 ^ ;;.24,0 DECIMAL DEFAULT^CJ1^^ ; ^S @("X=$P($G("_DCC_"D0,0)),U,2)"),X=$P($P(X,"J",2),",",2) ;;.25,0 TYPE^CJ15^^ ; ^S X=$P($G(@(DCC_"D0,0)")),U,2),X=$S(X["C":6,X["N":2,X["P":7,X["S":3,X["D":1,X["V":8,X["K":9,X["W"!$S('X:0,'$D(^DD(+X,.01,0)):0,1:$P(^(0),U,2)["W"):5,1:0),X=$S($D(^DOPT("DICATT",X,0)):$P(^(0)," "),1:"FREE TEXT") ;;.25,9 ^ DINIT001 DINIT001 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;22AUG2006 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^DIC(.84,0,"GL") ;;=^DI(.84, ;;^DIC("B","DIALOG",.84) ;;= ;;^DIC(.84,"%D",0) ;;=^^8^8^2941121^^^^ ;;^DIC(.84,"%D",1,0) ;;=This file stores the dialog used to 'talk' to a user (error messages, ;;^DIC(.84,"%D",2,0) ;;=help text, and other prompts.) Entry points in the ^DIALOG routine ;;^DIC(.84,"%D",3,0) ;;=retrieve text from this file. Variable parameters can be passed to these ;;^DIC(.84,"%D",4,0) ;;=calls. The parameters are inserted into windows within the text as it is ;;^DIC(.84,"%D",5,0) ;;=built. The text is returned in an array. This file and associated calls ;;^DIC(.84,"%D",6,0) ;;=can be used by any package to pass information in arrays rather than ;;^DIC(.84,"%D",7,0) ;;=writing to the current device. Record numbers 1 through 10000 are ;;^DIC(.84,"%D",8,0) ;;=reserved for VA FileMan. ;;^DD(.84,0) ;;=FIELD^^8^11 ;;^DD(.84,0,"DT") ;;=2960426 ;;^DD(.84,0,"ID","WRITE") ;;=N DIALID S DIALID(1)=$P($G(^(0)),U,5) S:DIALID(1)="" DIALID=+$O(^(2,0)),DIALID(1)=$E($G(^(DIALID,0)),1,42) S DIALID(1,"F")="?10" D EN^DDIOL(.DIALID) ;;^DD(.84,0,"IX","B",.84,.01) ;;= ;;^DD(.84,0,"IX","C",.84,1.2) ;;= ;;^DD(.84,0,"IX","D",.84,1.3) ;;= ;;^DD(.84,0,"NM","DIALOG") ;;= ;;^DD(.84,0,"PT",1.52192,4) ;;= ;;^DD(.84,.01,0) ;;=DIALOG NUMBER^RNJ14,3X^^0;1^K:+X'=X!(X>9999999999.999)!(('$G(DIFROM))&(X<10000.001))!(X?.E1"."4N.N) X S:$G(X) DINUM=X ;;^DD(.84,.01,1,0) ;;=^.1 ;;^DD(.84,.01,1,1,0) ;;=.84^B ;;^DD(.84,.01,1,1,1) ;;=S ^DI(.84,"B",$E(X,1,30),DA)="" ;;^DD(.84,.01,1,1,2) ;;=K ^DI(.84,"B",$E(X,1,30),DA) ;;^DD(.84,.01,3) ;;=Type a Number between 10000.001 and 9999999999.999, up to 3 Decimal Digits ;;^DD(.84,.01,21,0) ;;=^^1^1^2940523^ ;;^DD(.84,.01,21,1,0) ;;=The dialogue number is used to uniquely identify a message. ;;^DD(.84,.01,"DT") ;;=2940623 ;;^DD(.84,1,0) ;;=TYPE^RS^1:ERROR;2:GENERAL MESSAGE;3:HELP;^0;2^Q ;;^DD(.84,1,3) ;;=Enter code that reflects how this dialogue is used when talking to the users. ;;^DD(.84,1,21,0) ;;=^^2^2^2940523^ ;;^DD(.84,1,21,1,0) ;;=This code is used to group the entries in the FileMan DIALOG file, ;;^DD(.84,1,21,2,0) ;;=according to how they are used when interacting with the user. ;;^DD(.84,1,23,0) ;;=^^3^3^2940523^ ;;^DD(.84,1,23,1,0) ;;=This field is used to tell the DIALOG routines what array to use in ;;^DD(.84,1,23,2,0) ;;=returning the dialogue. It is also used for grouping the dialogue for ;;^DD(.84,1,23,3,0) ;;=reporting purposes. ;;^DD(.84,1,"DT") ;;=2940523 ;;^DD(.84,1.2,0) ;;=PACKAGE^P9.4'^DIC(9.4,^0;4^Q ;;^DD(.84,1.2,1,0) ;;=^.1 ;;^DD(.84,1.2,1,1,0) ;;=.84^C ;;^DD(.84,1.2,1,1,1) ;;=S ^DI(.84,"C",$E(X,1,30),DA)="" ;;^DD(.84,1.2,1,1,2) ;;=K ^DI(.84,"C",$E(X,1,30),DA) ;;^DD(.84,1.2,1,1,"%D",0) ;;=^^3^3^2940623^ ;;^DD(.84,1.2,1,1,"%D",1,0) ;;=Cross-reference on Package file. Used for identifying DIALOG entries by ;;^DD(.84,1.2,1,1,"%D",2,0) ;;=the package that owns the entry, and for populating the BUILD file during ;;^DD(.84,1.2,1,1,"%D",3,0) ;;=package distribution. ;;^DD(.84,1.2,1,1,"DT") ;;=2940623 ;;^DD(.84,1.2,3) ;;=Enter the name of the Package that owns and distributes this entry. ;;^DD(.84,1.2,21,0) ;;=^^3^3^2940526^ ;;^DD(.84,1.2,21,1,0) ;;=This is a pointer to the Package file. Each entry in this file belongs ;;^DD(.84,1.2,21,2,0) ;;=to, and is distributed by, a certain package. The Package field should be ;;^DD(.84,1.2,21,3,0) ;;=filled in for each entry on this file. ;;^DD(.84,1.2,"DT") ;;=2940623 ;;^DD(.84,1.3,0) ;;=SHORT DESCRIPTION^F^^0;5^K:$L(X)>42!($L(X)<1) X ;;^DD(.84,1.3,1,0) ;;=^.1 ;;^DD(.84,1.3,1,1,0) ;;=.84^D ;;^DD(.84,1.3,1,1,1) ;;=S ^DI(.84,"D",$E(X,1,30),DA)="" ;;^DD(.84,1.3,1,1,2) ;;=K ^DI(.84,"D",$E(X,1,30),DA) ;;^DD(.84,1.3,1,1,"DT") ;;=2960426 ;;^DD(.84,1.3,3) ;;=Description used to identify entry on lookup. Answer must be 1-42 characters in length. ;;^DD(.84,1.3,21,0) ;;=^^2^2^2960426^ ;;^DD(.84,1.3,21,1,0) ;;=Short description is used to identify an entry on lookup. The "WRITE" ;;^DD(.84,1.3,21,2,0) ;;=identifier will display this description if it is not null. ;;^DD(.84,1.3,"DT") ;;=2960426 ;;^DD(.84,2,0) ;;=DESCRIPTION^.842^^1;0 ;;^DD(.84,2,21,0) ;;=^^1^1^2930824^^ ;;^DD(.84,2,21,1,0) ;;= Used for internal documentation purposes. ;;^DD(.84,3,0) ;;=INTERNAL PARAMETERS NEEDED^S^y:YES;^0;3^Q ;;^DD(.84,3,3) ;;= ;;^DD(.84,3,21,0) ;;=^^6^6^2931105^ ;;^DD(.84,3,21,1,0) ;;= Some dialogue is built by inserting variable text (internal parameters) ;;^DD(.84,3,21,2,0) ;;=into windows in the word-processing TEXT field. The insertable text might ;;^DD(.84,3,21,3,0) ;;=be, for example, File or Field names. This field should be set to YES if ;;^DD(.84,3,21,4,0) ;;=any internal parameters need to be inserted into the TEXT. If the field ;;^DD(.84,3,21,5,0) ;;=is not set to YES, the DIALOG routine will not go through the part of the ;;^DD(.84,3,21,6,0) ;;=code that stuffs the internal parameters into the text. ;;^DD(.84,3,"DT") ;;=2931105 ;;^DD(.84,4,0) ;;=TEXT^.844^^2;0 ;;^DD(.84,4,21,0) ;;=^^7^7^2941122^ ;;^DD(.84,4,21,1,0) ;;=Actual text of the message. If parameters (variable pieces of text) are ;;^DD(.84,4,21,2,0) ;;=to be inserted into the dialogue when the message is built, the parameter ;;^DD(.84,4,21,3,0) ;;=will appear as a 'window' in this TEXT field, surrounded by vertical bars. ;;^DD(.84,4,21,4,0) ;;=The data within the 'window' will represent a subscript of the input ;;^DD(.84,4,21,5,0) ;;=parameter list that is passed to BLD^DIALOG or $$EZBLD^DIALOG when ;;^DD(.84,4,21,6,0) ;;=building the message. This same subscript should be used as the .01 of the ;;^DD(.84,4,21,7,0) ;;=PARAMETER field in this file to document the parameter. ;;^DD(.84,5,0) ;;=PARAMETER^.845A^^3;0 ;;^DD(.84,6,0) ;;=POST MESSAGE ACTION^K^^6;E1,245^K:$L(X)>245 X D:$D(X) ^DIM ;;^DD(.84,6,3) ;;=This is Standard MUMPS code. This code will be executed whenever this message is retrieved through a call to BLD^DIALOG or $$EZBLD^DIALOG. ;;^DD(.84,6,9) ;;=@ ;;^DD(.84,6,21,0) ;;=^^6^6^2941122^ ;;^DD(.84,6,21,1,0) ;;=If some special action should be taken whenever this message is built, ;;^DD(.84,6,21,2,0) ;;=MUMPS code can be entered here. This code will be executed by the ;;^DD(.84,6,21,3,0) ;;=BLD^DIALOG or $$EZBLD^DIALOG routines, immediately after the message text ;;^DD(.84,6,21,4,0) ;;=has been built in the output array. For example, the code could set a DINIT002 DINIT002 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;7APR2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^DD(.84,6,21,5,0) ;;=special flag into a global or local variable to notify the calling routine ;;^DD(.84,6,21,6,0) ;;=that some extra action needed to be taken. ;;^DD(.84,6,23,0) ;;=^^7^7^2941122^ ;;^DD(.84,6,23,1,0) ;;=At the time of executing this code ;;^DD(.84,6,23,2,0) ;;= D0 = IEN for the entry in the DIALOG file ;;^DD(.84,6,23,3,0) ;;= DIPI(n) = (for sequential number n) parameters incorporated in the text. ;;^DD(.84,6,23,4,0) ;;= DIPE(n) = parameters output back to the user ;;^DD(.84,6,23,5,0) ;;= ;;^DD(.84,6,23,6,0) ;;=All other variables used in this code should use your packages namespace, ;;^DD(.84,6,23,7,0) ;;=and should be NEWed. ;;^DD(.84,6,"DT") ;;=2940520 ;;^DD(.84,7,0) ;;=TRANSLATION^.847PA^^4;0 ;;^DD(.84,8,0) ;;=CALLED FROM ENTRY POINTS^.841A^^5;0 ;;^DD(.841,0) ;;=CALLED FROM ENTRY POINTS SUB-FIELD^^.05^2 ;;^DD(.841,0,"DT") ;;=2940411 ;;^DD(.841,0,"IX","B",.841,.01) ;;= ;;^DD(.841,0,"NM","CALLED FROM ENTRY POINTS") ;;= ;;^DD(.841,0,"UP") ;;=.84 ;;^DD(.841,.01,0) ;;=ROUTINE NAME^MF^^0;1^K:$L(X)>8!($L(X)<1) X ;;^DD(.841,.01,1,0) ;;=^.1 ;;^DD(.841,.01,1,1,0) ;;=.841^B ;;^DD(.841,.01,1,1,1) ;;=S ^DI(.84,DA(1),5,"B",$E(X,1,30),DA)="" ;;^DD(.841,.01,1,1,2) ;;=K ^DI(.84,DA(1),5,"B",$E(X,1,30),DA) ;;^DD(.841,.01,3) ;;=Answer must be 1-8 characters in length. ;;^DD(.841,.01,21,0) ;;=^^6^6^2940411^ ;;^DD(.841,.01,21,1,0) ;;=This multiple is used for documentation only. Entries are made to this ;;^DD(.841,.01,21,2,0) ;;=subfile ONLY for ERROR type text. Enter the routine name of an entry ;;^DD(.841,.01,21,3,0) ;;=point that may generate this error message. You only need to enter the ;;^DD(.841,.01,21,4,0) ;;=names of routines that directly generate the error through a call to ;;^DD(.841,.01,21,5,0) ;;=^DIALOG, and not when the error is generated by some other utility called ;;^DD(.841,.01,21,6,0) ;;=from your routine. ;;^DD(.841,.01,"DT") ;;=2940411 ;;^DD(.841,.05,0) ;;=LINE TAG^F^^0;2^K:$L(X)>10!($L(X)<1) X ;;^DD(.841,.05,3) ;;=Answer must be 1-10 characters in length. ;;^DD(.841,.05,21,0) ;;=^^6^6^2940411^ ;;^DD(.841,.05,21,1,0) ;;=This multiple is used for documentation only. Entries are made to this ;;^DD(.841,.05,21,2,0) ;;=subfile ONLY for ERROR type text. Enter the line tag of an entry point ;;^DD(.841,.05,21,3,0) ;;=that may generate this error message. You only need to enter the names of ;;^DD(.841,.05,21,4,0) ;;=routines that directly generate the error through a call to ^DIALOG, and ;;^DD(.841,.05,21,5,0) ;;=not when the error is generated by some other utility called from your ;;^DD(.841,.05,21,6,0) ;;=routine. ;;^DD(.841,.05,"DT") ;;=2940411 ;;^DD(.842,0) ;;=DESCRIPTION SUB-FIELD^^.01^1 ;;^DD(.842,0,"DT") ;;=2930614 ;;^DD(.842,0,"NM","DESCRIPTION") ;;= ;;^DD(.842,0,"UP") ;;=.84 ;;^DD(.842,.01,0) ;;=DESCRIPTION^W^^0;1^Q ;;^DD(.842,.01,3) ;;=Describe the use of this dialogue. ;;^DD(.842,.01,"DT") ;;=2930614 ;;^DD(.844,0) ;;=TEXT SUB-FIELD^^.01^1 ;;^DD(.844,0,"DT") ;;=2930811 ;;^DD(.844,0,"NM","TEXT") ;;= ;;^DD(.844,0,"UP") ;;=.84 ;;^DD(.844,.01,0) ;;=TEXT^WL^^0;1^Q ;;^DD(.844,.01,3) ;;=Enter the actual text of the dialogue, with optional parameter windows. ;;^DD(.844,.01,"DT") ;;=2930811 ;;^DD(.845,0) ;;=PARAMETER SUB-FIELD^^1^2 ;;^DD(.845,0,"DT") ;;=2931105 ;;^DD(.845,0,"IX","B",.845,.01) ;;= ;;^DD(.845,0,"NM","PARAMETER") ;;= ;;^DD(.845,0,"UP") ;;=.84 ;;^DD(.845,.01,0) ;;=PARAMETER SUBSCRIPT^MF^^0;1^K:$L(X)>20!($L(X)<1) X ;;^DD(.845,.01,1,0) ;;=^.1 ;;^DD(.845,.01,1,1,0) ;;=.845^B ;;^DD(.845,.01,1,1,1) ;;=S ^DI(.84,DA(1),3,"B",$E(X,1,30),DA)="" ;;^DD(.845,.01,1,1,2) ;;=K ^DI(.84,DA(1),3,"B",$E(X,1,30),DA) ;;^DD(.845,.01,3) ;;=This entry corresponds to the subscript of an entry in either the text or output parameter list to the BLD^DIALOG and $$EZBLD^DIALOG routine. Answer must be 1-20 characters in length. ;;^DD(.845,.01,21,0) ;;=^^7^7^2941122^ ;;^DD(.845,.01,21,1,0) ;;=This multiple is used for documentation purposes only. The entry in the ;;^DD(.845,.01,21,2,0) ;;=.01 field of this multiple will correspond to a subscript in either the ;;^DD(.845,.01,21,3,0) ;;=text or output parameter list, that are passed to the routines that build ;;^DD(.845,.01,21,4,0) ;;=dialogue messages, BLD^DIALOG and $$EZBLD^DIALOG. This routine will insert ;;^DD(.845,.01,21,5,0) ;;=into each 'window' from the TEXT field, the corresponding entry out of the ;;^DD(.845,.01,21,6,0) ;;=text parameter list. For errors only, it passes any entries from the ;;^DD(.845,.01,21,7,0) ;;=output parameter list back to the user as entries in its output array. ;;^DD(.845,.01,"DT") ;;=2931105 ;;^DD(.845,1,0) ;;=PARAMETER DESCRIPTION^F^^0;2^K:$L(X)>230!($L(X)<1) X ;;^DD(.845,1,3) ;;=Describe the Parameter for documentation purposes. Answer must be 1-230 characters in length. ;;^DD(.845,1,21,0) ;;=^^5^5^2941122^ ;;^DD(.845,1,21,1,0) ;;=This field is used for documentation purposes only. It describes the text ;;^DD(.845,1,21,2,0) ;;=and/or output parameter(s) that are passed to BLD^DIALOG and ;;^DD(.845,1,21,3,0) ;;=$$EZBLD^DIALOG. The same parameter can be used both as a text parameter ;;^DD(.845,1,21,4,0) ;;=(i.e., inserted into the text when it is built), and as an output ;;^DD(.845,1,21,5,0) ;;=parameter (i.e., a parameter passed back in a list to the user) ;;^DD(.845,1,"DT") ;;=2930614 ;;^DD(.847,0) ;;=TRANSLATION SUB-FIELD^^1^2 ;;^DD(.847,0,"DT") ;;=2940524 ;;^DD(.847,0,"IX","B",.847,.01) ;;= ;;^DD(.847,0,"NM","TRANSLATION") ;;= ;;^DD(.847,0,"UP") ;;=.84 ;;^DD(.847,.01,0) ;;=LANGUAGE^*P.85'X^DI(.85,^0;1^S DIC("S")="I Y>1" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X S:$G(X) DINUM=X ;;^DD(.847,.01,1,0) ;;=^.1 ;;^DD(.847,.01,1,1,0) ;;=.847^B ;;^DD(.847,.01,1,1,1) ;;=S ^DI(.84,DA(1),4,"B",$E(X,1,30),DA)="" ;;^DD(.847,.01,1,1,2) ;;=K ^DI(.84,DA(1),4,"B",$E(X,1,30),DA) ;;^DD(.847,.01,3) ;;=Enter the number or name for a non-English language. ;;^DD(.847,.01,12) ;;=English language cannot be selected. ;;^DD(.847,.01,12.1) ;;=S DIC("S")="I Y>1" ;;^DD(.847,.01,21,0) ;;=^^3^3^2941118^^ ;;^DD(.847,.01,21,1,0) ;;=Pointer to the LANGUAGE file. If FileMan system variable DUZ("LANG") is ;;^DD(.847,.01,21,2,0) ;;=set to an integer greater than 1, we use that number to extract dialogue ;;^DD(.847,.01,21,3,0) ;;=text for the specified language from this multiple. DINIT003 DINIT003 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^DD(.847,.01,"DT") ;;=2940524 ;;^DD(.847,1,0) ;;=FOREIGN TEXT^.8471^^1;0 ;;^DD(.847,1,21,0) ;;=^^3^3^2941118^ ;;^DD(.847,1,21,1,0) ;;=Insert here the non-English equivalent for this language to the text in ;;^DD(.847,1,21,2,0) ;;=the TEXT field for this entry. This field may contain windows for ;;^DD(.847,1,21,3,0) ;;=variable parameters the same as the TEXT field. ;;^DD(.8471,0) ;;=FOREIGN TEXT SUB-FIELD^^.01^1 ;;^DD(.8471,0,"DT") ;;=2930811 ;;^DD(.8471,0,"NM","FOREIGN TEXT") ;;= ;;^DD(.8471,0,"UP") ;;=.847 ;;^DD(.8471,.01,0) ;;=FOREIGN TEXT^WL^^0;1^Q ;;^DD(.8471,.01,3) ;;=Enter the non-English dialog text ;;^DD(.8471,.01,"DT") ;;=2930811 DINIT004 DINIT004 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;10:12 AM 10 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84) ;;=^DI(.84, ;;^UTILITY(U,$J,.84,0) ;;=DIALOG^.84I^9549^322 ;;^UTILITY(U,$J,.84,101,0) ;;=101^1^^5 ;;^UTILITY(U,$J,.84,101,1,0) ;;=^^2^2^2931110^ ;;^UTILITY(U,$J,.84,101,1,1,0) ;;=The option or function can only be done if DUZ(0)="@", designating ;;^UTILITY(U,$J,.84,101,1,2,0) ;;=the user as having programmer access. ;;^UTILITY(U,$J,.84,101,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,101,2,1,0) ;;=Only those with programmer's access can perform this function. ;;^UTILITY(U,$J,.84,110,0) ;;=110^1^^5 ;;^UTILITY(U,$J,.84,110,1,0) ;;=^^2^2^2931110^ ;;^UTILITY(U,$J,.84,110,1,1,0) ;;=An attempt to get a lock timed out. The record is locked and the desired ;;^UTILITY(U,$J,.84,110,1,2,0) ;;=action cannot be taken until the lock is released. ;;^UTILITY(U,$J,.84,110,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,110,2,1,0) ;;=The record is currently locked. ;;^UTILITY(U,$J,.84,110,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,110,3,1,0) ;;=FILE^File or subfile #. ;;^UTILITY(U,$J,.84,110,3,2,0) ;;=IENS^IEN string of entry numbers. ;;^UTILITY(U,$J,.84,110,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,110,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,111,0) ;;=111^1^y^5 ;;^UTILITY(U,$J,.84,111,1,0) ;;=^^2^2^2970205^^ ;;^UTILITY(U,$J,.84,111,1,1,0) ;;=An attempt to get a lock timed out. The File Header Node is locked, and ;;^UTILITY(U,$J,.84,111,1,2,0) ;;=the desired action cannot be taken until the lock is released. ;;^UTILITY(U,$J,.84,111,2,0) ;;=^^1^1^2970205^^ ;;^UTILITY(U,$J,.84,111,2,1,0) ;;=The File Header Node is currently locked. ;;^UTILITY(U,$J,.84,111,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,111,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,111,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,112,0) ;;=112^1^y^5 ;;^UTILITY(U,$J,.84,112,1,0) ;;=^^2^2^2970205^^ ;;^UTILITY(U,$J,.84,112,1,1,0) ;;=An attempt to get a lock timed out. The File is locked, and the desired ;;^UTILITY(U,$J,.84,112,1,2,0) ;;=action cannot be taken until the lock is released. ;;^UTILITY(U,$J,.84,112,2,0) ;;=^^1^1^2970205^ ;;^UTILITY(U,$J,.84,112,2,1,0) ;;=The file is currently locked. ;;^UTILITY(U,$J,.84,112,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,112,3,1,0) ;;=FILE^FILE # ;;^UTILITY(U,$J,.84,120,0) ;;=120^1^y^5 ;;^UTILITY(U,$J,.84,120,1,0) ;;=^^7^7^2941006^^ ;;^UTILITY(U,$J,.84,120,1,1,0) ;;=An error occurred during the Xecution of a FileMan hook (e.g., an input ;;^UTILITY(U,$J,.84,120,1,2,0) ;;=transform, DIC screen). The type of hook in which the error occurred is ;;^UTILITY(U,$J,.84,120,1,3,0) ;;=identified in the text. When relevant, the file, field, and IENS for ;;^UTILITY(U,$J,.84,120,1,4,0) ;;=which the hook was being Xecuted are identified in the PARAM nodes. The ;;^UTILITY(U,$J,.84,120,1,5,0) ;;=substance of the error will usually be identified by a separate error ;;^UTILITY(U,$J,.84,120,1,6,0) ;;=message generated during the Xecution of the hook itself. That error will ;;^UTILITY(U,$J,.84,120,1,7,0) ;;=usually be the one preceding this one in the DIERR array. ;;^UTILITY(U,$J,.84,120,2,0) ;;=^^1^1^2941006^^ ;;^UTILITY(U,$J,.84,120,2,1,0) ;;=The previous error occurred when performing an action specified in a |1|. ;;^UTILITY(U,$J,.84,120,3,0) ;;=^.845^4^4 ;;^UTILITY(U,$J,.84,120,3,1,0) ;;=1^Type of FileMan Xecutable code. ;;^UTILITY(U,$J,.84,120,3,2,0) ;;=FILE^File# ;;^UTILITY(U,$J,.84,120,3,3,0) ;;=FIELD^Field#. ;;^UTILITY(U,$J,.84,120,3,4,0) ;;=IENS^Internal Entry Number String. ;;^UTILITY(U,$J,.84,200,0) ;;=200^1^^5 ;;^UTILITY(U,$J,.84,200,1,0) ;;=^^2^2^2931109^ ;;^UTILITY(U,$J,.84,200,1,1,0) ;;=There is an error in one of the variables passed to a FileMan call or ;;^UTILITY(U,$J,.84,200,1,2,0) ;;=in one of the parameters passed in the actual parameter list. ;;^UTILITY(U,$J,.84,200,2,0) ;;=^^1^1^2931110^^^ ;;^UTILITY(U,$J,.84,200,2,1,0) ;;=An input variable or parameter is missing or invalid. ;;^UTILITY(U,$J,.84,201,0) ;;=201^1^y^5 ;;^UTILITY(U,$J,.84,201,1,0) ;;=^^2^2^2931110^^ ;;^UTILITY(U,$J,.84,201,1,1,0) ;;=The specified input variable is either 1) required but not defined or ;;^UTILITY(U,$J,.84,201,1,2,0) ;;=2) not valid. ;;^UTILITY(U,$J,.84,201,2,0) ;;=^^1^1^2931110^^^ ;;^UTILITY(U,$J,.84,201,2,1,0) ;;=The input variable |1| is missing or invalid. ;;^UTILITY(U,$J,.84,201,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,201,3,1,0) ;;=1^Variable name. ;;^UTILITY(U,$J,.84,202,0) ;;=202^1^y^5 ;;^UTILITY(U,$J,.84,202,1,0) ;;=^^1^1^2931110^^^^ ;;^UTILITY(U,$J,.84,202,1,1,0) ;;=The specified parameter is either required but missing or invalid. ;;^UTILITY(U,$J,.84,202,2,0) ;;=^^1^1^2950317^^^^ ;;^UTILITY(U,$J,.84,202,2,1,0) ;;=The input parameter that identifies the |1| is missing or invalid. ;;^UTILITY(U,$J,.84,202,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,202,3,1,0) ;;=1^Parameter as identified in the FM documentation. ;;^UTILITY(U,$J,.84,202,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,202,5,1,0) ;;=DIT^TRNMRG ;;^UTILITY(U,$J,.84,203,0) ;;=203^1^y^5 ;;^UTILITY(U,$J,.84,203,1,0) ;;=^^3^3^2940426^ ;;^UTILITY(U,$J,.84,203,1,1,0) ;;=An incorrect subscript is present in an array that is passed to FileMan. ;;^UTILITY(U,$J,.84,203,1,2,0) ;;=For example, one of the subscripts in the FDA which identifies FILE, IENS, ;;^UTILITY(U,$J,.84,203,1,3,0) ;;=or FIELD is incorrectly formatted. ;;^UTILITY(U,$J,.84,203,2,0) ;;=^^1^1^2940426^^^ ;;^UTILITY(U,$J,.84,203,2,1,0) ;;=The subscript that identifies the |1| is missing or invalid. ;;^UTILITY(U,$J,.84,203,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,203,3,1,0) ;;=1^The data element incorrectly specified by a subscript. ;;^UTILITY(U,$J,.84,203,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,203,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,204,0) ;;=204^1^^5 ;;^UTILITY(U,$J,.84,204,1,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,204,1,1,0) ;;=Control characters are not permitted in the database. ;;^UTILITY(U,$J,.84,204,2,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,204,2,1,0) ;;=The input value contains control characters. ;;^UTILITY(U,$J,.84,204,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,204,3,1,0) ;;=1^INPUT VALUE ;;^UTILITY(U,$J,.84,205,0) ;;=205^1^y^5 ;;^UTILITY(U,$J,.84,205,1,0) ;;=^^4^4^2960827^ ;;^UTILITY(U,$J,.84,205,1,1,0) ;;=Error message output when a file or subfile number, and its associated IEN ;;^UTILITY(U,$J,.84,205,1,2,0) ;;=string are not in sync (i.e, the number of comma pieces represented by DINIT005 DINIT005 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,205,1,3,0) ;;=the IEN string do not match the file/subfile level according to the "UP" ;;^UTILITY(U,$J,.84,205,1,4,0) ;;=nodes). ;;^UTILITY(U,$J,.84,205,2,0) ;;=^^1^1^2960827^^^ ;;^UTILITY(U,$J,.84,205,2,1,0) ;;=File# |1| and IEN string |IENS| represent different subfile levels. ;;^UTILITY(U,$J,.84,205,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,205,3,1,0) ;;=1^File or subfile number ;;^UTILITY(U,$J,.84,205,3,2,0) ;;=IENS^IEN string ;;^UTILITY(U,$J,.84,205,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,205,5,1,0) ;;=DIT3^IENCHK ;;^UTILITY(U,$J,.84,205,5,2,0) ;;=DICA3^ERR ;;^UTILITY(U,$J,.84,206,0) ;;=206^1^y^5 ;;^UTILITY(U,$J,.84,206,1,0) ;;=^^3^3^2960124^ ;;^UTILITY(U,$J,.84,206,1,1,0) ;;=FileMan is trying to pack fields onto a single node for a record, and the ;;^UTILITY(U,$J,.84,206,1,2,0) ;;=data will not fit. The application has asked for too many fields back for ;;^UTILITY(U,$J,.84,206,1,3,0) ;;=this record. ;;^UTILITY(U,$J,.84,206,2,0) ;;=^^1^1^2960124^ ;;^UTILITY(U,$J,.84,206,2,1,0) ;;=The data requested for record |1| is too long to pack together. ;;^UTILITY(U,$J,.84,206,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,206,3,1,0) ;;=1^Record Number. ;;^UTILITY(U,$J,.84,207,0) ;;=207^1^y^5 ;;^UTILITY(U,$J,.84,207,1,0) ;;=^^5^5^2960318^ ;;^UTILITY(U,$J,.84,207,1,1,0) ;;=The library function $$HTML^DILF can encode or decode a string to and from ;;^UTILITY(U,$J,.84,207,1,2,0) ;;=HTML, used within FileMan to pack a value containing embedded ^s into a ;;^UTILITY(U,$J,.84,207,1,3,0) ;;=^-delimited string. Encoding increases the length of the string. If ;;^UTILITY(U,$J,.84,207,1,4,0) ;;=encoding would cause the length to exceed the portable string length ;;^UTILITY(U,$J,.84,207,1,5,0) ;;=limit, $$HTML^DILF instead returns this error. ;;^UTILITY(U,$J,.84,207,2,0) ;;=^^1^1^2960318^ ;;^UTILITY(U,$J,.84,207,2,1,0) ;;=The value |1| is too long to encode into HTML. ;;^UTILITY(U,$J,.84,207,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,207,3,1,0) ;;=1^Value. ;;^UTILITY(U,$J,.84,208,0) ;;=208^1^^5^Illegal number error ;;^UTILITY(U,$J,.84,208,2,0) ;;=^^1^1^2970829^ ;;^UTILITY(U,$J,.84,208,2,1,0) ;;=Input value is an illegal number. ;;^UTILITY(U,$J,.84,209,0) ;;=209^1^^5 ;;^UTILITY(U,$J,.84,209,2,0) ;;=^^1^1^2980709^ ;;^UTILITY(U,$J,.84,209,2,1,0) ;;=Input value is too long. ;;^UTILITY(U,$J,.84,209,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,209,5,1,0) ;;=DIC0^CHKVAL2 ;;^UTILITY(U,$J,.84,209,5,2,0) ;;=DIC11^PR1 ;;^UTILITY(U,$J,.84,299,0) ;;=299^1^y^5 ;;^UTILITY(U,$J,.84,299,1,0) ;;=^^2^2^2970423^^^^ ;;^UTILITY(U,$J,.84,299,1,1,0) ;;=A lookup that was restricted to finding a single entry found more than ;;^UTILITY(U,$J,.84,299,1,2,0) ;;=one. ;;^UTILITY(U,$J,.84,299,2,0) ;;=^^1^1^2970423^ ;;^UTILITY(U,$J,.84,299,2,1,0) ;;=More than one entry matches the value(s) '|1|'. ;;^UTILITY(U,$J,.84,299,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,299,3,1,0) ;;=1^Lookup Value. ;;^UTILITY(U,$J,.84,299,3,2,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,299,3,3,0) ;;=IENS^IEN String. ;;^UTILITY(U,$J,.84,301,0) ;;=301^1^y^5 ;;^UTILITY(U,$J,.84,301,1,0) ;;=^^1^1^2931110^^ ;;^UTILITY(U,$J,.84,301,1,1,0) ;;=Flags passed in a variable (like DIC(0)) or in a parameter are incorrect. ;;^UTILITY(U,$J,.84,301,2,0) ;;=^^1^1^2931110^^ ;;^UTILITY(U,$J,.84,301,2,1,0) ;;=The passed flag(s) '|1|' are unknown or inconsistent. ;;^UTILITY(U,$J,.84,301,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,301,3,1,0) ;;=1^Letter(s) from flag. ;;^UTILITY(U,$J,.84,302,0) ;;=302^1^y^5 ;;^UTILITY(U,$J,.84,302,1,0) ;;=^^2^2^2940215^ ;;^UTILITY(U,$J,.84,302,1,1,0) ;;=The calling application has asked us to add a new record, and has supplied ;;^UTILITY(U,$J,.84,302,1,2,0) ;;=a record number, but a record already exists at that number. ;;^UTILITY(U,$J,.84,302,2,0) ;;=^^1^1^2941018^ ;;^UTILITY(U,$J,.84,302,2,1,0) ;;=Entry '|IENS|' already exists. ;;^UTILITY(U,$J,.84,302,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,302,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,302,3,2,0) ;;=IENS^IEN String. ;;^UTILITY(U,$J,.84,304,0) ;;=304^1^y^5 ;;^UTILITY(U,$J,.84,304,1,0) ;;=^^2^2^2940628^^^^ ;;^UTILITY(U,$J,.84,304,1,1,0) ;;=The problem with this IEN string is that it lacks the final ','. This is a ;;^UTILITY(U,$J,.84,304,1,2,0) ;;=common mistake for beginners. ;;^UTILITY(U,$J,.84,304,2,0) ;;=^^1^1^2941018^ ;;^UTILITY(U,$J,.84,304,2,1,0) ;;=The IENS '|IENS|' lacks a final comma. ;;^UTILITY(U,$J,.84,304,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,304,3,1,0) ;;=IENS^IENS. ;;^UTILITY(U,$J,.84,305,0) ;;=305^1^y^5 ;;^UTILITY(U,$J,.84,305,1,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,305,1,1,0) ;;=A root is used to identify an input array. But the array is empty. ;;^UTILITY(U,$J,.84,305,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,305,2,1,0) ;;=The array with a root of '|1|' has no data associated with it. ;;^UTILITY(U,$J,.84,305,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,305,3,1,0) ;;=1^Passed root. ;;^UTILITY(U,$J,.84,305,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,305,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,306,0) ;;=306^1^y^5 ;;^UTILITY(U,$J,.84,306,1,0) ;;=^^2^2^2940628^ ;;^UTILITY(U,$J,.84,306,1,1,0) ;;=When an IENS is used to explicitly identify a subfile, not a subfile ;;^UTILITY(U,$J,.84,306,1,2,0) ;;=entry, then the first comma-piece should be empty. This one wasn't. ;;^UTILITY(U,$J,.84,306,2,0) ;;=^^1^1^2941018^ ;;^UTILITY(U,$J,.84,306,2,1,0) ;;=The first comma-piece of IENS '|IENS|' should be empty. ;;^UTILITY(U,$J,.84,306,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,306,3,1,0) ;;=IENS^IENS. ;;^UTILITY(U,$J,.84,307,0) ;;=307^1^y^5 ;;^UTILITY(U,$J,.84,307,1,0) ;;=^^2^2^2940629^ ;;^UTILITY(U,$J,.84,307,1,1,0) ;;=One of the IENs in the IENS has been left out, leaving an empty ;;^UTILITY(U,$J,.84,307,1,2,0) ;;=comma-piece. ;;^UTILITY(U,$J,.84,307,2,0) ;;=^^1^1^2941018^ ;;^UTILITY(U,$J,.84,307,2,1,0) ;;=The IENS '|IENS|' has an empty comma-piece. ;;^UTILITY(U,$J,.84,307,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,307,3,1,0) ;;=IENS^IENS. ;;^UTILITY(U,$J,.84,308,0) ;;=308^1^y^5 ;;^UTILITY(U,$J,.84,308,1,0) ;;=^^3^3^2940629^ ;;^UTILITY(U,$J,.84,308,1,1,0) ;;=The syntax of this IENS is incorrect. For example, a record number may be ;;^UTILITY(U,$J,.84,308,1,2,0) ;;=illegal; or a subfile may be specified as already existing, but have a ;;^UTILITY(U,$J,.84,308,1,3,0) ;;=parent that is just now being added. DINIT006 DINIT006 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,308,2,0) ;;=^^1^1^2941018^ ;;^UTILITY(U,$J,.84,308,2,1,0) ;;=The IENS '|IENS|' is syntactically incorrect. ;;^UTILITY(U,$J,.84,308,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,308,3,1,0) ;;=IENS^IENS. ;;^UTILITY(U,$J,.84,309,0) ;;=309^1^^5 ;;^UTILITY(U,$J,.84,309,1,0) ;;=^^2^2^2931109^ ;;^UTILITY(U,$J,.84,309,1,1,0) ;;=A multiple field is involved. Either the root of the multiple or the ;;^UTILITY(U,$J,.84,309,1,2,0) ;;=necessary entry numbers are missing. ;;^UTILITY(U,$J,.84,309,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,309,2,1,0) ;;=There is insufficient information to identify an entry in a subfile. ;;^UTILITY(U,$J,.84,310,0) ;;=310^1^y^5 ;;^UTILITY(U,$J,.84,310,1,0) ;;=^^6^6^2940629^ ;;^UTILITY(U,$J,.84,310,1,1,0) ;;=Some of the IENS subscripts in this FDA conflict with each other. For ;;^UTILITY(U,$J,.84,310,1,2,0) ;;=example, one IENS may use the sequence number ?1 while another uses +1. ;;^UTILITY(U,$J,.84,310,1,3,0) ;;=This would be illegal because the sequence number 1 is being used to ;;^UTILITY(U,$J,.84,310,1,4,0) ;;=represent two different operations. Consult your documentation for an ;;^UTILITY(U,$J,.84,310,1,5,0) ;;=explanation of the various conflicts possible. The IENS returned with this ;;^UTILITY(U,$J,.84,310,1,6,0) ;;=error happens to be one of the IENS values in conflict. ;;^UTILITY(U,$J,.84,310,2,0) ;;=^^1^1^2941018^ ;;^UTILITY(U,$J,.84,310,2,1,0) ;;=The IENS '|IENS|' conflicts with the rest of the FDA. ;;^UTILITY(U,$J,.84,310,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,310,3,1,0) ;;=IENS^IENS. ;;^UTILITY(U,$J,.84,311,0) ;;=311^1^y^5 ;;^UTILITY(U,$J,.84,311,1,0) ;;=^^3^3^2940629^ ;;^UTILITY(U,$J,.84,311,1,1,0) ;;=Adding an entry to a file without including all required identifiers ;;^UTILITY(U,$J,.84,311,1,2,0) ;;=violates database integrity. The entry identified by this IENS lacks some ;;^UTILITY(U,$J,.84,311,1,3,0) ;;=of its required identifiers in the passed FDA. ;;^UTILITY(U,$J,.84,311,2,0) ;;=^^1^1^2941018^ ;;^UTILITY(U,$J,.84,311,2,1,0) ;;=The new record '|IENS|' lacks some required identifiers. ;;^UTILITY(U,$J,.84,311,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,311,3,1,0) ;;=IENS^IENS. ;;^UTILITY(U,$J,.84,312,0) ;;=312^1^y ;;^UTILITY(U,$J,.84,312,1,0) ;;=^^2^2^2950317^ ;;^UTILITY(U,$J,.84,312,1,1,0) ;;=All required identifiers must be present for a new entry to be filed. ;;^UTILITY(U,$J,.84,312,1,2,0) ;;=One or more of those fields is missing for the (sub)file. ;;^UTILITY(U,$J,.84,312,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,312,2,1,0) ;;=The list of fields is missing a required identifier for File #|FILE|. ;;^UTILITY(U,$J,.84,312,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,312,3,1,0) ;;=FILE^File or subfile #. ;;^UTILITY(U,$J,.84,313,0) ;;=313^1^^5 ;;^UTILITY(U,$J,.84,313,1,0) ;;=^^2^2^2960306^ ;;^UTILITY(U,$J,.84,313,1,1,0) ;;=The arrays that hold internal and external values must have different roots, ;;^UTILITY(U,$J,.84,313,1,2,0) ;;=but both FDAs have the same root. ;;^UTILITY(U,$J,.84,313,2,0) ;;=^^1^1^2960306^ ;;^UTILITY(U,$J,.84,313,2,1,0) ;;=The FDA root for external values is the same as the one for internal values. ;;^UTILITY(U,$J,.84,330,0) ;;=330^1^y^5 ;;^UTILITY(U,$J,.84,330,1,0) ;;=^^2^2^2941123^ ;;^UTILITY(U,$J,.84,330,1,1,0) ;;=The value passed by the calling application should be a certain data type, ;;^UTILITY(U,$J,.84,330,1,2,0) ;;=but according to our checks it is not. ;;^UTILITY(U,$J,.84,330,2,0) ;;=^^1^1^2941123^ ;;^UTILITY(U,$J,.84,330,2,1,0) ;;=The value '|1|' is not a valid |2|. ;;^UTILITY(U,$J,.84,330,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,330,3,1,0) ;;=1^Passed Value. ;;^UTILITY(U,$J,.84,330,3,2,0) ;;=2^Data Type. ;;^UTILITY(U,$J,.84,348,0) ;;=348^1^y^5 ;;^UTILITY(U,$J,.84,348,1,0) ;;=^^2^2^2940214^ ;;^UTILITY(U,$J,.84,348,1,1,0) ;;=The calling application passed us a variable pointer value. That value ;;^UTILITY(U,$J,.84,348,1,2,0) ;;=points to a file that does not exist, or that lacks a Header Node. ;;^UTILITY(U,$J,.84,348,2,0) ;;=^^2^2^2940214^ ;;^UTILITY(U,$J,.84,348,2,1,0) ;;=The passed value '|1|' points to a file that does not exist or lacks a ;;^UTILITY(U,$J,.84,348,2,2,0) ;;=Header Node. ;;^UTILITY(U,$J,.84,348,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,348,3,1,0) ;;=1^Passed Value. ;;^UTILITY(U,$J,.84,349,0) ;;=349^2^y^5 ;;^UTILITY(U,$J,.84,349,1,0) ;;=^^2^2^2940310^^^ ;;^UTILITY(U,$J,.84,349,1,1,0) ;;=Text used by the Replace...With editor ;;^UTILITY(U,$J,.84,349,1,2,0) ;;=Note: Dialog will be used with $$EZBLD^DIALOG call, only one text line!! ;;^UTILITY(U,$J,.84,349,2,0) ;;=^^1^1^2940310^^ ;;^UTILITY(U,$J,.84,349,2,1,0) ;;= String too long by |1| character(s)! ;;^UTILITY(U,$J,.84,349,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,349,3,1,0) ;;=1^Number of characters over the limit. ;;^UTILITY(U,$J,.84,350,0) ;;=350^2^^5 ;;^UTILITY(U,$J,.84,350,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,350,1,1,0) ;;=Message from the Replace...With editor. ;;^UTILITY(U,$J,.84,350,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,350,2,1,0) ;;= String too long! '^' to quit. ;;^UTILITY(U,$J,.84,351,0) ;;=351^1^y^5 ;;^UTILITY(U,$J,.84,351,1,0) ;;=^^4^4^2941021^ ;;^UTILITY(U,$J,.84,351,1,1,0) ;;=When passing an FDA to the Updater, any entries intended as Finding or ;;^UTILITY(U,$J,.84,351,1,2,0) ;;=LAYGO Finding nodes must include a .01 node that has the lookup value. ;;^UTILITY(U,$J,.84,351,1,3,0) ;;=This value need not be a legitimate .01 field value, but it must be a ;;^UTILITY(U,$J,.84,351,1,4,0) ;;=valid and unambiguous lookup value for the file. ;;^UTILITY(U,$J,.84,351,2,0) ;;=^^1^1^2941021^ ;;^UTILITY(U,$J,.84,351,2,1,0) ;;=FDA nodes for lookup '|IENS|' omit a .01 node with a lookup value. ;;^UTILITY(U,$J,.84,351,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,351,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,351,3,2,0) ;;=IENS^IENS Subscript for Finding or LAYGO Finding node. ;;^UTILITY(U,$J,.84,352,0) ;;=352^1^y^5 ;;^UTILITY(U,$J,.84,352,1,0) ;;=^^3^3^2980415^ ;;^UTILITY(U,$J,.84,352,1,1,0) ;;=When passing an FDA to the Updater, any entries intended as LAYGO or LAYGO ;;^UTILITY(U,$J,.84,352,1,2,0) ;;=Findings nodes must include a .01 node. Every new entry must have a value ;;^UTILITY(U,$J,.84,352,1,3,0) ;;=for the .01 field. ;;^UTILITY(U,$J,.84,352,2,0) ;;=^^1^1^2980415^ ;;^UTILITY(U,$J,.84,352,2,1,0) ;;=The new record '|IENS|' for file #|FILE| lacks a .01 field. DINIT007 DINIT007 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,352,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,352,3,1,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,352,3,2,0) ;;=IENS^IENS subscript for LAYGO or LAYGO Finding node. ;;^UTILITY(U,$J,.84,401,0) ;;=401^1^y^5 ;;^UTILITY(U,$J,.84,401,1,0) ;;=^^2^2^2990218^^^^ ;;^UTILITY(U,$J,.84,401,1,1,0) ;;=The specified file or subfile does not exist; it is not present in the ;;^UTILITY(U,$J,.84,401,1,2,0) ;;=data dictionary. ;;^UTILITY(U,$J,.84,401,2,0) ;;=^^1^1^2990218^^^^ ;;^UTILITY(U,$J,.84,401,2,1,0) ;;=File #|FILE| does not exist. ;;^UTILITY(U,$J,.84,401,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,401,3,1,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,402,0) ;;=402^1^y^5 ;;^UTILITY(U,$J,.84,402,1,0) ;;=^^2^2^2940316^^^^ ;;^UTILITY(U,$J,.84,402,1,1,0) ;;=The specified file or subfile lacks a valid global root; the global root ;;^UTILITY(U,$J,.84,402,1,2,0) ;;=is missing or is syntactically not valid. ;;^UTILITY(U,$J,.84,402,2,0) ;;=^^1^1^2940316^^^^ ;;^UTILITY(U,$J,.84,402,2,1,0) ;;=The global root of file #|FILE| is missing or not valid. ;;^UTILITY(U,$J,.84,402,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,402,3,1,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,402,3,2,0) ;;=ROOT^File root. ;;^UTILITY(U,$J,.84,402,3,3,0) ;;=IENS^IEN String. ;;^UTILITY(U,$J,.84,403,0) ;;=403^1^y^5 ;;^UTILITY(U,$J,.84,403,1,0) ;;=^^3^3^2940213^ ;;^UTILITY(U,$J,.84,403,1,1,0) ;;=The File Header Node, the top level of the data file as described in the ;;^UTILITY(U,$J,.84,403,1,2,0) ;;=Programmer Manual, must be present for FileMan to determine certain kinds ;;^UTILITY(U,$J,.84,403,1,3,0) ;;=of information about a file. ;;^UTILITY(U,$J,.84,403,2,0) ;;=^^1^1^2940213^ ;;^UTILITY(U,$J,.84,403,2,1,0) ;;=File #|FILE| lacks a Header Node. ;;^UTILITY(U,$J,.84,403,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,403,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,404,0) ;;=404^1^y^5 ;;^UTILITY(U,$J,.84,404,1,0) ;;=^^4^4^2940214^ ;;^UTILITY(U,$J,.84,404,1,1,0) ;;=We have identified a file by the global node of its data file, and found ;;^UTILITY(U,$J,.84,404,1,2,0) ;;=its Header Node. We needed to use the Header Node to identify the number ;;^UTILITY(U,$J,.84,404,1,3,0) ;;=of the file, but that piece of information is missing from the Header ;;^UTILITY(U,$J,.84,404,1,4,0) ;;=Node. ;;^UTILITY(U,$J,.84,404,2,0) ;;=^^1^1^2940214^ ;;^UTILITY(U,$J,.84,404,2,1,0) ;;=The File Header node of the file stored at |1| lacks a file number. ;;^UTILITY(U,$J,.84,404,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,404,3,1,0) ;;=1^File Root. ;;^UTILITY(U,$J,.84,405,0) ;;=405^1^y^5 ;;^UTILITY(U,$J,.84,405,1,0) ;;=^^2^2^2931110^^ ;;^UTILITY(U,$J,.84,405,1,1,0) ;;=The NO EDIT flag is set for the file. No instruction to override ;;^UTILITY(U,$J,.84,405,1,2,0) ;;=that flag is present. ;;^UTILITY(U,$J,.84,405,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,405,2,1,0) ;;=Entries in file |1| cannot be edited. ;;^UTILITY(U,$J,.84,405,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,405,3,1,0) ;;=1^File Name. ;;^UTILITY(U,$J,.84,405,3,2,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,406,0) ;;=406^1^y^5 ;;^UTILITY(U,$J,.84,406,1,0) ;;=^^2^2^2940317^ ;;^UTILITY(U,$J,.84,406,1,1,0) ;;=The data definition for a .01 field for the specified file is missing. ;;^UTILITY(U,$J,.84,406,1,2,0) ;;=This file is therefore not valid for most database operations. ;;^UTILITY(U,$J,.84,406,2,0) ;;=^^1^1^2940317^ ;;^UTILITY(U,$J,.84,406,2,1,0) ;;=File #|FILE| has no .01 field definition. ;;^UTILITY(U,$J,.84,406,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,406,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,407,0) ;;=407^1^^5 ;;^UTILITY(U,$J,.84,407,1,0) ;;=^^4^4^2940317^ ;;^UTILITY(U,$J,.84,407,1,1,0) ;;=The subfile number of a word processing field has been passed in the place ;;^UTILITY(U,$J,.84,407,1,2,0) ;;=of a file parameter. This is not acceptable. Although we implement word ;;^UTILITY(U,$J,.84,407,1,3,0) ;;=processing fields as independent files, we do not allow them to be treated ;;^UTILITY(U,$J,.84,407,1,4,0) ;;=as files for purposes of most database activities. ;;^UTILITY(U,$J,.84,407,2,0) ;;=^^1^1^2940317^ ;;^UTILITY(U,$J,.84,407,2,1,0) ;;=A word-processing field is not a file. ;;^UTILITY(U,$J,.84,407,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,407,3,1,0) ;;=FILE^Subfile # of word-processing field. ;;^UTILITY(U,$J,.84,408,0) ;;=408^1^y^5 ;;^UTILITY(U,$J,.84,408,1,0) ;;=^^2^2^2940715^ ;;^UTILITY(U,$J,.84,408,1,1,0) ;;=The file lacks a name. For subfiles, $P(^DD(file#,0),U) is null. For root ;;^UTILITY(U,$J,.84,408,1,2,0) ;;=files, $O(^DD(file#,0,"NM",""))="". ;;^UTILITY(U,$J,.84,408,2,0) ;;=^^1^1^2940715^ ;;^UTILITY(U,$J,.84,408,2,1,0) ;;=File# |FILE| lacks a name. ;;^UTILITY(U,$J,.84,408,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,408,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,409,0) ;;=409^1^y ;;^UTILITY(U,$J,.84,409,1,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,409,1,1,0) ;;=The indicated file does not exist in the FileMan database. ;;^UTILITY(U,$J,.84,409,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,409,2,1,0) ;;=File '|1|' could not be found. ;;^UTILITY(U,$J,.84,409,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,409,3,1,0) ;;=1^File name or number. ;;^UTILITY(U,$J,.84,410,0) ;;=410^1^y^5 ;;^UTILITY(U,$J,.84,410,1,0) ;;=^^1^1^2980602^^^ ;;^UTILITY(U,$J,.84,410,1,1,0) ;;=The global node is either missing or incomplete. ;;^UTILITY(U,$J,.84,410,2,0) ;;=^^1^1^2980602^ ;;^UTILITY(U,$J,.84,410,2,1,0) ;;=Missing or incomplete global node |1|. ;;^UTILITY(U,$J,.84,410,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,410,3,1,0) ;;=1^GLOBAL NODE ;;^UTILITY(U,$J,.84,420,0) ;;=420^1^y^5 ;;^UTILITY(U,$J,.84,420,1,0) ;;=^^4^4^2940628^ ;;^UTILITY(U,$J,.84,420,1,1,0) ;;=A cross reference was specified for look-up, but that cross reference ;;^UTILITY(U,$J,.84,420,1,2,0) ;;=does not exist on the file. The file has entries, but the index does not. ;;^UTILITY(U,$J,.84,420,1,3,0) ;;=This error implies nothing about whether the index is defined in the ;;^UTILITY(U,$J,.84,420,1,4,0) ;;=file's DD. ;;^UTILITY(U,$J,.84,420,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,420,2,1,0) ;;=There is no |1| index for File #|FILE|. ;;^UTILITY(U,$J,.84,420,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,420,3,1,0) ;;=1^Cross reference name. ;;^UTILITY(U,$J,.84,420,3,2,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,501,0) ;;=501^1^y^5 ;;^UTILITY(U,$J,.84,501,1,0) ;;=^^2^2^2940214^^^ DINIT008 DINIT008 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,501,1,1,0) ;;=A search of the data dictionary reveals that the field name or number ;;^UTILITY(U,$J,.84,501,1,2,0) ;;=passed does not exist in the specified file. ;;^UTILITY(U,$J,.84,501,2,0) ;;=^^1^1^2940214^^ ;;^UTILITY(U,$J,.84,501,2,1,0) ;;=File #|FILE| does not contain a field |1|. ;;^UTILITY(U,$J,.84,501,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,501,3,1,0) ;;=1^Field name or number. ;;^UTILITY(U,$J,.84,501,3,2,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,501,3,3,0) ;;=FIELD^Field number. ;;^UTILITY(U,$J,.84,502,0) ;;=502^1^y^5 ;;^UTILITY(U,$J,.84,502,1,0) ;;=^^3^3^2940715^ ;;^UTILITY(U,$J,.84,502,1,1,0) ;;=The field has been identified, but some key part of its definition is ;;^UTILITY(U,$J,.84,502,1,2,0) ;;=missing or corrupted. ^DD(file#,field#,0) may not be defined. Some key ;;^UTILITY(U,$J,.84,502,1,3,0) ;;=piece of that node may be missing. ;;^UTILITY(U,$J,.84,502,2,0) ;;=^^1^1^2940715^ ;;^UTILITY(U,$J,.84,502,2,1,0) ;;=Field# |FIELD| in file# |FILE| has a corrupted definition. ;;^UTILITY(U,$J,.84,502,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,502,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,502,3,2,0) ;;=FIELD^Field #. ;;^UTILITY(U,$J,.84,505,0) ;;=505^1^y^5 ;;^UTILITY(U,$J,.84,505,1,0) ;;=^^2^2^2931110^^ ;;^UTILITY(U,$J,.84,505,1,1,0) ;;=The field name passed is ambiguous. It cannot be determined to which field ;;^UTILITY(U,$J,.84,505,1,2,0) ;;=in the file it refers. ;;^UTILITY(U,$J,.84,505,2,0) ;;=^^1^1^2931116^^ ;;^UTILITY(U,$J,.84,505,2,1,0) ;;=There is more than one field named '|1|' in File #|FILE|. ;;^UTILITY(U,$J,.84,505,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,505,3,1,0) ;;=1^Field name. ;;^UTILITY(U,$J,.84,505,3,2,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,510,0) ;;=510^1^y^5 ;;^UTILITY(U,$J,.84,510,1,0) ;;=^^2^2^2940214^^^^ ;;^UTILITY(U,$J,.84,510,1,1,0) ;;=For some reason, the data type for the specified field cannot be determined. ;;^UTILITY(U,$J,.84,510,1,2,0) ;;=This may mean that the data dictionary is corrupted. ;;^UTILITY(U,$J,.84,510,2,0) ;;=^^1^1^2940214^^ ;;^UTILITY(U,$J,.84,510,2,1,0) ;;=The data type for Field #|FIELD| in File #|FILE| cannot be determined. ;;^UTILITY(U,$J,.84,510,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,510,3,1,0) ;;=FIELD^Field number. ;;^UTILITY(U,$J,.84,510,3,2,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,520,0) ;;=520^1^y^5 ;;^UTILITY(U,$J,.84,520,1,0) ;;=^^3^3^2931110^^ ;;^UTILITY(U,$J,.84,520,1,1,0) ;;=An incorrect kind of field is being processed. For example, filing is ;;^UTILITY(U,$J,.84,520,1,2,0) ;;=being attempted for a computed field or validation for a word ;;^UTILITY(U,$J,.84,520,1,3,0) ;;=processing field. ;;^UTILITY(U,$J,.84,520,2,0) ;;=^^1^1^2931110^^ ;;^UTILITY(U,$J,.84,520,2,1,0) ;;=A |1| field cannot be processed by this utility. ;;^UTILITY(U,$J,.84,520,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,520,3,1,0) ;;=1^Data type or other field characteristic (e.g., .001, DINUMed). ;;^UTILITY(U,$J,.84,520,3,2,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,520,3,3,0) ;;=FIELD^Field #. ;;^UTILITY(U,$J,.84,520,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,520,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,525,0) ;;=525^1^y ;;^UTILITY(U,$J,.84,525,1,0) ;;=^^2^2^2950317^ ;;^UTILITY(U,$J,.84,525,1,1,0) ;;=It is indicated that a subfile is involved (for example, by choosing a ;;^UTILITY(U,$J,.84,525,1,2,0) ;;=multiple field's field number), but no fields from the subfile are chosen. ;;^UTILITY(U,$J,.84,525,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,525,2,1,0) ;;=No fields are specified for subfile #|FILE|. ;;^UTILITY(U,$J,.84,525,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,525,3,1,0) ;;=FILE^Subfile #. ;;^UTILITY(U,$J,.84,537,0) ;;=537^1^y^5 ;;^UTILITY(U,$J,.84,537,1,0) ;;=^^7^7^2940213^ ;;^UTILITY(U,$J,.84,537,1,1,0) ;;=This error means that a certain field in a certain file has a data type of ;;^UTILITY(U,$J,.84,537,1,2,0) ;;=pointer, but something is wrong with the rest of the DD info needed to ;;^UTILITY(U,$J,.84,537,1,3,0) ;;=make that pointer work. For example, perhaps the number of the pointed to ;;^UTILITY(U,$J,.84,537,1,4,0) ;;=file, which should follow the P in the second ^-piece of the field ;;^UTILITY(U,$J,.84,537,1,5,0) ;;=descriptor node, is missing. Another problem would be if the global root ;;^UTILITY(U,$J,.84,537,1,6,0) ;;=of the pointed to file were missing from the field's definition; that ;;^UTILITY(U,$J,.84,537,1,7,0) ;;=should be found in the third ^-piece of the field descriptor. ;;^UTILITY(U,$J,.84,537,2,0) ;;=^^1^1^2940213^ ;;^UTILITY(U,$J,.84,537,2,1,0) ;;=Field #|FIELD| in File #|FILE| has a corrupted pointer definition. ;;^UTILITY(U,$J,.84,537,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,537,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,537,3,2,0) ;;=FIELD^Field #. ;;^UTILITY(U,$J,.84,601,0) ;;=601^1^^5 ;;^UTILITY(U,$J,.84,601,1,0) ;;=^^1^1^2940426^ ;;^UTILITY(U,$J,.84,601,1,1,0) ;;=The entry identified by FILE and IENS does not exist in the database. ;;^UTILITY(U,$J,.84,601,2,0) ;;=^^1^1^2940426^^ ;;^UTILITY(U,$J,.84,601,2,1,0) ;;=The entry does not exist. ;;^UTILITY(U,$J,.84,601,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,601,3,1,0) ;;=FILE^File or subfile #. (external only) ;;^UTILITY(U,$J,.84,601,3,2,0) ;;=IENS^IEN string (external only) ;;^UTILITY(U,$J,.84,602,0) ;;=602^1^^5 ;;^UTILITY(U,$J,.84,602,1,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,602,1,1,0) ;;=There is a -9 node for the entry; therefore, the entry cannot be accessed. ;;^UTILITY(U,$J,.84,602,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,602,2,1,0) ;;=The entry is not available for editing. ;;^UTILITY(U,$J,.84,602,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,602,3,1,0) ;;=FILE^File or subfile #. (external only) ;;^UTILITY(U,$J,.84,602,3,2,0) ;;=IENS^IEN string. (external only) ;;^UTILITY(U,$J,.84,603,0) ;;=603^1^y^5 ;;^UTILITY(U,$J,.84,603,1,0) ;;=^^2^2^2940214^ ;;^UTILITY(U,$J,.84,603,1,1,0) ;;=A specific entry in a specific file lacks a value for a required field. ;;^UTILITY(U,$J,.84,603,1,2,0) ;;=This error message returns which field is missing. ;;^UTILITY(U,$J,.84,603,2,0) ;;=^^1^1^2940214^ ;;^UTILITY(U,$J,.84,603,2,1,0) ;;=Entry #|1| in File #|FILE| lacks the required Field #|FIELD|. ;;^UTILITY(U,$J,.84,603,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,603,3,1,0) ;;=1^Entry #. ;;^UTILITY(U,$J,.84,603,3,2,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,603,3,3,0) ;;=FIELD^Field #. DINIT009 DINIT009 ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,630,0) ;;=630^1^y^5 ;;^UTILITY(U,$J,.84,630,1,0) ;;=^^2^2^2941128^ ;;^UTILITY(U,$J,.84,630,1,1,0) ;;=The database is corrupted. The value for a specific field in one entry ;;^UTILITY(U,$J,.84,630,1,2,0) ;;=should be a certain data type, but it is not. ;;^UTILITY(U,$J,.84,630,2,0) ;;=^^2^2^2941128^ ;;^UTILITY(U,$J,.84,630,2,1,0) ;;=In Entry #|1| of File #|FILE|, the value '|2|' for Field #|FIELD| is not a ;;^UTILITY(U,$J,.84,630,2,2,0) ;;=valid |3|. ;;^UTILITY(U,$J,.84,630,3,0) ;;=^.845^5^5 ;;^UTILITY(U,$J,.84,630,3,1,0) ;;=1^Entry #. ;;^UTILITY(U,$J,.84,630,3,2,0) ;;=2^Field Value. ;;^UTILITY(U,$J,.84,630,3,3,0) ;;=3^Data Type. ;;^UTILITY(U,$J,.84,630,3,4,0) ;;=FIELD^Field #. ;;^UTILITY(U,$J,.84,630,3,5,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,648,0) ;;=648^1^y^5 ;;^UTILITY(U,$J,.84,648,1,0) ;;=^^3^3^2940214^ ;;^UTILITY(U,$J,.84,648,1,1,0) ;;=The database is corrupted. In a specific variable pointer field of a ;;^UTILITY(U,$J,.84,648,1,2,0) ;;=certain entry, the field's value points to a file that either does not ;;^UTILITY(U,$J,.84,648,1,3,0) ;;=exist or that lacks a Header Node. ;;^UTILITY(U,$J,.84,648,2,0) ;;=^^2^2^2940214^ ;;^UTILITY(U,$J,.84,648,2,1,0) ;;=In Entry #|1| of File #|FILE|, the value '|2|' for Field #|FIELD| points ;;^UTILITY(U,$J,.84,648,2,2,0) ;;=to a file that does not exist or lacks a Header Node. ;;^UTILITY(U,$J,.84,648,3,0) ;;=^.845^4^4 ;;^UTILITY(U,$J,.84,648,3,1,0) ;;=1^Entry #. ;;^UTILITY(U,$J,.84,648,3,2,0) ;;=2^Field Value. ;;^UTILITY(U,$J,.84,648,3,3,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,648,3,4,0) ;;=FIELD^Field #. ;;^UTILITY(U,$J,.84,701,0) ;;=701^1^y^5 ;;^UTILITY(U,$J,.84,701,1,0) ;;=^^3^3^2931109^ ;;^UTILITY(U,$J,.84,701,1,1,0) ;;=The value is invalid. Possible causes include: value did not pass input ;;^UTILITY(U,$J,.84,701,1,2,0) ;;=transform, value for a pointer or variable pointer field cannot be found in ;;^UTILITY(U,$J,.84,701,1,3,0) ;;=the pointed-to file, a screen was not passed. ;;^UTILITY(U,$J,.84,701,2,0) ;;=^^1^1^2931110^^ ;;^UTILITY(U,$J,.84,701,2,1,0) ;;=The value '|3|' for field |1| in file |2| is not valid. ;;^UTILITY(U,$J,.84,701,3,0) ;;=^.845^6^6 ;;^UTILITY(U,$J,.84,701,3,1,0) ;;=1^Field name. ;;^UTILITY(U,$J,.84,701,3,2,0) ;;=2^File name. ;;^UTILITY(U,$J,.84,701,3,3,0) ;;=3^Value that was found to be invalid. ;;^UTILITY(U,$J,.84,701,3,4,0) ;;=FIELD^Field number. (external only) ;;^UTILITY(U,$J,.84,701,3,5,0) ;;=FILE^File number. (external only) ;;^UTILITY(U,$J,.84,701,3,6,0) ;;=IENS^IEN string identifying entry with invalid value. (external only, sometimes returned) ;;^UTILITY(U,$J,.84,701,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,701,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,703,0) ;;=703^1^y^5 ;;^UTILITY(U,$J,.84,703,1,0) ;;=^^1^1^2940317^ ;;^UTILITY(U,$J,.84,703,1,1,0) ;;=The value passed cannot be found in the indicated file using $$FIND1^DIC. ;;^UTILITY(U,$J,.84,703,2,0) ;;=^^1^1^2940317^ ;;^UTILITY(U,$J,.84,703,2,1,0) ;;=The value '|1|' cannot be found in file #|FILE|. ;;^UTILITY(U,$J,.84,703,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,703,3,1,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,703,3,2,0) ;;=IENS^IEN String. ;;^UTILITY(U,$J,.84,703,3,3,0) ;;=1^Lookup Value. ;;^UTILITY(U,$J,.84,710,0) ;;=710^1^y^5 ;;^UTILITY(U,$J,.84,710,1,0) ;;=^^2^2^2931123^^^^ ;;^UTILITY(U,$J,.84,710,1,1,0) ;;=The data dictionary specifies that the field is uneditable. Data already ;;^UTILITY(U,$J,.84,710,1,2,0) ;;=exists in the field. It cannot be changed. ;;^UTILITY(U,$J,.84,710,2,0) ;;=^^1^1^2931110^^^ ;;^UTILITY(U,$J,.84,710,2,1,0) ;;=Data in Field #|FIELD| in File #|FILE| cannot be edited. ;;^UTILITY(U,$J,.84,710,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,710,3,1,0) ;;=FIELD^Field number. ;;^UTILITY(U,$J,.84,710,3,2,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,712,0) ;;=712^1^y^5 ;;^UTILITY(U,$J,.84,712,1,0) ;;=^^3^3^2931109^ ;;^UTILITY(U,$J,.84,712,1,1,0) ;;=The value of a field cannot be deleted either because it is a required ;;^UTILITY(U,$J,.84,712,1,2,0) ;;=field, because it is the .01 of a file, or because the test in the "DEL" ;;^UTILITY(U,$J,.84,712,1,3,0) ;;=node was not passed. ;;^UTILITY(U,$J,.84,712,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,712,2,1,0) ;;=The value of field |1| in file |2| cannot be deleted. ;;^UTILITY(U,$J,.84,712,3,0) ;;=^.845^4^4 ;;^UTILITY(U,$J,.84,712,3,1,0) ;;=1^Field name. ;;^UTILITY(U,$J,.84,712,3,2,0) ;;=2^File name. ;;^UTILITY(U,$J,.84,712,3,3,0) ;;=FIELD^Field number. (external only) ;;^UTILITY(U,$J,.84,712,3,4,0) ;;=FILE^File number. (external only) ;;^UTILITY(U,$J,.84,712,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,712,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,714,0) ;;=714^1^y^5 ;;^UTILITY(U,$J,.84,714,1,0) ;;=^^2^2^2931109^^ ;;^UTILITY(U,$J,.84,714,1,1,0) ;;=The field uses $Piece storage and the data contains an '^'. The data ;;^UTILITY(U,$J,.84,714,1,2,0) ;;=cannot be filed. ;;^UTILITY(U,$J,.84,714,2,0) ;;=^^1^1^2931109^^ ;;^UTILITY(U,$J,.84,714,2,1,0) ;;=Data for Field |1| in File |2| contains an '^'. ;;^UTILITY(U,$J,.84,714,3,0) ;;=^.845^4^4 ;;^UTILITY(U,$J,.84,714,3,1,0) ;;=1^Field name. ;;^UTILITY(U,$J,.84,714,3,2,0) ;;=2^File name. ;;^UTILITY(U,$J,.84,714,3,3,0) ;;=FILE^File number. (external only) ;;^UTILITY(U,$J,.84,714,3,4,0) ;;=FIELD^Field number. (external only) ;;^UTILITY(U,$J,.84,714,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,714,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,716,0) ;;=716^1^y^5 ;;^UTILITY(U,$J,.84,716,1,0) ;;=^^2^2^2931109^ ;;^UTILITY(U,$J,.84,716,1,1,0) ;;=Data being filed is too long for the field. Specifically, this occurs ;;^UTILITY(U,$J,.84,716,1,2,0) ;;=when data of the wrong length is being filed in a $Extract (Em,n) field. ;;^UTILITY(U,$J,.84,716,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,716,2,1,0) ;;=Data for field |1| in file |2| is too long. ;;^UTILITY(U,$J,.84,716,3,0) ;;=^.845^4^4 ;;^UTILITY(U,$J,.84,716,3,1,0) ;;=1^Field name. ;;^UTILITY(U,$J,.84,716,3,2,0) ;;=2^File name. ;;^UTILITY(U,$J,.84,716,3,3,0) ;;=FIELD^Field number. (external only) ;;^UTILITY(U,$J,.84,716,3,4,0) ;;=FILE^File number. (external only) ;;^UTILITY(U,$J,.84,716,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,716,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,720,0) ;;=720^1^^5 ;;^UTILITY(U,$J,.84,720,1,0) ;;=^^2^2^2931110^^ ;;^UTILITY(U,$J,.84,720,1,1,0) ;;=The lookup for a pointer fails. This is an error only when DINIT00A DINIT00A ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,720,1,2,0) ;;=LAYGO is not allowed. ;;^UTILITY(U,$J,.84,720,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,720,2,1,0) ;;=The value cannot be found in the pointed-to file. ;;^UTILITY(U,$J,.84,720,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,720,3,1,0) ;;=FILE^File number -- the number of the file in which the pointer field exists. ;;^UTILITY(U,$J,.84,720,3,2,0) ;;=FIELD^Field number of the pointer field. ;;^UTILITY(U,$J,.84,726,0) ;;=726^1^y^5 ;;^UTILITY(U,$J,.84,726,1,0) ;;=^^2^2^2931110^ ;;^UTILITY(U,$J,.84,726,1,1,0) ;;=There is an attempt to take an action with word processing data, but ;;^UTILITY(U,$J,.84,726,1,2,0) ;;=the specified field is not a word processing field. ;;^UTILITY(U,$J,.84,726,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,726,2,1,0) ;;=Field #|FIELD| in File #|FILE| is not a word processing field. ;;^UTILITY(U,$J,.84,726,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,726,3,1,0) ;;=FIELD^Field number. ;;^UTILITY(U,$J,.84,726,3,2,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,730,0) ;;=730^1^y^5 ;;^UTILITY(U,$J,.84,730,1,0) ;;=^^2^2^2941128^ ;;^UTILITY(U,$J,.84,730,1,1,0) ;;=Based on how the data type is defined by a specific field in a specific ;;^UTILITY(U,$J,.84,730,1,2,0) ;;=file, the passed value is not valid. ;;^UTILITY(U,$J,.84,730,2,0) ;;=^^2^2^2941128^ ;;^UTILITY(U,$J,.84,730,2,1,0) ;;=The value '|1|' is not a valid |2| according to the definition in Field ;;^UTILITY(U,$J,.84,730,2,2,0) ;;=#|FIELD| of File #|FILE|. ;;^UTILITY(U,$J,.84,730,3,0) ;;=^.845^4^4 ;;^UTILITY(U,$J,.84,730,3,1,0) ;;=1^Passed Value. ;;^UTILITY(U,$J,.84,730,3,2,0) ;;=2^Data Type. ;;^UTILITY(U,$J,.84,730,3,3,0) ;;=FIELD^Field #. ;;^UTILITY(U,$J,.84,730,3,4,0) ;;=FILE^File #. ;;^UTILITY(U,$J,.84,740,0) ;;=740^1^y^5 ;;^UTILITY(U,$J,.84,740,1,0) ;;=^^5^5^2980407^^^^ ;;^UTILITY(U,$J,.84,740,1,1,0) ;;=When one or more fields are declared as a key for a file, there cannot be ;;^UTILITY(U,$J,.84,740,1,2,0) ;;=duplicate values in those field(s) for entries in the file. The values ;;^UTILITY(U,$J,.84,740,1,3,0) ;;=being passed for validation, when combined with values for unchanging ;;^UTILITY(U,$J,.84,740,1,4,0) ;;=fields in the entry if necessary, create a duplicate key. The changes ;;^UTILITY(U,$J,.84,740,1,5,0) ;;=destroy the integrity of the key. Therefore, they are invalid. ;;^UTILITY(U,$J,.84,740,2,0) ;;=^^1^1^2980407^ ;;^UTILITY(U,$J,.84,740,2,1,0) ;;=New values are invalid because they create a duplicate Key '|1|' for the |2| file. ;;^UTILITY(U,$J,.84,740,3,0) ;;=^.845^5^5 ;;^UTILITY(U,$J,.84,740,3,1,0) ;;=1^Name of Key. ;;^UTILITY(U,$J,.84,740,3,2,0) ;;=2^Name of affected file. ;;^UTILITY(U,$J,.84,740,3,3,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,740,3,4,0) ;;=KEY^IEN of the invalid key. ;;^UTILITY(U,$J,.84,740,3,5,0) ;;=IENS^IENS of record with invalid key. ;;^UTILITY(U,$J,.84,741,0) ;;=741^1^^5 ;;^UTILITY(U,$J,.84,741,1,0) ;;=^^3^3^2981208^ ;;^UTILITY(U,$J,.84,741,1,1,0) ;;=Error message generated when user is adding a new entry using classic ;;^UTILITY(U,$J,.84,741,1,2,0) ;;=FileMan lookup ^DIC routines, and either key values are not entered, or ;;^UTILITY(U,$J,.84,741,1,3,0) ;;=they create a duplicate key. ;;^UTILITY(U,$J,.84,741,2,0) ;;=^^1^1^2981208^ ;;^UTILITY(U,$J,.84,741,2,1,0) ;;=Either key values are null, or they create a duplicate key. ;;^UTILITY(U,$J,.84,741,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,741,5,1,0) ;;=DICN1^A ;;^UTILITY(U,$J,.84,742,0) ;;=742^1^y^5 ;;^UTILITY(U,$J,.84,742,1,0) ;;=^^2^2^2980407^^^^ ;;^UTILITY(U,$J,.84,742,1,1,0) ;;=Every field in a key must have a value. The incoming data cannot delete ;;^UTILITY(U,$J,.84,742,1,2,0) ;;=the value for any field in a key. ;;^UTILITY(U,$J,.84,742,2,0) ;;=^^1^1^2980407^^ ;;^UTILITY(U,$J,.84,742,2,1,0) ;;=The value of field |1| in the |2| file cannot be deleted because that field is part of the '|3|' key. ;;^UTILITY(U,$J,.84,742,3,0) ;;=^.845^6^6 ;;^UTILITY(U,$J,.84,742,3,1,0) ;;=1^Field name ;;^UTILITY(U,$J,.84,742,3,2,0) ;;=2^File name ;;^UTILITY(U,$J,.84,742,3,3,0) ;;=3^Key name ;;^UTILITY(U,$J,.84,742,3,4,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,742,3,5,0) ;;=FIELD^Field number. ;;^UTILITY(U,$J,.84,742,3,6,0) ;;=IENS^IENS ;;^UTILITY(U,$J,.84,744,0) ;;=744^1^y^5 ;;^UTILITY(U,$J,.84,744,1,0) ;;=^^2^2^2980413^^^^ ;;^UTILITY(U,$J,.84,744,1,1,0) ;;=Every field that is in a key must have a value. No value for this field ;;^UTILITY(U,$J,.84,744,1,2,0) ;;=exists. ;;^UTILITY(U,$J,.84,744,2,0) ;;=^^1^1^2980407^^^^ ;;^UTILITY(U,$J,.84,744,2,1,0) ;;=Field |1| is part of Key '|2|', but the field has not been assigned a value. ;;^UTILITY(U,$J,.84,744,3,0) ;;=^.845^5^5 ;;^UTILITY(U,$J,.84,744,3,1,0) ;;=1^Field name. ;;^UTILITY(U,$J,.84,744,3,2,0) ;;=2^Key name. ;;^UTILITY(U,$J,.84,744,3,3,0) ;;=FIELD^Field number. ;;^UTILITY(U,$J,.84,744,3,4,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,744,3,5,0) ;;=IENS^IENS of record with incomplete key. ;;^UTILITY(U,$J,.84,746,0) ;;=746^1^y^5 ;;^UTILITY(U,$J,.84,746,1,0) ;;=^^2^2^2980415^^^^ ;;^UTILITY(U,$J,.84,746,1,1,0) ;;=A lookup node is present in the FDA, but no Primary Key fields are ;;^UTILITY(U,$J,.84,746,1,2,0) ;;=provided. ;;^UTILITY(U,$J,.84,746,2,0) ;;=^^1^1^2980415^ ;;^UTILITY(U,$J,.84,746,2,1,0) ;;=No fields in Primary Key '|1|' have been provided in the FDA to look up '|IENS|' in the |2| file. ;;^UTILITY(U,$J,.84,746,3,0) ;;=^.845^5^5 ;;^UTILITY(U,$J,.84,746,3,1,0) ;;=1^Key name. ;;^UTILITY(U,$J,.84,746,3,2,0) ;;=2^File name. ;;^UTILITY(U,$J,.84,746,3,3,0) ;;=IENS^IENS of lookup node. ;;^UTILITY(U,$J,.84,746,3,4,0) ;;=KEY^Key number. ;;^UTILITY(U,$J,.84,746,3,5,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,810,0) ;;=810^1^^5 ;;^UTILITY(U,$J,.84,810,1,0) ;;=^^3^3^2931109^ ;;^UTILITY(U,$J,.84,810,1,1,0) ;;=A %ZOSF node required to perform a function does not exist. The ;;^UTILITY(U,$J,.84,810,1,2,0) ;;=VA FileMan Programmer's Manual contains a complete list of %ZOSF ;;^UTILITY(U,$J,.84,810,1,3,0) ;;=nodes. ;;^UTILITY(U,$J,.84,810,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,810,2,1,0) ;;=A necessary %ZOSF node does not exist on your system. ;;^UTILITY(U,$J,.84,820,0) ;;=820^1^^5 ;;^UTILITY(U,$J,.84,820,1,0) ;;=^^3^3^2931109^ ;;^UTILITY(U,$J,.84,820,1,1,0) ;;=The ZSAVE CODE field (#2619) in the MUMPS Operating System file (#.7) DINIT00B DINIT00B ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,820,1,2,0) ;;=is empty for the operating system being used. It is impossible to perform ;;^UTILITY(U,$J,.84,820,1,3,0) ;;=functions such as compiling templates or cross references. ;;^UTILITY(U,$J,.84,820,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,820,2,1,0) ;;=There is no way to save routines on the system. ;;^UTILITY(U,$J,.84,840,0) ;;=840^1^y^5 ;;^UTILITY(U,$J,.84,840,1,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,840,1,1,0) ;;=The Terminal Type file does not have an entry that matches IOST(0). ;;^UTILITY(U,$J,.84,840,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,840,2,1,0) ;;=Terminal type '|1|' cannot be found in the Terminal Type file. ;;^UTILITY(U,$J,.84,840,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,840,3,1,0) ;;=1^Terminal type as identified by IOST(0). ;;^UTILITY(U,$J,.84,842,0) ;;=842^1^y^5 ;;^UTILITY(U,$J,.84,842,1,0) ;;=^^2^2^2931110^^ ;;^UTILITY(U,$J,.84,842,1,1,0) ;;=The field in the Terminal Type field that contains the specified ;;^UTILITY(U,$J,.84,842,1,2,0) ;;=characteristic of the terminal is null. ;;^UTILITY(U,$J,.84,842,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,842,2,1,0) ;;=|1| cannot be found for Terminal Type |2|. ;;^UTILITY(U,$J,.84,842,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,842,3,1,0) ;;=1^Terminal Type characteristic. ;;^UTILITY(U,$J,.84,842,3,2,0) ;;=2^Terminal type. ;;^UTILITY(U,$J,.84,845,0) ;;=845^1^^5 ;;^UTILITY(U,$J,.84,845,1,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,845,1,1,0) ;;=A %ZIS call with IOP set to "HOME" returns POP. ;;^UTILITY(U,$J,.84,845,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,845,2,1,0) ;;=The characteristics for the HOME device cannot be obtained. ;;^UTILITY(U,$J,.84,1300,0) ;;=1300^1^y^5 ;;^UTILITY(U,$J,.84,1300,1,0) ;;=^^1^1^2970210^^ ;;^UTILITY(U,$J,.84,1300,1,1,0) ;;=The entry encountered an error during subfile filing. ;;^UTILITY(U,$J,.84,1300,2,0) ;;=^^1^1^2970210^ ;;^UTILITY(U,$J,.84,1300,2,1,0) ;;=The entry encountered an error during subfile filing. ;;^UTILITY(U,$J,.84,1300,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1300,3,1,0) ;;=IEN^Entry Number ;;^UTILITY(U,$J,.84,1500,0) ;;=1500^1^y^5 ;;^UTILITY(U,$J,.84,1500,1,0) ;;=^^2^2^2931112^ ;;^UTILITY(U,$J,.84,1500,1,1,0) ;;=Error given for unsuccessful lookup of search template in BY(0) input ;;^UTILITY(U,$J,.84,1500,1,2,0) ;;=variable. ;;^UTILITY(U,$J,.84,1500,2,0) ;;=^^2^2^2931112^ ;;^UTILITY(U,$J,.84,1500,2,1,0) ;;=Search template |1| in BY(0) variable cannot be found, ;;^UTILITY(U,$J,.84,1500,2,2,0) ;;=is for the wrong file, or has no list of search results. ;;^UTILITY(U,$J,.84,1500,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1500,3,1,0) ;;=1^Name of search template in input variable BY(0). ;;^UTILITY(U,$J,.84,1500,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,1500,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,1500,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,1501,0) ;;=1501^1^^5 ;;^UTILITY(U,$J,.84,1501,1,0) ;;=^^2^2^2931116^^^ ;;^UTILITY(U,$J,.84,1501,1,1,0) ;;=Error message shown to user when no code was generated during compilation ;;^UTILITY(U,$J,.84,1501,1,2,0) ;;=of SORT TEMPLATES. ;;^UTILITY(U,$J,.84,1501,2,0) ;;=^^1^1^2931116^ ;;^UTILITY(U,$J,.84,1501,2,1,0) ;;=There is no code to save for this compiled Sort Template routine. ;;^UTILITY(U,$J,.84,1501,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,1501,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,1502,0) ;;=1502^1^^5 ;;^UTILITY(U,$J,.84,1502,1,0) ;;=^^3^3^2931116^^^ ;;^UTILITY(U,$J,.84,1502,1,1,0) ;;=Error message notifying the user that there are no more available ;;^UTILITY(U,$J,.84,1502,1,2,0) ;;=routine numbers for compiled sort template routines. This should ;;^UTILITY(U,$J,.84,1502,1,3,0) ;;=never happen, since routine numbers are re-used. ;;^UTILITY(U,$J,.84,1502,2,0) ;;=^^2^2^2940909^ ;;^UTILITY(U,$J,.84,1502,2,1,0) ;;=All available routine numbers for compilation are in use. ;;^UTILITY(U,$J,.84,1502,2,2,0) ;;=IRM needs to run ENRLS^DIOZ() to release the routine numbers. ;;^UTILITY(U,$J,.84,1502,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,1502,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,1503,0) ;;=1503^1^y^5 ;;^UTILITY(U,$J,.84,1503,1,0) ;;=^^1^1^2931116^^^^ ;;^UTILITY(U,$J,.84,1503,1,1,0) ;;=Warn user to shorten compiled cross-reference routine name. ;;^UTILITY(U,$J,.84,1503,2,0) ;;=^^1^1^2931116^^ ;;^UTILITY(U,$J,.84,1503,2,1,0) ;;= routine name is too long. Compilation has been aborted. ;;^UTILITY(U,$J,.84,1503,5,0) ;;=^.841^6^6 ;;^UTILITY(U,$J,.84,1503,5,1,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,1503,5,2,0) ;;=DIEZ^EN ;;^UTILITY(U,$J,.84,1503,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,1503,5,4,0) ;;=DIKZ^EN ;;^UTILITY(U,$J,.84,1503,5,5,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,1503,5,6,0) ;;=DIPZ^EN ;;^UTILITY(U,$J,.84,1504,0) ;;=1504^1^^5 ;;^UTILITY(U,$J,.84,1504,1,0) ;;=^^2^2^2940316^ ;;^UTILITY(U,$J,.84,1504,1,1,0) ;;=If doing Transfer/Merge of a single record from one file to another, and ;;^UTILITY(U,$J,.84,1504,1,2,0) ;;=the .01 field names do not match, we cannot do the transfer/merge. ;;^UTILITY(U,$J,.84,1504,2,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,1504,2,1,0) ;;=No matching .01 field names found. Transfer/Merge cannot be done. ;;^UTILITY(U,$J,.84,1504,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,1504,5,1,0) ;;=DIT^TRNMRG ;;^UTILITY(U,$J,.84,1610,0) ;;=1610^1^^5 ;;^UTILITY(U,$J,.84,1610,1,0) ;;=^^2^2^2940223^^ ;;^UTILITY(U,$J,.84,1610,1,1,0) ;;=A question mark or, in the case of a variable pointer field, a .? ;;^UTILITY(U,$J,.84,1610,1,2,0) ;;=was passed to the Validator. The Validator does not process help requests. ;;^UTILITY(U,$J,.84,1610,2,0) ;;=^^1^1^2940223^^^ ;;^UTILITY(U,$J,.84,1610,2,1,0) ;;=Help is being requested from the Validator utility. ;;^UTILITY(U,$J,.84,1610,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,1610,3,1,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,1610,3,2,0) ;;=FIELD^Field number. ;;^UTILITY(U,$J,.84,1610,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,1610,5,1,0) ;;=DIE^FILE ;;^UTILITY(U,$J,.84,1700,0) ;;=1700^1^y^5 ;;^UTILITY(U,$J,.84,1700,1,0) ;;=^^1^1^2940310^^ ;;^UTILITY(U,$J,.84,1700,1,1,0) ;;=Generic message for Silent DIFROM ;;^UTILITY(U,$J,.84,1700,2,0) ;;=^^1^1^2940310^^ ;;^UTILITY(U,$J,.84,1700,2,1,0) ;;=Error: |1|. ;;^UTILITY(U,$J,.84,1700,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1700,3,1,0) ;;=1^Generic message ;;^UTILITY(U,$J,.84,1701,0) ;;=1701^1^y^5 ;;^UTILITY(U,$J,.84,1701,1,0) ;;=^^1^1^2940912^^^ DINIT00C DINIT00C ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,1701,1,1,0) ;;=Transport structure does not contain SPECIFIC ELEMENT. ;;^UTILITY(U,$J,.84,1701,2,0) ;;=^^1^1^2940912^^^ ;;^UTILITY(U,$J,.84,1701,2,1,0) ;;=Transport structure does not contain |1|. ;;^UTILITY(U,$J,.84,1701,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1701,3,1,0) ;;=1^Describes missing element in transport structure. ;;^UTILITY(U,$J,.84,1805,0) ;;=1805^1^ ;;^UTILITY(U,$J,.84,1805,1,0) ;;=^^2^2^2950317^ ;;^UTILITY(U,$J,.84,1805,1,1,0) ;;=For some reason a record or a field in a record could not be filed. The cause ;;^UTILITY(U,$J,.84,1805,1,2,0) ;;=of the error should be present in another message. ;;^UTILITY(U,$J,.84,1805,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1805,2,1,0) ;;=An error occurred during the actual filing of data into the FileMan database. ;;^UTILITY(U,$J,.84,1810,0) ;;=1810^1^y ;;^UTILITY(U,$J,.84,1810,1,0) ;;=^^3^3^2950317^ ;;^UTILITY(U,$J,.84,1810,1,1,0) ;;=The attempt to move data from a host file into the MUMPS environment ;;^UTILITY(U,$J,.84,1810,1,2,0) ;;=failed. A possible cause is that the host file does not exist in the ;;^UTILITY(U,$J,.84,1810,1,3,0) ;;=path specified. ;;^UTILITY(U,$J,.84,1810,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1810,2,1,0) ;;=The data from host file '|1|' could not be moved into a FileMan file. ;;^UTILITY(U,$J,.84,1810,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1810,3,1,0) ;;=1^Host file name. ;;^UTILITY(U,$J,.84,1812,0) ;;=1812^1^y ;;^UTILITY(U,$J,.84,1812,1,0) ;;=^^3^3^2950317^ ;;^UTILITY(U,$J,.84,1812,1,1,0) ;;=A host file was located; however, no data was present in it. This error ;;^UTILITY(U,$J,.84,1812,1,2,0) ;;=will also occur if the only "data" is the designation of file and fields ;;^UTILITY(U,$J,.84,1812,1,3,0) ;;=with no actual data present to file. ;;^UTILITY(U,$J,.84,1812,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1812,2,1,0) ;;=The host file, |1|, contains no data to import. ;;^UTILITY(U,$J,.84,1812,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1812,3,1,0) ;;=1^Host file name. ;;^UTILITY(U,$J,.84,1820,0) ;;=1820^1^y^5 ;;^UTILITY(U,$J,.84,1820,1,0) ;;=^^2^2^2950317^ ;;^UTILITY(U,$J,.84,1820,1,1,0) ;;=The foreign format name that was passed could not be found in the Foreign Format ;;^UTILITY(U,$J,.84,1820,1,2,0) ;;=file. ;;^UTILITY(U,$J,.84,1820,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1820,2,1,0) ;;=There is no Foreign Format named '|1|'. ;;^UTILITY(U,$J,.84,1820,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1820,3,1,0) ;;=1^Foreign format. ;;^UTILITY(U,$J,.84,1821,0) ;;=1821^1^ ;;^UTILITY(U,$J,.84,1821,1,0) ;;=^^3^3^2960913^^^^ ;;^UTILITY(U,$J,.84,1821,1,1,0) ;;=The format of the imported data must either be delimited by a specified ;;^UTILITY(U,$J,.84,1821,1,2,0) ;;=character or be fixed length. Either no format is specified ;;^UTILITY(U,$J,.84,1821,1,3,0) ;;=or it is both fixed length and delimited or it is neither. ;;^UTILITY(U,$J,.84,1821,2,0) ;;=^^2^2^2960913^^^^ ;;^UTILITY(U,$J,.84,1821,2,1,0) ;;=The format of imported data must be fixed length or have a delimiter. ;;^UTILITY(U,$J,.84,1821,2,2,0) ;;=You may also specify a Foreign Format. ;;^UTILITY(U,$J,.84,1822,0) ;;=1822^1^ ;;^UTILITY(U,$J,.84,1822,1,0) ;;=^^2^2^2960719^^ ;;^UTILITY(U,$J,.84,1822,1,1,0) ;;=For a fixed length import, the length data for a field is impossible. For ;;^UTILITY(U,$J,.84,1822,1,2,0) ;;=example, the length is zero or no length is given. ;;^UTILITY(U,$J,.84,1822,2,0) ;;=^^1^1^2960719^^ ;;^UTILITY(U,$J,.84,1822,2,1,0) ;;=The length of a field is missing or incorrect. ;;^UTILITY(U,$J,.84,1831,0) ;;=1831^1^^5 ;;^UTILITY(U,$J,.84,1831,1,0) ;;=^^6^6^2960919^ ;;^UTILITY(U,$J,.84,1831,1,1,0) ;;=The Import Tool was expecting to find File and Field specifications ;;^UTILITY(U,$J,.84,1831,1,2,0) ;;=in the host file containing import data. However, either the File ;;^UTILITY(U,$J,.84,1831,1,3,0) ;;=is not specified or the format of the specification is incorrect. ;;^UTILITY(U,$J,.84,1831,1,4,0) ;;=The first line of the host file should look exactly like this: ;;^UTILITY(U,$J,.84,1831,1,5,0) ;;= ;;^UTILITY(U,$J,.84,1831,1,6,0) ;;=FILE=filename ;;^UTILITY(U,$J,.84,1831,2,0) ;;=^^1^1^2960919^ ;;^UTILITY(U,$J,.84,1831,2,1,0) ;;=The file name is either missing from the host file or incorrectly specified. ;;^UTILITY(U,$J,.84,1833,0) ;;=1833^1^ ;;^UTILITY(U,$J,.84,1833,1,0) ;;=^^3^3^2950317^ ;;^UTILITY(U,$J,.84,1833,1,1,0) ;;=The 'F' flag for the Import call means that the file and field information ;;^UTILITY(U,$J,.84,1833,1,2,0) ;;=is in the host file. However, the file and/or fields parameter contained ;;^UTILITY(U,$J,.84,1833,1,3,0) ;;=data. This conflicts with the 'F' flag. ;;^UTILITY(U,$J,.84,1833,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1833,2,1,0) ;;=The 'F' flag conflicts with the File or Fields parameter. ;;^UTILITY(U,$J,.84,1841,0) ;;=1841^1^ ;;^UTILITY(U,$J,.84,1841,1,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1841,1,1,0) ;;=Only multiple fields can be in the path to a field. ;;^UTILITY(U,$J,.84,1841,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1841,2,1,0) ;;=A field other than a multiple is in the 'path'. ;;^UTILITY(U,$J,.84,1842,0) ;;=1842^1^ ;;^UTILITY(U,$J,.84,1842,1,0) ;;=^^2^2^2950317^ ;;^UTILITY(U,$J,.84,1842,1,1,0) ;;=The last field in a string of colon-delimited fields must be a field ;;^UTILITY(U,$J,.84,1842,1,2,0) ;;=containing data, not a multiple field. ;;^UTILITY(U,$J,.84,1842,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1842,2,1,0) ;;=A multiple field is shown as the last field is a string of fields. ;;^UTILITY(U,$J,.84,1844,0) ;;=1844^1^ ;;^UTILITY(U,$J,.84,1844,1,0) ;;=^^2^2^2950317^ ;;^UTILITY(U,$J,.84,1844,1,1,0) ;;=There must be at least one field in every subfile before moving down ;;^UTILITY(U,$J,.84,1844,1,2,0) ;;=into a lower level subfile. ;;^UTILITY(U,$J,.84,1844,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1844,2,1,0) ;;=A subfile level was skipped without specifying any fields in it. ;;^UTILITY(U,$J,.84,1845,0) ;;=1845^1^ ;;^UTILITY(U,$J,.84,1845,1,0) ;;=^^2^2^2950317^ ;;^UTILITY(U,$J,.84,1845,1,1,0) ;;=A field may only appear once in the designated fields for a particular ;;^UTILITY(U,$J,.84,1845,1,2,0) ;;=file or subfile. ;;^UTILITY(U,$J,.84,1845,2,0) ;;=^^1^1^2950317^ ;;^UTILITY(U,$J,.84,1845,2,1,0) ;;=The same field appears twice in the list of fields for a (sub)file. DINIT00D DINIT00D ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,1846,0) ;;=1846^1^y ;;^UTILITY(U,$J,.84,1846,1,0) ;;=^^1^1^2950317^^ ;;^UTILITY(U,$J,.84,1846,1,1,0) ;;=A file or subfile must have only one string of fields associated with it. ;;^UTILITY(U,$J,.84,1846,2,0) ;;=^^1^1^2950317^^ ;;^UTILITY(U,$J,.84,1846,2,1,0) ;;=File #|FILE| appears more than once in the import with different fields. ;;^UTILITY(U,$J,.84,1846,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,1846,3,1,0) ;;=FILE^File or subfile number. ;;^UTILITY(U,$J,.84,1850,0) ;;=1850^1^^5 ;;^UTILITY(U,$J,.84,1850,1,0) ;;=^^4^4^2960718^^ ;;^UTILITY(U,$J,.84,1850,1,1,0) ;;=The device for printing the Import report was not properly specified. ;;^UTILITY(U,$J,.84,1850,1,2,0) ;;=This could be caused either by a user's response or by the ;;^UTILITY(U,$J,.84,1850,1,3,0) ;;=device specifications passed to the FILE^DDMP call. The problem ;;^UTILITY(U,$J,.84,1850,1,4,0) ;;=could involve either device or queuing instructions. ;;^UTILITY(U,$J,.84,1850,2,0) ;;=^^1^1^2960718^^ ;;^UTILITY(U,$J,.84,1850,2,1,0) ;;=There is an error in device selection or queuing setup. ;;^UTILITY(U,$J,.84,1860,0) ;;=1860^1^^5 ;;^UTILITY(U,$J,.84,1860,1,0) ;;=^^1^1^2960906^ ;;^UTILITY(U,$J,.84,1860,1,1,0) ;;=The record being imported has no data. ;;^UTILITY(U,$J,.84,1860,2,0) ;;=^^1^1^2960906^ ;;^UTILITY(U,$J,.84,1860,2,1,0) ;;=The record being imported has no data. ;;^UTILITY(U,$J,.84,1862,0) ;;=1862^1^^5 ;;^UTILITY(U,$J,.84,1862,1,0) ;;=^^4^4^2960906^^ ;;^UTILITY(U,$J,.84,1862,1,1,0) ;;=When parsing the imported record, more fields were found than expected. ;;^UTILITY(U,$J,.84,1862,1,2,0) ;;=There were either more delimiter-pieces than expected or the length of a ;;^UTILITY(U,$J,.84,1862,1,3,0) ;;=fixed length import was too long. This probably means that the incoming ;;^UTILITY(U,$J,.84,1862,1,4,0) ;;=file is corrupted. ;;^UTILITY(U,$J,.84,1862,2,0) ;;=^^1^1^2960906^^ ;;^UTILITY(U,$J,.84,1862,2,1,0) ;;=There are more fields in the incoming record than expected. ;;^UTILITY(U,$J,.84,1870,0) ;;=1870^1^y^5 ;;^UTILITY(U,$J,.84,1870,1,0) ;;=^^2^2^2960913^ ;;^UTILITY(U,$J,.84,1870,1,1,0) ;;=A requested import template does not exist in the Import Template file ;;^UTILITY(U,$J,.84,1870,1,2,0) ;;=for the file being imported into. ;;^UTILITY(U,$J,.84,1870,2,0) ;;=^^1^1^2961002^^^ ;;^UTILITY(U,$J,.84,1870,2,1,0) ;;=Import template |1| does not exist for File #|FILE|. ;;^UTILITY(U,$J,.84,1870,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,1870,3,1,0) ;;=1^Template name. ;;^UTILITY(U,$J,.84,1870,3,2,0) ;;=FILE^File number. ;;^UTILITY(U,$J,.84,3000,0) ;;=3000^1^^5 ;;^UTILITY(U,$J,.84,3000,1,0) ;;=^^1^1^2930721^ ;;^UTILITY(U,$J,.84,3000,1,1,0) ;;=Initial call to ^DDS failed. ;;^UTILITY(U,$J,.84,3000,2,0) ;;=^^1^1^2931202^ ;;^UTILITY(U,$J,.84,3000,2,1,0) ;;=THE FORM COULD NOT BE INVOKED. ;;^UTILITY(U,$J,.84,3002,0) ;;=3002^1^y^5 ;;^UTILITY(U,$J,.84,3002,1,0) ;;=^^1^1^2931202^ ;;^UTILITY(U,$J,.84,3002,1,1,0) ;;=An error was encountered during Form compilation. ;;^UTILITY(U,$J,.84,3002,2,0) ;;=^^1^1^2931202^^ ;;^UTILITY(U,$J,.84,3002,2,1,0) ;;=THE FORM "|1|" COULD NOT BE COMPILED. ;;^UTILITY(U,$J,.84,3002,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3002,3,1,0) ;;=1^Form name ;;^UTILITY(U,$J,.84,3011,0) ;;=3011^1^y^5 ;;^UTILITY(U,$J,.84,3011,1,0) ;;=^^1^1^2931201^ ;;^UTILITY(U,$J,.84,3011,1,1,0) ;;=The specified field is missing or invalid. ;;^UTILITY(U,$J,.84,3011,2,0) ;;=^^1^1^2931201^ ;;^UTILITY(U,$J,.84,3011,2,1,0) ;;=The |1| field of the |2| file is missing or invalid. ;;^UTILITY(U,$J,.84,3011,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,3011,3,1,0) ;;=1^Field or subfield name ;;^UTILITY(U,$J,.84,3011,3,2,0) ;;=2^File name ;;^UTILITY(U,$J,.84,3012,0) ;;=3012^1^y^5 ;;^UTILITY(U,$J,.84,3012,1,0) ;;=^^2^2^2931201^ ;;^UTILITY(U,$J,.84,3012,1,1,0) ;;=The specified file or subfile does not exist; it is not present in the ;;^UTILITY(U,$J,.84,3012,1,2,0) ;;=data dictionary. ;;^UTILITY(U,$J,.84,3012,2,0) ;;=^^1^1^2931201^ ;;^UTILITY(U,$J,.84,3012,2,1,0) ;;=File |1| does not exist. ;;^UTILITY(U,$J,.84,3012,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3012,3,1,0) ;;=1^File number or name ;;^UTILITY(U,$J,.84,3021,0) ;;=3021^1^y^5 ;;^UTILITY(U,$J,.84,3021,1,0) ;;=^^1^1^2940811^^^ ;;^UTILITY(U,$J,.84,3021,1,1,0) ;;=A lookup in to the Form file for the given form failed. ;;^UTILITY(U,$J,.84,3021,2,0) ;;=^^2^2^2940811^ ;;^UTILITY(U,$J,.84,3021,2,1,0) ;;=Form |1| does not exist in the Form file, or DDSFILE is not the Primary ;;^UTILITY(U,$J,.84,3021,2,2,0) ;;=File of the form. ;;^UTILITY(U,$J,.84,3021,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3021,3,1,0) ;;=1^Form name ;;^UTILITY(U,$J,.84,3022,0) ;;=3022^1^y^5 ;;^UTILITY(U,$J,.84,3022,1,0) ;;=^^1^1^2931130^^ ;;^UTILITY(U,$J,.84,3022,1,1,0) ;;=There are no pages defined in the Page multiple of the given form. ;;^UTILITY(U,$J,.84,3022,2,0) ;;=^^1^1^2931130^^ ;;^UTILITY(U,$J,.84,3022,2,1,0) ;;=Form |1| contains no pages. ;;^UTILITY(U,$J,.84,3022,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3022,3,1,0) ;;=1^Form name ;;^UTILITY(U,$J,.84,3023,0) ;;=3023^1^y^5 ;;^UTILITY(U,$J,.84,3023,1,0) ;;=^^1^1^2931129^^ ;;^UTILITY(U,$J,.84,3023,1,1,0) ;;=The given page was not found on the form. ;;^UTILITY(U,$J,.84,3023,2,0) ;;=^^1^1^2931129^^^ ;;^UTILITY(U,$J,.84,3023,2,1,0) ;;=The form does not contain a page |1|. ;;^UTILITY(U,$J,.84,3023,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3023,3,1,0) ;;=1^Page name or number ;;^UTILITY(U,$J,.84,3031,0) ;;=3031^1^y^5 ;;^UTILITY(U,$J,.84,3031,1,0) ;;=^^1^1^2931124^ ;;^UTILITY(U,$J,.84,3031,1,1,0) ;;=The call to the specified ScreenMan utility failed. ;;^UTILITY(U,$J,.84,3031,2,0) ;;=^^1^1^2931124^ ;;^UTILITY(U,$J,.84,3031,2,1,0) ;;=NOTE: The programmer call to the |1| ScreenMan utility failed. ;;^UTILITY(U,$J,.84,3031,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3031,3,1,0) ;;=1^ScreenMan utility entry point. ;;^UTILITY(U,$J,.84,3041,0) ;;=3041^1^y^5 ;;^UTILITY(U,$J,.84,3041,1,0) ;;=^^1^1^2931130^^ ;;^UTILITY(U,$J,.84,3041,1,1,0) ;;=Errors were encountered while attempting to load the page. ;;^UTILITY(U,$J,.84,3041,2,0) ;;=^^1^1^2931130^ ;;^UTILITY(U,$J,.84,3041,2,1,0) ;;=Page |1| (|2|) could not be loaded. ;;^UTILITY(U,$J,.84,3041,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,3041,3,1,0) ;;=1^Page number ;;^UTILITY(U,$J,.84,3041,3,2,0) ;;=2^Page name ;;^UTILITY(U,$J,.84,3051,0) ;;=3051^1^y^5 DINIT00E DINIT00E ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;29JAN2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,3051,1,0) ;;=^^2^2^2931129^^^^ ;;^UTILITY(U,$J,.84,3051,1,1,0) ;;=The block has no 0 node in the Block file or was not found in the "B" ;;^UTILITY(U,$J,.84,3051,1,2,0) ;;=index. ;;^UTILITY(U,$J,.84,3051,2,0) ;;=^^1^1^2931129^^^ ;;^UTILITY(U,$J,.84,3051,2,1,0) ;;=Block |1| does not exist in the Block file. ;;^UTILITY(U,$J,.84,3051,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3051,3,1,0) ;;=1^Block number or name ;;^UTILITY(U,$J,.84,3053,0) ;;=3053^1^y^5 ;;^UTILITY(U,$J,.84,3053,1,0) ;;=^^4^4^2931129^ ;;^UTILITY(U,$J,.84,3053,1,1,0) ;;=The specified block was not found on the page. For example, it was not ;;^UTILITY(U,$J,.84,3053,1,2,0) ;;=found in the "AC" or "B" index in the block multiple of the page multiple ;;^UTILITY(U,$J,.84,3053,1,3,0) ;;=of the Form file, or the 0 node of the block in the block multiple is ;;^UTILITY(U,$J,.84,3053,1,4,0) ;;=missing. ;;^UTILITY(U,$J,.84,3053,2,0) ;;=^^1^1^2931129^^ ;;^UTILITY(U,$J,.84,3053,2,1,0) ;;=Block |1| was not found on page |2|. ;;^UTILITY(U,$J,.84,3053,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,3053,3,1,0) ;;=1^Block order, name, or number ;;^UTILITY(U,$J,.84,3053,3,2,0) ;;=2^Page number and/or name ;;^UTILITY(U,$J,.84,3055,0) ;;=3055^1^y^5 ;;^UTILITY(U,$J,.84,3055,1,0) ;;=^^1^1^2931129^^^ ;;^UTILITY(U,$J,.84,3055,1,1,0) ;;=There are no blocks defined on the page. ;;^UTILITY(U,$J,.84,3055,2,0) ;;=^^1^1^2931129^^^ ;;^UTILITY(U,$J,.84,3055,2,1,0) ;;=There are no blocks defined on page |1|. ;;^UTILITY(U,$J,.84,3055,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3055,3,1,0) ;;=1^Page name and/or number ;;^UTILITY(U,$J,.84,3071,0) ;;=3071^1^y^5 ;;^UTILITY(U,$J,.84,3071,1,0) ;;=^^1^1^2931129^^^ ;;^UTILITY(U,$J,.84,3071,1,1,0) ;;=The specified block has no fields on it. ;;^UTILITY(U,$J,.84,3071,2,0) ;;=^^1^1^2931129^^ ;;^UTILITY(U,$J,.84,3071,2,1,0) ;;=There are no fields defined on block |1|. ;;^UTILITY(U,$J,.84,3071,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,3071,3,1,0) ;;=1^Block name ;;^UTILITY(U,$J,.84,3072,0) ;;=3072^1^y^5 ;;^UTILITY(U,$J,.84,3072,1,0) ;;=^^1^1^2931129^ ;;^UTILITY(U,$J,.84,3072,1,1,0) ;;=The specified field was not found on the block. ;;^UTILITY(U,$J,.84,3072,2,0) ;;=^^1^1^2931129^ ;;^UTILITY(U,$J,.84,3072,2,1,0) ;;=Field |1| was not found on block |2|. ;;^UTILITY(U,$J,.84,3072,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,3072,3,1,0) ;;=1^Field order, number, caption, or unique name ;;^UTILITY(U,$J,.84,3072,3,2,0) ;;=2^Block name ;;^UTILITY(U,$J,.84,3081,0) ;;=3081^1^^5 ;;^UTILITY(U,$J,.84,3081,1,0) ;;=^^2^2^2931201^^ ;;^UTILITY(U,$J,.84,3081,1,1,0) ;;=The field specified by FO(field) in the pointer link or computed expression ;;^UTILITY(U,$J,.84,3081,1,2,0) ;;=is not a form only field. ;;^UTILITY(U,$J,.84,3081,2,0) ;;=^^1^1^2931201^^ ;;^UTILITY(U,$J,.84,3081,2,1,0) ;;=The specified field is not a form-only field. ;;^UTILITY(U,$J,.84,3082,0) ;;=3082^1^^5 ;;^UTILITY(U,$J,.84,3082,1,0) ;;=^^3^3^2931203^ ;;^UTILITY(U,$J,.84,3082,1,1,0) ;;=The field, block, and/or page is missing or invalid in the expression ;;^UTILITY(U,$J,.84,3082,1,2,0) ;;=FO(field,block,page), used in the pointer link, parent field, or computed ;;^UTILITY(U,$J,.84,3082,1,3,0) ;;=expression. ;;^UTILITY(U,$J,.84,3082,2,0) ;;=^^1^1^2931203^ ;;^UTILITY(U,$J,.84,3082,2,1,0) ;;=Parameters are missing or invalid in an FO() expression. ;;^UTILITY(U,$J,.84,3083,0) ;;=3083^1^^5 ;;^UTILITY(U,$J,.84,3083,1,0) ;;=^^1^1^2931203^^ ;;^UTILITY(U,$J,.84,3083,1,1,0) ;;=The relational expression is incomplete. ;;^UTILITY(U,$J,.84,3083,2,0) ;;=^^1^1^2931203^^ ;;^UTILITY(U,$J,.84,3083,2,1,0) ;;=The relational expression is incomplete. ;;^UTILITY(U,$J,.84,3084,0) ;;=3084^1^^5 ;;^UTILITY(U,$J,.84,3084,1,0) ;;=^^3^3^2931203^^ ;;^UTILITY(U,$J,.84,3084,1,1,0) ;;=In a computed expression, a form-only field should be referenced as ;;^UTILITY(U,$J,.84,3084,1,2,0) ;;={FO(field,block)} or {FO(field)}. The page parameter should not be ;;^UTILITY(U,$J,.84,3084,1,3,0) ;;=included. ;;^UTILITY(U,$J,.84,3084,2,0) ;;=^^1^1^2931203^^ ;;^UTILITY(U,$J,.84,3084,2,1,0) ;;=The FO() expression should not contain a page parameter. ;;^UTILITY(U,$J,.84,3085,0) ;;=3085^1^^5 ;;^UTILITY(U,$J,.84,3085,1,0) ;;=^^3^3^2931203^ ;;^UTILITY(U,$J,.84,3085,1,1,0) ;;=In a computed expression, a form-only field should be referenced as ;;^UTILITY(U,$J,.84,3085,1,2,0) ;;={FO(field,block)} or {FO(field)}. The block parameter should be ;;^UTILITY(U,$J,.84,3085,1,3,0) ;;=either the block name or `block number. It should not be a block order. ;;^UTILITY(U,$J,.84,3085,2,0) ;;=^^1^1^2931203^^ ;;^UTILITY(U,$J,.84,3085,2,1,0) ;;=The FO() expression should not use block order to specify a block. ;;^UTILITY(U,$J,.84,3086,0) ;;=3086^1^^5 ;;^UTILITY(U,$J,.84,3086,1,0) ;;=^^2^2^2940708^^ ;;^UTILITY(U,$J,.84,3086,1,1,0) ;;=Reject calls to PUT^DDSVAL which attempt to set the .01 field of a file to ;;^UTILITY(U,$J,.84,3086,1,2,0) ;;="" or "@". ;;^UTILITY(U,$J,.84,3086,2,0) ;;=^^1^1^2940708^^^ ;;^UTILITY(U,$J,.84,3086,2,1,0) ;;=PUT^DDSVAL cannot be used to delete an entry. ;;^UTILITY(U,$J,.84,3091,0) ;;=3091^1^^5 ;;^UTILITY(U,$J,.84,3091,1,0) ;;=^^1^1^2930722^ ;;^UTILITY(U,$J,.84,3091,1,1,0) ;;=The data could not be filed. ;;^UTILITY(U,$J,.84,3091,2,0) ;;=^^1^1^2931202^^ ;;^UTILITY(U,$J,.84,3091,2,1,0) ;;=THE DATA COULD NOT BE FILED. ;;^UTILITY(U,$J,.84,3092,0) ;;=3092^1^y^5 ;;^UTILITY(U,$J,.84,3092,1,0) ;;=^^1^1^2940713^^^^ ;;^UTILITY(U,$J,.84,3092,1,1,0) ;;=The given field is required and its current value is null. ;;^UTILITY(U,$J,.84,3092,2,0) ;;=^^1^1^2940713^^^ ;;^UTILITY(U,$J,.84,3092,2,1,0) ;;=On |1|, |2| is a required field |3| ;;^UTILITY(U,$J,.84,3092,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,3092,3,1,0) ;;=1^Page name ;;^UTILITY(U,$J,.84,3092,3,2,0) ;;=2^Caption ;;^UTILITY(U,$J,.84,3092,3,3,0) ;;=3^Subrecord name in parentheses ;;^UTILITY(U,$J,.84,7001,0) ;;=7001^2^^5 ;;^UTILITY(U,$J,.84,7001,1,0) ;;=^^1^1^2940314^^^ ;;^UTILITY(U,$J,.84,7001,1,1,0) ;;=This is the general Yes/No Prompt ;;^UTILITY(U,$J,.84,7001,2,0) ;;=^^1^1^2940314^^^ ;;^UTILITY(U,$J,.84,7001,2,1,0) ;;=Yes^No ;;^UTILITY(U,$J,.84,7002,0) ;;=7002^2^^5 ;;^UTILITY(U,$J,.84,7002,1,0) ;;=^^1^1^2940314^^^ ;;^UTILITY(U,$J,.84,7002,1,1,0) ;;=Insert/Replace Switch ;;^UTILITY(U,$J,.84,7002,2,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,7002,2,1,0) ;;=Insert ^Replace DINIT00F DINIT00F ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;31JAN2005 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,7003,0) ;;=7003^2^^5 ;;^UTILITY(U,$J,.84,7003,1,0) ;;=^^1^1^2960321^^ ;;^UTILITY(U,$J,.84,7003,1,1,0) ;;=Yes/No prompt for Reader ;;^UTILITY(U,$J,.84,7003,2,0) ;;=^^1^1^2960321^^^ ;;^UTILITY(U,$J,.84,7003,2,1,0) ;;=y:YES;n:NO ;;^UTILITY(U,$J,.84,7003,4,0) ;;=^.847P^2^1 ;;^UTILITY(U,$J,.84,7003,4,2,0) ;;=2 ;;^UTILITY(U,$J,.84,7003,4,2,1,0) ;;=^^1^1^2960321^ ;;^UTILITY(U,$J,.84,7003,4,2,1,1,0) ;;=j:JA;n:NEIN ;;^UTILITY(U,$J,.84,7004,0) ;;=7004^2^^5 ;;^UTILITY(U,$J,.84,7004,1,0) ;;=^^2^2^2940909^^^^ ;;^UTILITY(U,$J,.84,7004,1,1,0) ;;=Set of codes for reader call when asking user whether they want to include ;;^UTILITY(U,$J,.84,7004,1,2,0) ;;=computed fields and/or IEN in CAPTIONED output. ;;^UTILITY(U,$J,.84,7004,2,0) ;;=^^4^4^2940914^^ ;;^UTILITY(U,$J,.84,7004,2,1,0) ;;=N:NO - No record number (IEN), no Computed Fields; ;;^UTILITY(U,$J,.84,7004,2,2,0) ;;=Y:Computed Fields; ;;^UTILITY(U,$J,.84,7004,2,3,0) ;;=R:Record Number (IEN); ;;^UTILITY(U,$J,.84,7004,2,4,0) ;;=B:BOTH Computed Fields and Record Number (IEN) ;;^UTILITY(U,$J,.84,7005,0) ;;=7005^1^^13^You must have a valid DUZ ;;^UTILITY(U,$J,.84,7005,2,0) ;;=^^1^1^3050128^^^ ;;^UTILITY(U,$J,.84,7005,2,1,0) ;;=You must have a valid DUZ! ;;^UTILITY(U,$J,.84,7005,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,7005,5,1,0) ;;=DII ;;^UTILITY(U,$J,.84,8001,0) ;;=8001^2^^5 ;;^UTILITY(U,$J,.84,8001,1,0) ;;=^^1^1^2941118^^^^ ;;^UTILITY(U,$J,.84,8001,1,1,0) ;;=Prompt for name of compiled template or cross-reference routine. ;;^UTILITY(U,$J,.84,8001,2,0) ;;=^^1^1^2941118^^ ;;^UTILITY(U,$J,.84,8001,2,1,0) ;;=Routine Name ;;^UTILITY(U,$J,.84,8001,5,0) ;;=^.841^3^3 ;;^UTILITY(U,$J,.84,8001,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8001,5,2,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8001,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8002,0) ;;=8002^2^^5 ;;^UTILITY(U,$J,.84,8002,1,0) ;;=^^1^1^2940426^^^^ ;;^UTILITY(U,$J,.84,8002,1,1,0) ;;=Prompt for including computed fields and/or IEN in CAPTIONED output. ;;^UTILITY(U,$J,.84,8002,2,0) ;;=^^1^1^2940909^^^^ ;;^UTILITY(U,$J,.84,8002,2,1,0) ;;=Include COMPUTED fields ;;^UTILITY(U,$J,.84,8003,0) ;;=8003^2^y^5 ;;^UTILITY(U,$J,.84,8003,1,0) ;;=^^2^2^2931101^^^^ ;;^UTILITY(U,$J,.84,8003,1,1,0) ;;=Used in Print to display sort criteria in heading--when BY(0) contains ;;^UTILITY(U,$J,.84,8003,1,2,0) ;;=a search template name. ;;^UTILITY(U,$J,.84,8003,2,0) ;;=^^1^1^2931102^ ;;^UTILITY(U,$J,.84,8003,2,1,0) ;;=Records from list on |1| search template ;;^UTILITY(U,$J,.84,8003,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8003,3,1,0) ;;=1^Name of search template. ;;^UTILITY(U,$J,.84,8003,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8003,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8003,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8004,0) ;;=8004^2^y^5 ;;^UTILITY(U,$J,.84,8004,1,0) ;;=^^3^3^2931101^ ;;^UTILITY(U,$J,.84,8004,1,1,0) ;;=Used in Print to display sort criteria in heading--when BY(0) contains ;;^UTILITY(U,$J,.84,8004,1,2,0) ;;=the global reference for a cross-reference or for another global ;;^UTILITY(U,$J,.84,8004,1,3,0) ;;=containing a list of record numbers. ;;^UTILITY(U,$J,.84,8004,2,0) ;;=^^1^1^2931101^^ ;;^UTILITY(U,$J,.84,8004,2,1,0) ;;=Sort using |1| ;;^UTILITY(U,$J,.84,8004,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8004,3,1,0) ;;=1^Global reference passed in BY(0) ;;^UTILITY(U,$J,.84,8004,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8004,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8004,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8005,0) ;;=8005^2^y^5 ;;^UTILITY(U,$J,.84,8005,1,0) ;;=^^4^4^2940908^^ ;;^UTILITY(U,$J,.84,8005,1,1,0) ;;=At the heading prompt during the FileMan print, the user can enter flags ;;^UTILITY(U,$J,.84,8005,1,2,0) ;;=to either suppress printing of the header if there are no records to ;;^UTILITY(U,$J,.84,8005,1,3,0) ;;=print, or to cause the search/sort criteria to print in the header. This ;;^UTILITY(U,$J,.84,8005,1,4,0) ;;=is the help prompt. ;;^UTILITY(U,$J,.84,8005,2,0) ;;=^^11^11^2940908^^^^ ;;^UTILITY(U,$J,.84,8005,2,1,0) ;;=There are two different options: ;;^UTILITY(U,$J,.84,8005,2,2,0) ;;= ;;^UTILITY(U,$J,.84,8005,2,3,0) ;;=1) Accept the default heading or enter a custom heading. ;;^UTILITY(U,$J,.84,8005,2,4,0) ;;= For no heading at all, type @. ;;^UTILITY(U,$J,.84,8005,2,5,0) ;;= To use a Print Template for the heading, type [TEMPLATE NAME]. ;;^UTILITY(U,$J,.84,8005,2,6,0) ;;= ;;^UTILITY(U,$J,.84,8005,2,7,0) ;;=2) Replace the default heading with: ;;^UTILITY(U,$J,.84,8005,2,8,0) ;;= S to Suppress the |1|, and/or ;;^UTILITY(U,$J,.84,8005,2,9,0) ;;= C to print |2| Criteria in the heading. ;;^UTILITY(U,$J,.84,8005,2,10,0) ;;= ;;^UTILITY(U,$J,.84,8005,2,11,0) ;;=If S and/or C is entered, the heading prompt will re-appear. ;;^UTILITY(U,$J,.84,8005,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,8005,3,1,0) ;;=1^Text from either entry #8006 or #8007, depending on whether we're coming from the search or print. ;;^UTILITY(U,$J,.84,8005,3,2,0) ;;=2^Text from either entry #8038 or #8037, depending on whether we're coming from the search or print. ;;^UTILITY(U,$J,.84,8005,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8005,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8005,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8006,0) ;;=8006^2^^5 ;;^UTILITY(U,$J,.84,8006,1,0) ;;=^^1^1^2940526^^^^ ;;^UTILITY(U,$J,.84,8006,1,1,0) ;;=Inserted as a parameter to #8005 when called from the SEARCH Option. ;;^UTILITY(U,$J,.84,8006,2,0) ;;=^^1^1^2940526^^ ;;^UTILITY(U,$J,.84,8006,2,1,0) ;;=Number of Matches from the search ;;^UTILITY(U,$J,.84,8006,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8006,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8006,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8007,0) ;;=8007^2^^5 ;;^UTILITY(U,$J,.84,8007,1,0) ;;=^^1^1^2940526^^^^ ;;^UTILITY(U,$J,.84,8007,1,1,0) ;;=Inserted as a parameter to #8005 when called from the PRINT Option. ;;^UTILITY(U,$J,.84,8007,2,0) ;;=^^1^1^2940526^ ;;^UTILITY(U,$J,.84,8007,2,1,0) ;;=heading when there are no records to print ;;^UTILITY(U,$J,.84,8007,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8007,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8007,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8008,0) ;;=8008^2^^5 ;;^UTILITY(U,$J,.84,8008,1,0) ;;=^^4^4^2940908^ ;;^UTILITY(U,$J,.84,8008,1,1,0) ;;=At the HEADING prompt during the FileMan print, the user can enter flags ;;^UTILITY(U,$J,.84,8008,1,2,0) ;;=to either suppress printing of the header if there are no records to ;;^UTILITY(U,$J,.84,8008,1,3,0) ;;=print, or to cause the sort criteria to print in the header. This is the ;;^UTILITY(U,$J,.84,8008,1,4,0) ;;=prompt for the reader call. ;;^UTILITY(U,$J,.84,8008,2,0) ;;=^^1^1^2940909^ DINIT00G DINIT00G ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;21FEB2005 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,8008,2,1,0) ;;=Heading (S/C) ;;^UTILITY(U,$J,.84,8008,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8008,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8008,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8004.1,0) ;;=8004.1^3^^13^HELP FOR ONE SEARCH CRITERION ('A') ;;^UTILITY(U,$J,.84,8004.1,2,0) ;;=^.844^3^3^3050131^^ ;;^UTILITY(U,$J,.84,8004.1,2,1,0) ;;=To search on the condition you have just typed, hit 'Enter'. ;;^UTILITY(U,$J,.84,8004.1,2,2,0) ;;=To search for the NEGATIVE of the condition, ;;^UTILITY(U,$J,.84,8004.1,2,3,0) ;;=type "'A". The "'" character means "negation". ;;^UTILITY(U,$J,.84,8004.1,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8004.1,5,1,0) ;;=DIS0^BAD+1 ;;^UTILITY(U,$J,.84,8004.2,0) ;;=8004.2^3^^13^HELP AFTER 'IF: ' FOR MULTIPLE CONDITIONS ;;^UTILITY(U,$J,.84,8004.2,2,0) ;;=^^3^3^3050131^ ;;^UTILITY(U,$J,.84,8004.2,2,1,0) ;;=To 'AND' Condition 'A' with Condition 'B', type 'A&B'. ;;^UTILITY(U,$J,.84,8004.2,2,2,0) ;;=To 'OR' Condition 'A' with Condition 'B', type 'A', ;;^UTILITY(U,$J,.84,8004.2,2,3,0) ;;=and then type 'B' at the next "OR:" prompt. ;;^UTILITY(U,$J,.84,8004.2,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8004.2,5,1,0) ;;=DIS0^BAD+1 ;;^UTILITY(U,$J,.84,8009,0) ;;=8009^2^^5 ;;^UTILITY(U,$J,.84,8009,1,0) ;;=^^2^2^2940908^^^^ ;;^UTILITY(U,$J,.84,8009,1,1,0) ;;=This is the normal help message given if user enters a question mark when ;;^UTILITY(U,$J,.84,8009,1,2,0) ;;=being prompted for the HEADER during a FileMan print. ;;^UTILITY(U,$J,.84,8009,2,0) ;;=^^3^3^2940908^ ;;^UTILITY(U,$J,.84,8009,2,1,0) ;;=Accept default heading or enter a custom heading. ;;^UTILITY(U,$J,.84,8009,2,2,0) ;;=For no heading at all, type @. ;;^UTILITY(U,$J,.84,8009,2,3,0) ;;=To use a Print Template for the heading, type [TEMPLATE NAME]. ;;^UTILITY(U,$J,.84,8009,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8009,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8009,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8010,0) ;;=8010^2^y^5 ;;^UTILITY(U,$J,.84,8010,1,0) ;;=^^1^1^2931102^^^^ ;;^UTILITY(U,$J,.84,8010,1,1,0) ;;=Print dialog coming from routine ^DIP31. ;;^UTILITY(U,$J,.84,8010,2,0) ;;=^^1^1^2931102^ ;;^UTILITY(U,$J,.84,8010,2,1,0) ;;=** Suppress the |1|. ;;^UTILITY(U,$J,.84,8010,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8010,3,1,0) ;;=1^Text from either entry #8006 or #8007, depending on whether it's called from the SEARCH or PRINT Options. ;;^UTILITY(U,$J,.84,8010,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8010,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8010,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8011,0) ;;=8011^2^y^5 ;;^UTILITY(U,$J,.84,8011,1,0) ;;=^^1^1^2940526^^^^ ;;^UTILITY(U,$J,.84,8011,1,1,0) ;;=Dialog coming from routine ^DIP31 ;;^UTILITY(U,$J,.84,8011,2,0) ;;=^^1^1^2940526^ ;;^UTILITY(U,$J,.84,8011,2,1,0) ;;=** print |1| Criteria in heading. ;;^UTILITY(U,$J,.84,8011,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8011,3,1,0) ;;=1^The word SORT or SEARCH, depending on which option we're coming from. ;;^UTILITY(U,$J,.84,8011,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8011,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8011,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8012,0) ;;=8012^2^^5 ;;^UTILITY(U,$J,.84,8012,1,0) ;;=^^2^2^2931102^^^ ;;^UTILITY(U,$J,.84,8012,1,1,0) ;;=The word HEADING to be used in the prompt for the heading from the FileMan ;;^UTILITY(U,$J,.84,8012,1,2,0) ;;=PRINT option. ;;^UTILITY(U,$J,.84,8012,2,0) ;;=^^1^1^2931102^ ;;^UTILITY(U,$J,.84,8012,2,1,0) ;;=Heading ;;^UTILITY(U,$J,.84,8012,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8012,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8012,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8013,0) ;;=8013^2^^5 ;;^UTILITY(U,$J,.84,8013,1,0) ;;=^^3^3^2931105^^ ;;^UTILITY(U,$J,.84,8013,1,1,0) ;;=The DD for the file of files is not completely FileMan compatible. This ;;^UTILITY(U,$J,.84,8013,1,2,0) ;;=is the field name prompt for the POST-SELECTION ACTION field on the file ;;^UTILITY(U,$J,.84,8013,1,3,0) ;;=of files. Prompt appears when file attributes. ;;^UTILITY(U,$J,.84,8013,2,0) ;;=^^1^1^2931105^^ ;;^UTILITY(U,$J,.84,8013,2,1,0) ;;=POST-SELECTION ACTION ;;^UTILITY(U,$J,.84,8013,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8013,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8014,0) ;;=8014^2^^5 ;;^UTILITY(U,$J,.84,8014,1,0) ;;=^^3^3^2931105^ ;;^UTILITY(U,$J,.84,8014,1,1,0) ;;=The DD for the file of files is not completely FileMan compatible. This ;;^UTILITY(U,$J,.84,8014,1,2,0) ;;=is the field name prompt for the LOOK-UP PROGRAM field on the file ;;^UTILITY(U,$J,.84,8014,1,3,0) ;;=of files. Prompt appears when file attributes are edited. ;;^UTILITY(U,$J,.84,8014,2,0) ;;=^^1^1^2931105^ ;;^UTILITY(U,$J,.84,8014,2,1,0) ;;=LOOK-UP PROGRAM ;;^UTILITY(U,$J,.84,8014,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8014,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8015,0) ;;=8015^2^^5 ;;^UTILITY(U,$J,.84,8015,1,0) ;;=^^2^2^2931105^ ;;^UTILITY(U,$J,.84,8015,1,1,0) ;;=Standard prompt to verify to the user that they just deleted something ;;^UTILITY(U,$J,.84,8015,1,2,0) ;;=with the "@". ;;^UTILITY(U,$J,.84,8015,2,0) ;;=^^1^1^2931105^ ;;^UTILITY(U,$J,.84,8015,2,1,0) ;;=Deleted. ;;^UTILITY(U,$J,.84,8015,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8015,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8016,0) ;;=8016^2^y^5 ;;^UTILITY(U,$J,.84,8016,1,0) ;;=^^2^2^2931105^^^^ ;;^UTILITY(U,$J,.84,8016,1,1,0) ;;=Called after performing routine existence test to tell user that routine ;;^UTILITY(U,$J,.84,8016,1,2,0) ;;=is already in their directory. ;;^UTILITY(U,$J,.84,8016,2,0) ;;=^^1^1^2931105^ ;;^UTILITY(U,$J,.84,8016,2,1,0) ;;=Note that |1| is already in the routine directory. ;;^UTILITY(U,$J,.84,8016,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8016,3,1,0) ;;=1^Name of the routine. ;;^UTILITY(U,$J,.84,8016,5,0) ;;=^.841^4^4 ;;^UTILITY(U,$J,.84,8016,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8016,5,2,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8016,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8016,5,4,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8017,0) ;;=8017^2^^5 ;;^UTILITY(U,$J,.84,8017,1,0) ;;=^^2^2^2931105^ ;;^UTILITY(U,$J,.84,8017,1,1,0) ;;=Message warning user that a routine does not exist in their routine ;;^UTILITY(U,$J,.84,8017,1,2,0) ;;=directory. ;;^UTILITY(U,$J,.84,8017,2,0) ;;=^^1^1^2931105^ ;;^UTILITY(U,$J,.84,8017,2,1,0) ;;=This routine does not exist in the routine directory. ;;^UTILITY(U,$J,.84,8017,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8017,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8018,0) ;;=8018^2^y^5 ;;^UTILITY(U,$J,.84,8018,1,0) ;;=^^2^2^2931105^ ;;^UTILITY(U,$J,.84,8018,1,1,0) ;;=Prompt showing the user a routine name previously used for compiled ;;^UTILITY(U,$J,.84,8018,1,2,0) ;;=routines (input templates, print templates, cross-references). ;;^UTILITY(U,$J,.84,8018,2,0) ;;=^^1^1^2931105^ ;;^UTILITY(U,$J,.84,8018,2,1,0) ;;=Previously compiled under routine name |1|. ;;^UTILITY(U,$J,.84,8018,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8018,3,1,0) ;;=1^Routine name from "DIKOLD" or "ROUOLD" nodes in templates or DD for cross-references. ;;^UTILITY(U,$J,.84,8018,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8018,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8019,0) ;;=8019^2^^5 ;;^UTILITY(U,$J,.84,8019,1,0) ;;=^^3^3^2931105^^ ;;^UTILITY(U,$J,.84,8019,1,1,0) ;;=The DD for the file of files is not completely FileMan compatible. This ;;^UTILITY(U,$J,.84,8019,1,2,0) ;;=is the field name prompt for the CROSS-REFERENCE ROUTINE field on the file ;;^UTILITY(U,$J,.84,8019,1,3,0) ;;=of files. Prompt appears when file attributes are edited. DINIT00H DINIT00H ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,8019,2,0) ;;=^^1^1^2931105^ ;;^UTILITY(U,$J,.84,8019,2,1,0) ;;=CROSS-REFERENCE ROUTINE ;;^UTILITY(U,$J,.84,8019,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8019,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8020,0) ;;=8020^2^^5 ;;^UTILITY(U,$J,.84,8020,1,0) ;;=^^2^2^2931110^^^^ ;;^UTILITY(U,$J,.84,8020,1,1,0) ;;=This prompt asks the user whether they are ready to compile, when ;;^UTILITY(U,$J,.84,8020,1,2,0) ;;=compiling TEMPLATES or CROSS-REFERENCES. ;;^UTILITY(U,$J,.84,8020,2,0) ;;=^^1^1^2931110^^ ;;^UTILITY(U,$J,.84,8020,2,1,0) ;;=Should the compilation run now ;;^UTILITY(U,$J,.84,8020,5,0) ;;=^.841^4^4 ;;^UTILITY(U,$J,.84,8020,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8020,5,2,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8020,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8020,5,4,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8021,0) ;;=8021^2^^5 ;;^UTILITY(U,$J,.84,8021,1,0) ;;=^^3^3^2931109^ ;;^UTILITY(U,$J,.84,8021,1,1,0) ;;=Message from editing the CROSS-REFERENCE ROUTINE. If this field is ;;^UTILITY(U,$J,.84,8021,1,2,0) ;;=deleted, the message notifies the user that the compiled routines will no ;;^UTILITY(U,$J,.84,8021,1,3,0) ;;=longer be used for re-indexing. ;;^UTILITY(U,$J,.84,8021,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,8021,2,1,0) ;;=The compiled routines will no longer be used for re-indexing. ;;^UTILITY(U,$J,.84,8021,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8021,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,8022,0) ;;=8022^2^^5 ;;^UTILITY(U,$J,.84,8022,1,0) ;;=^^2^2^2931110^^^ ;;^UTILITY(U,$J,.84,8022,1,1,0) ;;=Used when compiling PRINT templates, this is the prompt for the margin ;;^UTILITY(U,$J,.84,8022,1,2,0) ;;=width to be used for the printed report. ;;^UTILITY(U,$J,.84,8022,2,0) ;;=^^1^1^2931112^ ;;^UTILITY(U,$J,.84,8022,2,1,0) ;;=Margin Width for output ;;^UTILITY(U,$J,.84,8022,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8022,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8023,0) ;;=8023^2^^5 ;;^UTILITY(U,$J,.84,8023,1,0) ;;=^^2^2^2931110^^^^ ;;^UTILITY(U,$J,.84,8023,1,1,0) ;;=This is the help prompt for MARGIN WIDTH FOR OUTPUT, used when compiling ;;^UTILITY(U,$J,.84,8023,1,2,0) ;;=PRINT templates. ;;^UTILITY(U,$J,.84,8023,2,0) ;;=^^2^2^2931110^^^^ ;;^UTILITY(U,$J,.84,8023,2,1,0) ;;=Type a number from 19 to 255. This is the number of columns ;;^UTILITY(U,$J,.84,8023,2,2,0) ;;=on the report ;;^UTILITY(U,$J,.84,8023,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8023,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8024,0) ;;=8024^2^y^5 ;;^UTILITY(U,$J,.84,8024,1,0) ;;=^^1^1^2931110^^^^ ;;^UTILITY(U,$J,.84,8024,1,1,0) ;;=This is the text that tells the user they are now compiling routines. ;;^UTILITY(U,$J,.84,8024,2,0) ;;=^^1^1^2931110^^^^ ;;^UTILITY(U,$J,.84,8024,2,1,0) ;;=Compiling |1| |2| of File |3|. ;;^UTILITY(U,$J,.84,8024,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,8024,3,1,0) ;;=1^Name of template, if compiling templates. ;;^UTILITY(U,$J,.84,8024,3,2,0) ;;=2^The words "print template", "cross-references", etc. (i.e., what is being compiled). ;;^UTILITY(U,$J,.84,8024,3,3,0) ;;=3^File name ;;^UTILITY(U,$J,.84,8024,5,0) ;;=^.841^6^6 ;;^UTILITY(U,$J,.84,8024,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8024,5,2,0) ;;=DIPZ^EN ;;^UTILITY(U,$J,.84,8024,5,3,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8024,5,4,0) ;;=DIEZ^EN ;;^UTILITY(U,$J,.84,8024,5,5,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8024,5,6,0) ;;=DIKZ^EN ;;^UTILITY(U,$J,.84,8025,0) ;;=8025^2^y^5 ;;^UTILITY(U,$J,.84,8025,1,0) ;;=^^2^2^2931110^^ ;;^UTILITY(U,$J,.84,8025,1,1,0) ;;=Notify user that a routine has been filed. Used during compilation of ;;^UTILITY(U,$J,.84,8025,1,2,0) ;;=TEMPLATES and CROSS-REFERENCES. ;;^UTILITY(U,$J,.84,8025,2,0) ;;=^^1^1^2931110^^^ ;;^UTILITY(U,$J,.84,8025,2,1,0) ;;='|1|' ROUTINE FILED. ;;^UTILITY(U,$J,.84,8025,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8025,3,1,0) ;;=1^Routine name ;;^UTILITY(U,$J,.84,8025,5,0) ;;=^.841^8^7 ;;^UTILITY(U,$J,.84,8025,5,1,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8025,5,2,0) ;;=DIKZ^EN ;;^UTILITY(U,$J,.84,8025,5,3,0) ;;=DIOZ^ENCU ;;^UTILITY(U,$J,.84,8025,5,5,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8025,5,6,0) ;;=DIPZ^EN ;;^UTILITY(U,$J,.84,8025,5,7,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8025,5,8,0) ;;=DIEZ^EN ;;^UTILITY(U,$J,.84,8026,0) ;;=8026^2^y^5 ;;^UTILITY(U,$J,.84,8026,1,0) ;;=^^2^2^2931110^^^ ;;^UTILITY(U,$J,.84,8026,1,1,0) ;;=Used to notify the user that templates or cross-references have been ;;^UTILITY(U,$J,.84,8026,1,2,0) ;;=UNCOMPILED. ;;^UTILITY(U,$J,.84,8026,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8026,2,1,0) ;;=|1| now uncompiled. ;;^UTILITY(U,$J,.84,8026,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8026,3,1,0) ;;=1^Contains the word 'TEMPLATE' or 'CROSS-REFERENCES' ;;^UTILITY(U,$J,.84,8026,5,0) ;;=^.841^6^6 ;;^UTILITY(U,$J,.84,8026,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8026,5,2,0) ;;=DIPZ^EN ;;^UTILITY(U,$J,.84,8026,5,3,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8026,5,4,0) ;;=DIEZ^EN ;;^UTILITY(U,$J,.84,8026,5,5,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8026,5,6,0) ;;=DIKZ^EN ;;^UTILITY(U,$J,.84,8027,0) ;;=8027^2^^5 ;;^UTILITY(U,$J,.84,8027,1,0) ;;=^^2^2^2931110^^^ ;;^UTILITY(U,$J,.84,8027,1,1,0) ;;=Prompt for maximum routine size, used when compiling templates or ;;^UTILITY(U,$J,.84,8027,1,2,0) ;;=cross-references. ;;^UTILITY(U,$J,.84,8027,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8027,2,1,0) ;;=Maximum routine size on this computer (in bytes). ;;^UTILITY(U,$J,.84,8027,5,0) ;;=^.841^3^3 ;;^UTILITY(U,$J,.84,8027,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8027,5,2,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8027,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8028,0) ;;=8028^2^y^5 ;;^UTILITY(U,$J,.84,8028,1,0) ;;=^^2^2^2931110^^^^ ;;^UTILITY(U,$J,.84,8028,1,1,0) ;;=Extended dialogue for asking user whether they wish to UNCOMPILE ;;^UTILITY(U,$J,.84,8028,1,2,0) ;;=a previously compiled template or cross-references. ;;^UTILITY(U,$J,.84,8028,2,0) ;;=^^2^2^2931110^ ;;^UTILITY(U,$J,.84,8028,2,1,0) ;;= |1| currently compiled under namespace |2|. ;;^UTILITY(U,$J,.84,8028,2,2,0) ;;=UNCOMPILE the |1| ;;^UTILITY(U,$J,.84,8028,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,8028,3,1,0) ;;=1^Contains the word 'TEMPLATE' or 'CROSS-REFERENCES' ;;^UTILITY(U,$J,.84,8028,3,2,0) ;;=2^Routine name under which templates were previously compiled. ;;^UTILITY(U,$J,.84,8028,5,0) ;;=^.841^4^4 ;;^UTILITY(U,$J,.84,8028,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8028,5,2,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8028,5,3,0) ;;=DIKZ^ DINIT00I DINIT00I ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,8028,5,4,0) ;;=DIOZ^ENCU ;;^UTILITY(U,$J,.84,8029,0) ;;=8029^2^y^5 ;;^UTILITY(U,$J,.84,8029,1,0) ;;=^^2^2^2931110^ ;;^UTILITY(U,$J,.84,8029,1,1,0) ;;=Extended dialogue for asking user whether they wish to COMPILE a ;;^UTILITY(U,$J,.84,8029,1,2,0) ;;=template or cross-references. ;;^UTILITY(U,$J,.84,8029,2,0) ;;=^^2^2^2931110^ ;;^UTILITY(U,$J,.84,8029,2,1,0) ;;= |1| not currently compiled. ;;^UTILITY(U,$J,.84,8029,2,2,0) ;;=COMPILE the |1| ;;^UTILITY(U,$J,.84,8029,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8029,3,1,0) ;;=1^Contains the word 'TEMPLATE' or 'CROSS-REFERENCES' ;;^UTILITY(U,$J,.84,8029,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8029,5,1,0) ;;=DIOZ^ENCU ;;^UTILITY(U,$J,.84,8030,0) ;;=8030^2^y^5 ;;^UTILITY(U,$J,.84,8030,1,0) ;;=^^2^2^2931110^^^^ ;;^UTILITY(U,$J,.84,8030,1,1,0) ;;=Warning to user that SORT/PRINT templates are uneditable because the PRINT ;;^UTILITY(U,$J,.84,8030,1,2,0) ;;=TEMPLATE field on the SORT TEMPLATE has linked it with a print template. ;;^UTILITY(U,$J,.84,8030,2,0) ;;=^^7^7^2931112^ ;;^UTILITY(U,$J,.84,8030,2,1,0) ;;=Because this Sort Template has been linked with the Print Template ;;^UTILITY(U,$J,.84,8030,2,2,0) ;;=|1|, neither template can be edited from this option. ;;^UTILITY(U,$J,.84,8030,2,3,0) ;;= ;;^UTILITY(U,$J,.84,8030,2,4,0) ;;=To edit the templates, first use the FileMan TEMPLATE EDIT ;;^UTILITY(U,$J,.84,8030,2,5,0) ;;=option to edit the Sort Template, and delete the field called ;;^UTILITY(U,$J,.84,8030,2,6,0) ;;='PRINT TEMPLATE'. Then, the templates can be edited from ;;^UTILITY(U,$J,.84,8030,2,7,0) ;;=the PRINT option. ;;^UTILITY(U,$J,.84,8030,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8030,3,1,0) ;;=1^Name of associated PRINT TEMPLATE. ;;^UTILITY(U,$J,.84,8030,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8030,5,1,0) ;;=DIP^EN ;;^UTILITY(U,$J,.84,8031,0) ;;=8031^2^^5 ;;^UTILITY(U,$J,.84,8031,1,0) ;;=^^1^1^2931110^^ ;;^UTILITY(U,$J,.84,8031,1,1,0) ;;=Warning that compiled routine names may get too long. ;;^UTILITY(U,$J,.84,8031,2,0) ;;=^^3^3^2931110^ ;;^UTILITY(U,$J,.84,8031,2,1,0) ;;=WARNING!! Since the namespace for this routine is so long, use the ;;^UTILITY(U,$J,.84,8031,2,2,0) ;;=largest possible size to compile these routines. Otherwise, FileMan may ;;^UTILITY(U,$J,.84,8031,2,3,0) ;;=run out of routine names. ;;^UTILITY(U,$J,.84,8031,5,0) ;;=^.841^3^3 ;;^UTILITY(U,$J,.84,8031,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8031,5,2,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8031,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8032,0) ;;=8032^2^^5 ;;^UTILITY(U,$J,.84,8032,1,0) ;;=^^1^1^2930702^ ;;^UTILITY(U,$J,.84,8032,1,1,0) ;;=Words SEARCH TEMPLATE ;;^UTILITY(U,$J,.84,8032,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8032,2,1,0) ;;=Search Template ;;^UTILITY(U,$J,.84,8033,0) ;;=8033^2^^5 ;;^UTILITY(U,$J,.84,8033,1,0) ;;=^^1^1^2930701^^ ;;^UTILITY(U,$J,.84,8033,1,1,0) ;;=the words INPUT TEMPLATE to use in any FileMan dialog. ;;^UTILITY(U,$J,.84,8033,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8033,2,1,0) ;;=Input Template ;;^UTILITY(U,$J,.84,8033,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8033,5,1,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,8033,5,2,0) ;;=DIEZ^EN ;;^UTILITY(U,$J,.84,8034,0) ;;=8034^2^^5 ;;^UTILITY(U,$J,.84,8034,1,0) ;;=^^1^1^2930701^^ ;;^UTILITY(U,$J,.84,8034,1,1,0) ;;=The words PRINT TEMPLATE to use in any FileMan dialog. ;;^UTILITY(U,$J,.84,8034,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8034,2,1,0) ;;=Print Template ;;^UTILITY(U,$J,.84,8034,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8034,5,1,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,8034,5,2,0) ;;=DIPZ^EN ;;^UTILITY(U,$J,.84,8035,0) ;;=8035^2^^5 ;;^UTILITY(U,$J,.84,8035,1,0) ;;=^^1^1^2930701^ ;;^UTILITY(U,$J,.84,8035,1,1,0) ;;=The words SORT TEMPLATE to use in any FileMan dialog. ;;^UTILITY(U,$J,.84,8035,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8035,2,1,0) ;;=Sort Template ;;^UTILITY(U,$J,.84,8035,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8035,5,1,0) ;;=DIOZ^ENCU ;;^UTILITY(U,$J,.84,8036,0) ;;=8036^2^^5 ;;^UTILITY(U,$J,.84,8036,1,0) ;;=^^1^1^2930702^^ ;;^UTILITY(U,$J,.84,8036,1,1,0) ;;=The words CROSS-REFERENCE(S) to use in any FileMan Dialog. ;;^UTILITY(U,$J,.84,8036,2,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8036,2,1,0) ;;=Cross-Reference(s) ;;^UTILITY(U,$J,.84,8036,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8036,5,1,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,8036,5,2,0) ;;=DIKZ^EN ;;^UTILITY(U,$J,.84,8037,0) ;;=8037^2^^5 ;;^UTILITY(U,$J,.84,8037,1,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8037,1,1,0) ;;=The word SORT to use in any FileMan dialog. ;;^UTILITY(U,$J,.84,8037,2,0) ;;=^^1^1^2940526^ ;;^UTILITY(U,$J,.84,8037,2,1,0) ;;=sort ;;^UTILITY(U,$J,.84,8037,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8037,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8038,0) ;;=8038^2^^5 ;;^UTILITY(U,$J,.84,8038,1,0) ;;=^^1^1^2931110^ ;;^UTILITY(U,$J,.84,8038,1,1,0) ;;=The word SEARCH to use in any FileMan dialog. ;;^UTILITY(U,$J,.84,8038,2,0) ;;=^^1^1^2940526^ ;;^UTILITY(U,$J,.84,8038,2,1,0) ;;=search ;;^UTILITY(U,$J,.84,8038,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8038,5,1,0) ;;=DIP^EN1 ;;^UTILITY(U,$J,.84,8038,5,2,0) ;;=DIS^ENS ;;^UTILITY(U,$J,.84,8040,0) ;;=8040^2^^5 ;;^UTILITY(U,$J,.84,8040,1,0) ;;=^^1^1^2940314^^^ ;;^UTILITY(U,$J,.84,8040,1,1,0) ;;=Advice for the Yes/No question ;;^UTILITY(U,$J,.84,8040,2,0) ;;=^^1^1^2940314^^^ ;;^UTILITY(U,$J,.84,8040,2,1,0) ;;=Answer with 'Yes' or 'No' ;;^UTILITY(U,$J,.84,8041,0) ;;=8041^2^^5 ;;^UTILITY(U,$J,.84,8041,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8041,2,1,0) ;;=This is a required response. Enter '^' to exit ;;^UTILITY(U,$J,.84,8042,0) ;;=8042^2^y^5 ;;^UTILITY(U,$J,.84,8042,1,0) ;;=^^2^2^2940315^^^^ ;;^UTILITY(U,$J,.84,8042,1,1,0) ;;=This 'Select' prompt may be used for dialogs with filenames. ;;^UTILITY(U,$J,.84,8042,1,2,0) ;;=Note: Dialog will be used with $$EZBLD^DIALOG call, only one text line!! ;;^UTILITY(U,$J,.84,8042,2,0) ;;=1 ;;^UTILITY(U,$J,.84,8042,2,1,0) ;;=Select |1|: ;;^UTILITY(U,$J,.84,8042,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8042,3,1,0) ;;=1^Name of the file ;;^UTILITY(U,$J,.84,8043,0) ;;=8043^2^^5 ;;^UTILITY(U,$J,.84,8043,1,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,8043,1,1,0) ;;=Used for date time input to the reader. ;;^UTILITY(U,$J,.84,8043,2,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,8043,2,1,0) ;;= and time ;;^UTILITY(U,$J,.84,8044,0) ;;=8044^2^^5 DINIT00J DINIT00J ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;12:15 PM 6 Nov 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,8044,1,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,8044,1,1,0) ;;=Used for time input to the reader. ;;^UTILITY(U,$J,.84,8044,2,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,8044,2,1,0) ;;= and optional time ;;^UTILITY(U,$J,.84,8045,0) ;;=8045^2^y^5 ;;^UTILITY(U,$J,.84,8045,1,0) ;;=^^3^3^2940310^^^^ ;;^UTILITY(U,$J,.84,8045,1,1,0) ;;=This prompt is used by the reader when he is building prompts for ;;^UTILITY(U,$J,.84,8045,1,2,0) ;;=Set-of-codes type data. ;;^UTILITY(U,$J,.84,8045,1,3,0) ;;=Note: Dialog will be used with $$EZBLD^DIALOG call, only one text line!! ;;^UTILITY(U,$J,.84,8045,2,0) ;;=^^1^1^2940310^^^ ;;^UTILITY(U,$J,.84,8045,2,1,0) ;;=Enter |1|: ;;^UTILITY(U,$J,.84,8045,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8045,3,1,0) ;;=1^Default Prompt from DIR("A") ;;^UTILITY(U,$J,.84,8046,0) ;;=8046^2^^5 ;;^UTILITY(U,$J,.84,8046,1,0) ;;=^^1^1^2960124^^ ;;^UTILITY(U,$J,.84,8046,1,1,0) ;;=Reader prompt for choices from a list ;;^UTILITY(U,$J,.84,8046,2,0) ;;=^^1^1^2960124^^^ ;;^UTILITY(U,$J,.84,8046,2,1,0) ;;=Select one of the following: ;;^UTILITY(U,$J,.84,8047,0) ;;=8047^2^^5 ;;^UTILITY(U,$J,.84,8047,1,0) ;;=^^1^1^2940315^^^^ ;;^UTILITY(U,$J,.84,8047,1,1,0) ;;=Part one of the Replace with prompt (including spaces). ;;^UTILITY(U,$J,.84,8047,2,0) ;;=^^1^1^2940315^^^^ ;;^UTILITY(U,$J,.84,8047,2,1,0) ;;= Replace ;;^UTILITY(U,$J,.84,8048,0) ;;=8048^2^^5 ;;^UTILITY(U,$J,.84,8048,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8048,1,1,0) ;;=Part two of the Replace With editor (including spaces). ;;^UTILITY(U,$J,.84,8048,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8048,2,1,0) ;;= With ;;^UTILITY(U,$J,.84,8050,0) ;;=8050^2^^5 ;;^UTILITY(U,$J,.84,8050,1,0) ;;=^^2^2^2971125^ ;;^UTILITY(U,$J,.84,8050,1,1,0) ;;=Print the word 'Another' when prompting user to select another entry in ;;^UTILITY(U,$J,.84,8050,1,2,0) ;;=Inquire mode. ;;^UTILITY(U,$J,.84,8050,2,0) ;;=^^1^1^2971125^ ;;^UTILITY(U,$J,.84,8050,2,1,0) ;;=Another ;;^UTILITY(U,$J,.84,8050,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8050,5,1,0) ;;=DIC11^GETPRMT ;;^UTILITY(U,$J,.84,8051,0) ;;=8051^2^^5 ;;^UTILITY(U,$J,.84,8051,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8051,1,1,0) ;;=Reader prompt ;;^UTILITY(U,$J,.84,8051,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8051,2,1,0) ;;=Enter response: ;;^UTILITY(U,$J,.84,8052,0) ;;=8052^2^^5 ;;^UTILITY(U,$J,.84,8052,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8052,1,1,0) ;;=Prompt for the reader ;;^UTILITY(U,$J,.84,8052,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8052,2,1,0) ;;=Enter Yes or No: ;;^UTILITY(U,$J,.84,8053,0) ;;=8053^2^^5 ;;^UTILITY(U,$J,.84,8053,1,0) ;;=^^1^1^2940316^^ ;;^UTILITY(U,$J,.84,8053,1,1,0) ;;=Prompt for the reader: End of page ;;^UTILITY(U,$J,.84,8053,2,0) ;;=^^1^1^2940316^^ ;;^UTILITY(U,$J,.84,8053,2,1,0) ;;=Type to continue or '^' to exit: ;;^UTILITY(U,$J,.84,8054,0) ;;=8054^2^^5 ;;^UTILITY(U,$J,.84,8054,1,0) ;;=^^1^1^2940310^^ ;;^UTILITY(U,$J,.84,8054,1,1,0) ;;=Prompt for the reader: numbers ;;^UTILITY(U,$J,.84,8054,2,0) ;;=^^1^1^2940310^^ ;;^UTILITY(U,$J,.84,8054,2,1,0) ;;=Enter a number ;;^UTILITY(U,$J,.84,8055,0) ;;=8055^2^^5 ;;^UTILITY(U,$J,.84,8055,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8055,1,1,0) ;;=Prompt for the reader: date ;;^UTILITY(U,$J,.84,8055,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8055,2,1,0) ;;=Enter a date ;;^UTILITY(U,$J,.84,8056,0) ;;=8056^2^^5 ;;^UTILITY(U,$J,.84,8056,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8056,1,1,0) ;;=Prompt for the reader: List ;;^UTILITY(U,$J,.84,8056,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8056,2,1,0) ;;=Enter a list or range of numbers ;;^UTILITY(U,$J,.84,8057,0) ;;=8057^2^^5 ;;^UTILITY(U,$J,.84,8057,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8057,1,1,0) ;;=Prompt for the Reader: Pointers ;;^UTILITY(U,$J,.84,8057,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,8057,2,1,0) ;;=Select: ;;^UTILITY(U,$J,.84,8058,0) ;;=8058^2^y^5 ;;^UTILITY(U,$J,.84,8058,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8058,1,1,0) ;;=Part II of the 'Are you adding a new...' question ;;^UTILITY(U,$J,.84,8058,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8058,2,1,0) ;;= (the |1| ;;^UTILITY(U,$J,.84,8058,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8058,3,1,0) ;;=1^Ordinal number of new entry ;;^UTILITY(U,$J,.84,8059,0) ;;=8059^2^y^5 ;;^UTILITY(U,$J,.84,8059,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8059,1,1,0) ;;=Part III of the 'Are you adding a new...' question ;;^UTILITY(U,$J,.84,8059,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8059,2,1,0) ;;= for this |1| ;;^UTILITY(U,$J,.84,8059,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8059,3,1,0) ;;=1^Filename ;;^UTILITY(U,$J,.84,8060,0) ;;=8060^2^^5 ;;^UTILITY(U,$J,.84,8060,1,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,8060,1,1,0) ;;=Part Ia of the 'Are you adding...' message ;;^UTILITY(U,$J,.84,8060,2,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,8060,2,1,0) ;;= Are you adding ;;^UTILITY(U,$J,.84,8061,0) ;;=8061^2^y^5 ;;^UTILITY(U,$J,.84,8061,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8061,1,1,0) ;;=Part Ib of the 'Are you adding...' question ;;^UTILITY(U,$J,.84,8061,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8061,2,1,0) ;;='|1|' as ;;^UTILITY(U,$J,.84,8061,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8061,3,1,0) ;;=1^Input value for .01 field ;;^UTILITY(U,$J,.84,8062,0) ;;=8062^2^y^5 ;;^UTILITY(U,$J,.84,8062,1,0) ;;=^^1^1^2940314^^^ ;;^UTILITY(U,$J,.84,8062,1,1,0) ;;=Part Ic of the "Are you adding..." message ;;^UTILITY(U,$J,.84,8062,2,0) ;;=^^1^1^2940314^^^^ ;;^UTILITY(U,$J,.84,8062,2,1,0) ;;=a new |1| ;;^UTILITY(U,$J,.84,8062,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8062,3,1,0) ;;=1^Filename ;;^UTILITY(U,$J,.84,8063,0) ;;=8063^2^y^5 ;;^UTILITY(U,$J,.84,8063,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8063,1,1,0) ;;=Lookup Part I ;;^UTILITY(U,$J,.84,8063,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8063,2,1,0) ;;= Answer with |1| ;;^UTILITY(U,$J,.84,8063,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8063,3,1,0) ;;=1^Filename ;;^UTILITY(U,$J,.84,8064,0) ;;=8064^2^^5 ;;^UTILITY(U,$J,.84,8064,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8064,1,1,0) ;;=Lookup Part II ;;^UTILITY(U,$J,.84,8064,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8064,2,1,0) ;;= Do you want the entire ;;^UTILITY(U,$J,.84,8065,0) ;;=8065^2^y^5 ;;^UTILITY(U,$J,.84,8065,1,0) ;;=^^1^1^2940314^^ ;;^UTILITY(U,$J,.84,8065,1,1,0) ;;=Lookup Part III DINIT00K DINIT00K ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;22MAY2004 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,8065,2,0) ;;=^^1^1^2940314^^^ ;;^UTILITY(U,$J,.84,8065,2,1,0) ;;=|1|-Entry ;;^UTILITY(U,$J,.84,8065,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8065,3,1,0) ;;=1^Number of entries in list ;;^UTILITY(U,$J,.84,8066,0) ;;=8066^2^y^5 ;;^UTILITY(U,$J,.84,8066,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8066,1,1,0) ;;=Lookup Part IV ;;^UTILITY(U,$J,.84,8066,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8066,2,1,0) ;;=|1| List ;;^UTILITY(U,$J,.84,8066,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8066,3,1,0) ;;=1^Filename ;;^UTILITY(U,$J,.84,8067,0) ;;=8067^2^^5 ;;^UTILITY(U,$J,.84,8067,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8067,1,1,0) ;;=For list of Fields on Lookup ;;^UTILITY(U,$J,.84,8067,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8067,2,1,0) ;;=, or ;;^UTILITY(U,$J,.84,8068,0) ;;=8068^2^^5 ;;^UTILITY(U,$J,.84,8068,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8068,1,1,0) ;;=The Chooser ;;^UTILITY(U,$J,.84,8068,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8068,2,1,0) ;;=Choose from: ;;^UTILITY(U,$J,.84,8069,0) ;;=8069^2^y^5 ;;^UTILITY(U,$J,.84,8069,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8069,1,1,0) ;;=New entry allowed message ;;^UTILITY(U,$J,.84,8069,2,0) ;;=^^1^1^2940315^^ ;;^UTILITY(U,$J,.84,8069,2,1,0) ;;=You may enter a new |1|, if you wish ;;^UTILITY(U,$J,.84,8069,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8069,3,1,0) ;;=1^Filename ;;^UTILITY(U,$J,.84,8070,0) ;;=8070^2^y^5 ;;^UTILITY(U,$J,.84,8070,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8070,1,1,0) ;;=Variable Pointer Lookup ;;^UTILITY(U,$J,.84,8070,2,0) ;;=^^1^1^2980304^ ;;^UTILITY(U,$J,.84,8070,2,1,0) ;;= Searching for a |1| ;;^UTILITY(U,$J,.84,8070,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8070,3,1,0) ;;=1^Filename ;;^UTILITY(U,$J,.84,8071,0) ;;=8071^2^^5 ;;^UTILITY(U,$J,.84,8071,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8071,1,1,0) ;;=Variable Pointer lookup ;;^UTILITY(U,$J,.84,8071,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8071,2,1,0) ;;=Enter one of the following: ;;^UTILITY(U,$J,.84,8072,0) ;;=8072^2^y^5 ;;^UTILITY(U,$J,.84,8072,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8072,1,1,0) ;;=Variable Pointer Lookup ;;^UTILITY(U,$J,.84,8072,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8072,2,1,0) ;;= |1|.EntryName to select a |2| ;;^UTILITY(U,$J,.84,8072,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,8072,3,1,0) ;;=1^Prefix ;;^UTILITY(U,$J,.84,8072,3,2,0) ;;=2^Filename ;;^UTILITY(U,$J,.84,8073,0) ;;=8073^2^^5 ;;^UTILITY(U,$J,.84,8073,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8073,1,1,0) ;;=Variable Pointer Lookup ;;^UTILITY(U,$J,.84,8073,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8073,2,1,0) ;;=To see the entries in any particular file type ;;^UTILITY(U,$J,.84,8074,0) ;;=8074^2^^5 ;;^UTILITY(U,$J,.84,8074,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8074,1,1,0) ;;=How to call for help ;;^UTILITY(U,$J,.84,8074,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,8074,2,1,0) ;;=Press H for help ;;^UTILITY(U,$J,.84,8074.1,0) ;;=8074.1^2^^5 ;;^UTILITY(U,$J,.84,8074.1,1,0) ;;=^^1^1^3040430 ;;^UTILITY(U,$J,.84,8074.1,1,1,0) ;;=How to click for help ;;^UTILITY(U,$J,.84,8074.1,2,0) ;;=^^1^1^3040430 ;;^UTILITY(U,$J,.84,8074.1,2,1,0) ;;=HELP ;;^UTILITY(U,$J,.84,8075,0) ;;=8075^2^^5 ;;^UTILITY(U,$J,.84,8075,1,0) ;;=^^1^1^2940524^^ ;;^UTILITY(U,$J,.84,8075,1,1,0) ;;=Save changes question on form exit ;;^UTILITY(U,$J,.84,8075,2,0) ;;=^^1^1^2940524^^ ;;^UTILITY(U,$J,.84,8075,2,1,0) ;;=Save changes before leaving form (Y/N)? ;;^UTILITY(U,$J,.84,8076,0) ;;=8076^2^^5 ;;^UTILITY(U,$J,.84,8076,1,0) ;;=^^1^1^2940315^ ;;^UTILITY(U,$J,.84,8076,1,1,0) ;;=Timeout ;;^UTILITY(U,$J,.84,8076,2,0) ;;=^^1^1^2940315^ ;;^UTILITY(U,$J,.84,8076,2,1,0) ;;=Timed out. ;;^UTILITY(U,$J,.84,8077,0) ;;=8077^2^^5 ;;^UTILITY(U,$J,.84,8077,1,0) ;;=^^1^1^2940315^ ;;^UTILITY(U,$J,.84,8077,1,1,0) ;;=Changes not saved on leaving form ;;^UTILITY(U,$J,.84,8077,2,0) ;;=^^1^1^2940315^ ;;^UTILITY(U,$J,.84,8077,2,1,0) ;;=Changes not saved! ;;^UTILITY(U,$J,.84,8078,0) ;;=8078^2^^5 ;;^UTILITY(U,$J,.84,8078,1,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,8078,1,1,0) ;;=Wording for record ;;^UTILITY(U,$J,.84,8078,2,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,8078,2,1,0) ;;=record ;;^UTILITY(U,$J,.84,8079,0) ;;=8079^2^^5 ;;^UTILITY(U,$J,.84,8079,1,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,8079,1,1,0) ;;=Wording for Subrecord ;;^UTILITY(U,$J,.84,8079,2,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,8079,2,1,0) ;;=Subrecord ;;^UTILITY(U,$J,.84,8080,0) ;;=8080^2^y^5 ;;^UTILITY(U,$J,.84,8080,1,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,8080,1,1,0) ;;=Warning for immediate deletion of entries. ;;^UTILITY(U,$J,.84,8080,2,0) ;;=^^3^3^2940316^ ;;^UTILITY(U,$J,.84,8080,2,1,0) ;;= WARNING: DELETIONS ARE DONE IMMEDIATELY! ;;^UTILITY(U,$J,.84,8080,2,2,0) ;;= (EXITING WITHOUT SAVING WILL NOT RESTORE DELETED RECORDS.) ;;^UTILITY(U,$J,.84,8080,2,3,0) ;;=Are you sure you want to delete this entire |1| (Y/N)? ;;^UTILITY(U,$J,.84,8080,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8080,3,1,0) ;;=1^Record or Subrecord ;;^UTILITY(U,$J,.84,8081,0) ;;=8081^2^y^5 ;;^UTILITY(U,$J,.84,8081,1,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,8081,1,1,0) ;;=Choose from-to dialog ;;^UTILITY(U,$J,.84,8081,2,0) ;;=^^1^1^2940316^^ ;;^UTILITY(U,$J,.84,8081,2,1,0) ;;=Choose |1| or '^' to quit: ;;^UTILITY(U,$J,.84,8081,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8081,3,1,0) ;;=1^Number range for selection ;;^UTILITY(U,$J,.84,8082,0) ;;=8082^2^^5 ;;^UTILITY(U,$J,.84,8082,1,0) ;;=^^2^2^2940318^^^^ ;;^UTILITY(U,$J,.84,8082,1,1,0) ;;=Used to build error prompts in the TRANSFER/MERGE routine ^DIT3. Could be ;;^UTILITY(U,$J,.84,8082,1,2,0) ;;=used elsewhere, however, so I didn't put it into the ERROR category. ;;^UTILITY(U,$J,.84,8082,2,0) ;;=^^1^1^2940318^ ;;^UTILITY(U,$J,.84,8082,2,1,0) ;;=Transfer FROM ;;^UTILITY(U,$J,.84,8082,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8082,5,1,0) ;;=DIT^TRNMRG ;;^UTILITY(U,$J,.84,8083,0) ;;=8083^2^^5 ;;^UTILITY(U,$J,.84,8083,1,0) ;;=^^2^2^2940318^^^^ ;;^UTILITY(U,$J,.84,8083,1,1,0) ;;=Used to build error prompts in the TRANSFER/MERGE routine ^DIT3. Could be ;;^UTILITY(U,$J,.84,8083,1,2,0) ;;=used elsewhere, however, so I didn't put it into the ERROR category. ;;^UTILITY(U,$J,.84,8083,2,0) ;;=^^1^1^2940318^ ;;^UTILITY(U,$J,.84,8083,2,1,0) ;;=Transfer TO ;;^UTILITY(U,$J,.84,8083,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8083,5,1,0) ;;=DIT^TRNMRG ;;^UTILITY(U,$J,.84,8084,0) ;;=8084^2^^5 ;;^UTILITY(U,$J,.84,8084,1,0) ;;=^^1^1^2940318^ ;;^UTILITY(U,$J,.84,8084,1,1,0) ;;=The words 'file number' to be used in any dialog. DINIT00L DINIT00L ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;29AUG2003 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,8084,2,0) ;;=^^1^1^2940318^ ;;^UTILITY(U,$J,.84,8084,2,1,0) ;;=file number ;;^UTILITY(U,$J,.84,8084,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8084,5,1,0) ;;=DIT^TRNMRG ;;^UTILITY(U,$J,.84,8085,0) ;;=8085^2^^5 ;;^UTILITY(U,$J,.84,8085,1,0) ;;=^^1^1^2940426^^ ;;^UTILITY(U,$J,.84,8085,1,1,0) ;;=The words 'IEN string' to be used in any dialog. ;;^UTILITY(U,$J,.84,8085,2,0) ;;=^^1^1^2940426^^ ;;^UTILITY(U,$J,.84,8085,2,1,0) ;;=IEN string ;;^UTILITY(U,$J,.84,8085,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8085,5,1,0) ;;=DIT^TRNMRG ;;^UTILITY(U,$J,.84,8086,0) ;;=8086^2^^5 ;;^UTILITY(U,$J,.84,8086,1,0) ;;=^^1^1^2940608^^^^ ;;^UTILITY(U,$J,.84,8086,1,1,0) ;;=Warning to use the merge only during non-peak times. ;;^UTILITY(U,$J,.84,8086,2,0) ;;=^^5^5^2940608^ ;;^UTILITY(U,$J,.84,8086,2,1,0) ;;= ;;^UTILITY(U,$J,.84,8086,2,2,0) ;;=NOTE: Use this option ONLY DURING NON-PEAK HOURS if merging entries in a ;;^UTILITY(U,$J,.84,8086,2,3,0) ;;=file that is pointed-to either by many files, or by large files. ;;^UTILITY(U,$J,.84,8086,2,4,0) ;;= ;;^UTILITY(U,$J,.84,8086,2,5,0) ;;=MERGE ENTRIES AFTER COMPARING THEM ;;^UTILITY(U,$J,.84,8087,0) ;;=8087^2^y^5^End of Page message for Lookup (DIC) ;;^UTILITY(U,$J,.84,8087,1,0) ;;=^^2^2^2970529^ ;;^UTILITY(U,$J,.84,8087,1,1,0) ;;=Displays the end of page message displayed at the bottom of a screen after ;;^UTILITY(U,$J,.84,8087,1,2,0) ;;=a list of selectable entries is displayed during lookup (^DIC). ;;^UTILITY(U,$J,.84,8087,2,0) ;;=^^1^1^2970529^ ;;^UTILITY(U,$J,.84,8087,2,1,0) ;;=Press to see more, '^' to exit this list, |T| OR ;;^UTILITY(U,$J,.84,8087,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,8087,3,1,0) ;;=T^TO EXIT ALL LISTS ;;^UTILITY(U,$J,.84,8087,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8087,5,1,0) ;;=DIC1^DSP ;;^UTILITY(U,$J,.84,8088,0) ;;=8088^2^y^5 ;;^UTILITY(U,$J,.84,8088,1,0) ;;=^^2^2^2970529^^ ;;^UTILITY(U,$J,.84,8088,1,1,0) ;;=Message directing the user to Choose one of the displayed selections ;;^UTILITY(U,$J,.84,8088,1,2,0) ;;=during lookup (^DIC). ;;^UTILITY(U,$J,.84,8088,2,0) ;;=^^1^1^2970529^ ;;^UTILITY(U,$J,.84,8088,2,1,0) ;;=CHOOSE |1|-|2|: ;;^UTILITY(U,$J,.84,8088,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,8088,3,1,0) ;;=1^Starting number in displayed list ;;^UTILITY(U,$J,.84,8088,3,2,0) ;;=2^Ending number in displayed list ;;^UTILITY(U,$J,.84,8088,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8088,5,1,0) ;;=DIC1^DSP ;;^UTILITY(U,$J,.84,8089,0) ;;=8089^2^y^5 ;;^UTILITY(U,$J,.84,8089,1,0) ;;=^^2^2^2970609^^ ;;^UTILITY(U,$J,.84,8089,1,1,0) ;;=Message used during interactive ^DIC to display the file and index name ;;^UTILITY(U,$J,.84,8089,1,2,0) ;;=on which the displayed entries were found. ;;^UTILITY(U,$J,.84,8089,2,0) ;;=^^1^1^2970609^^ ;;^UTILITY(U,$J,.84,8089,2,1,0) ;;=Matches to: |1| |2|. ;;^UTILITY(U,$J,.84,8089,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,8089,3,1,0) ;;=1^File name ;;^UTILITY(U,$J,.84,8089,3,2,0) ;;=2^Indexed field name ;;^UTILITY(U,$J,.84,8089,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8089,5,1,0) ;;=DIC1^DSP ;;^UTILITY(U,$J,.84,8090,0) ;;=8090^2^^5 ;;^UTILITY(U,$J,.84,8090,1,0) ;;=^^3^3^2970626^ ;;^UTILITY(U,$J,.84,8090,1,1,0) ;;=Used in displaying an error message when the lookup value X does not pass ;;^UTILITY(U,$J,.84,8090,1,2,0) ;;=the Pre-lookup transform code (^DD(File#,.01,7.5) node) during ^DIC or ;;^UTILITY(U,$J,.84,8090,1,3,0) ;;=Finder lookups. ;;^UTILITY(U,$J,.84,8090,2,0) ;;=^^1^1^2970626^ ;;^UTILITY(U,$J,.84,8090,2,1,0) ;;=Pre-lookup transform (7.5 node) ;;^UTILITY(U,$J,.84,8090,5,0) ;;=^.841^2^2 ;;^UTILITY(U,$J,.84,8090,5,1,0) ;;=DIC ;;^UTILITY(U,$J,.84,8090,5,2,0) ;;=DICF ;;^UTILITY(U,$J,.84,8091,0) ;;=8091^1^^5^ ;;^UTILITY(U,$J,.84,8091,1,0) ;;=^^1^1^2970715^ ;;^UTILITY(U,$J,.84,8091,1,1,0) ;;=Error set when user times out. ;;^UTILITY(U,$J,.84,8091,2,0) ;;=^^1^1^2970715^ ;;^UTILITY(U,$J,.84,8091,2,1,0) ;;=User timed out. ;;^UTILITY(U,$J,.84,8091,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8091,5,1,0) ;;=DIC1^Y ;;^UTILITY(U,$J,.84,8092,0) ;;=8092^1^^5 ;;^UTILITY(U,$J,.84,8092,1,0) ;;=^^1^1^2970715^ ;;^UTILITY(U,$J,.84,8092,1,1,0) ;;=Error when user up-arrows out. ;;^UTILITY(U,$J,.84,8092,2,0) ;;=^^1^1^2970715^ ;;^UTILITY(U,$J,.84,8092,2,1,0) ;;=User up-arrowed out. ;;^UTILITY(U,$J,.84,8092,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8092,5,1,0) ;;=DIC1^Y ;;^UTILITY(U,$J,.84,8093,0) ;;=8093^1^^5 ;;^UTILITY(U,$J,.84,8093,1,0) ;;=^^4^4^2970722^ ;;^UTILITY(U,$J,.84,8093,1,1,0) ;;=Error that occurs when user passes too many lookup values to either the ;;^UTILITY(U,$J,.84,8093,1,2,0) ;;=Finder call ^DICF or the FileMan lookup ^DIC. When the number of lookup ;;^UTILITY(U,$J,.84,8093,1,3,0) ;;=values exceeds the number of subscripts in the index passed (or the ;;^UTILITY(U,$J,.84,8093,1,4,0) ;;=default index if no index is passed). ;;^UTILITY(U,$J,.84,8093,2,0) ;;=^^1^1^2970722^ ;;^UTILITY(U,$J,.84,8093,2,1,0) ;;=Too many lookup values for this index. ;;^UTILITY(U,$J,.84,8093,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8093,5,1,0) ;;=DIC3^ASK ;;^UTILITY(U,$J,.84,8094,0) ;;=8094^1^^5 ;;^UTILITY(U,$J,.84,8094,1,0) ;;=^^3^3^2970820^ ;;^UTILITY(U,$J,.84,8094,1,1,0) ;;=Error message returned from ^DICF or ^DIC when flags parameter or ;;^UTILITY(U,$J,.84,8094,1,2,0) ;;=DIC(0) contains an "X", but not enough lookup values passed for the number ;;^UTILITY(U,$J,.84,8094,1,3,0) ;;=of subscripts in the lookup index. ;;^UTILITY(U,$J,.84,8094,2,0) ;;=^^1^1^2970820^ ;;^UTILITY(U,$J,.84,8094,2,1,0) ;;=Not enough lookup values provided for an exact match on this index. ;;^UTILITY(U,$J,.84,8094,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8094,5,1,0) ;;=DIC31^CHKVAL1 ;;^UTILITY(U,$J,.84,8095,0) ;;=8095^1^^5 ;;^UTILITY(U,$J,.84,8095,1,0) ;;=^^3^3^2990104^^ ;;^UTILITY(U,$J,.84,8095,1,1,0) ;;=In calls to the Finder, IX^DIC or MIX^DIC, if the first index passed (or ;;^UTILITY(U,$J,.84,8095,1,2,0) ;;=the default index) is a compound index, then only one index can be passed, ;;^UTILITY(U,$J,.84,8095,1,3,0) ;;=so DIC(0) (or flags) cannot contain "M". ;;^UTILITY(U,$J,.84,8095,2,0) ;;=^^1^1^2990104^ ;;^UTILITY(U,$J,.84,8095,2,1,0) ;;=First lookup index is compound, so "M"ultiple index lookups not allowed. ;;^UTILITY(U,$J,.84,8095,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8095,5,1,0) ;;=DIC31^CHKVAL1 ;;^UTILITY(U,$J,.84,8096,0) ;;=8096^1^^5 ;;^UTILITY(U,$J,.84,8096,1,0) ;;=^^2^2^2971001^ ;;^UTILITY(U,$J,.84,8096,1,1,0) ;;=Error message from ^DIC or ^DICQ when DIC contains a subfile number DINIT00M DINIT00M ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 3/30/99 10:41:48 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,8096,1,2,0) ;;=instead of an open global root, and the DA array is not defined. ;;^UTILITY(U,$J,.84,8096,2,0) ;;=^^1^1^2971001^ ;;^UTILITY(U,$J,.84,8096,2,1,0) ;;=If DIC contains a subfile number, DA array must be defined. ;;^UTILITY(U,$J,.84,8096,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,8096,5,1,0) ;;=DIC0^GETFILE ;;^UTILITY(U,$J,.84,8097,0) ;;=8097^2^y^5 ;;^UTILITY(U,$J,.84,8097,1,0) ;;=^^1^1^2980304^^^ ;;^UTILITY(U,$J,.84,8097,1,1,0) ;;=Variable Pointer Lookup ;;^UTILITY(U,$J,.84,8097,2,0) ;;=^^1^1^2980304^ ;;^UTILITY(U,$J,.84,8097,2,1,0) ;;= Searching for a |1|, (pointed-to by |2|) ;;^UTILITY(U,$J,.84,8097,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,8097,3,1,0) ;;=1^Pointed-to Filename ;;^UTILITY(U,$J,.84,8097,3,2,0) ;;=2^Pointing field name ;;^UTILITY(U,$J,.84,8098,0) ;;=8098^2^^5 ;;^UTILITY(U,$J,.84,8098,2,0) ;;=^^1^1^2980603^^^^ ;;^UTILITY(U,$J,.84,8098,2,1,0) ;;=file^File^subfile^Subfile ;;^UTILITY(U,$J,.84,9002,0) ;;=9002^3^y^5 ;;^UTILITY(U,$J,.84,9002,1,0) ;;=^^1^1^2930617^^ ;;^UTILITY(U,$J,.84,9002,1,1,0) ;;=Help for entering maximum routine size for compiled routines. ;;^UTILITY(U,$J,.84,9002,2,0) ;;=^^4^4^2930629^^^^ ;;^UTILITY(U,$J,.84,9002,2,1,0) ;;=This number will be used to determine how large to make the generated ;;^UTILITY(U,$J,.84,9002,2,2,0) ;;=compiled |1| routines. The size must be a number greater ;;^UTILITY(U,$J,.84,9002,2,3,0) ;;=than 2400, the larger the better, up to the maximum routine size for ;;^UTILITY(U,$J,.84,9002,2,4,0) ;;=your operating system. ;;^UTILITY(U,$J,.84,9002,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,9002,3,1,0) ;;=1^Will be the word 'TEMPLATE' when compiling templates, or 'cross-reference' when compiling CROSS-REFERENCES. ;;^UTILITY(U,$J,.84,9002,5,0) ;;=^.841^3^3 ;;^UTILITY(U,$J,.84,9002,5,1,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,9002,5,2,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,9002,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,9004,0) ;;=9004^3^y^5 ;;^UTILITY(U,$J,.84,9004,1,0) ;;=^^2^2^2931110^^^^ ;;^UTILITY(U,$J,.84,9004,1,1,0) ;;=Help asking the user whether they wish to UNCOMPILE previously compiled ;;^UTILITY(U,$J,.84,9004,1,2,0) ;;=templates or cross-references. ;;^UTILITY(U,$J,.84,9004,2,0) ;;=^^4^4^2931110^^ ;;^UTILITY(U,$J,.84,9004,2,1,0) ;;= Answer YES to UNCOMPILE the |1|. ;;^UTILITY(U,$J,.84,9004,2,2,0) ;;=The compiled routine will no longer be used. ;;^UTILITY(U,$J,.84,9004,2,3,0) ;;= ;;^UTILITY(U,$J,.84,9004,2,4,0) ;;= Answer NO to recompile the |1| at this time. ;;^UTILITY(U,$J,.84,9004,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,9004,3,1,0) ;;=1^Will contain either the word 'TEMPLATE' or 'CROSS-REFERENCES. ;;^UTILITY(U,$J,.84,9004,5,0) ;;=^.841^3^3 ;;^UTILITY(U,$J,.84,9004,5,1,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,9004,5,2,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,9004,5,3,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,9006,0) ;;=9006^3^y^5 ;;^UTILITY(U,$J,.84,9006,1,0) ;;=^^2^2^2931105^^^^ ;;^UTILITY(U,$J,.84,9006,1,1,0) ;;=Help for prompting for compiled routine name, when compiling templates ;;^UTILITY(U,$J,.84,9006,1,2,0) ;;=or cross-references. ;;^UTILITY(U,$J,.84,9006,2,0) ;;=^^2^2^2931109^ ;;^UTILITY(U,$J,.84,9006,2,1,0) ;;=Enter a valid MUMPS routine name of from 3 to |1| characters. This must ;;^UTILITY(U,$J,.84,9006,2,2,0) ;;=be entered without a leading up-arrow, and cannot begin with "DI". ;;^UTILITY(U,$J,.84,9006,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,9006,3,1,0) ;;=1^Internal parameter indicating the maximum number of characters allowed for routine namespace. ;;^UTILITY(U,$J,.84,9006,5,0) ;;=^.841^4^4 ;;^UTILITY(U,$J,.84,9006,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,9006,5,2,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,9006,5,3,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,9006,5,4,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,9014,0) ;;=9014^3^^5 ;;^UTILITY(U,$J,.84,9014,1,0) ;;=^^1^1^2930706^^^^ ;;^UTILITY(U,$J,.84,9014,1,1,0) ;;=Help prompt for compiling sort templates. ;;^UTILITY(U,$J,.84,9014,2,0) ;;=^^3^3^2931110^ ;;^UTILITY(U,$J,.84,9014,2,1,0) ;;=If YES is entered, ;;^UTILITY(U,$J,.84,9014,2,2,0) ;;=the Sort logic will be compiled into a routine at the ;;^UTILITY(U,$J,.84,9014,2,3,0) ;;=time the template is used in a FileMan Sort/Print. ;;^UTILITY(U,$J,.84,9014,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9014,5,1,0) ;;=DIOZ^ENCU ;;^UTILITY(U,$J,.84,9019,0) ;;=9019^3^^5 ;;^UTILITY(U,$J,.84,9019,1,0) ;;=^^1^1^2931110^^^^ ;;^UTILITY(U,$J,.84,9019,1,1,0) ;;=Help prompt for Uncompiling sort templates. ;;^UTILITY(U,$J,.84,9019,2,0) ;;=^^3^3^2931110^ ;;^UTILITY(U,$J,.84,9019,2,1,0) ;;=If YES is entered, ;;^UTILITY(U,$J,.84,9019,2,2,0) ;;=the Sort logic for this template will NOT be compiled into a ;;^UTILITY(U,$J,.84,9019,2,3,0) ;;=routine during the time it is used by a FileMan sort/print. ;;^UTILITY(U,$J,.84,9019,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9019,5,1,0) ;;=DIOZ^ENCU ;;^UTILITY(U,$J,.84,9024,0) ;;=9024^3^^5 ;;^UTILITY(U,$J,.84,9024,1,0) ;;=^^2^2^2931105^ ;;^UTILITY(U,$J,.84,9024,1,1,0) ;;=Help for the POST-SELECTION ACTION field for a file. This entry is put ;;^UTILITY(U,$J,.84,9024,1,2,0) ;;=in from the Utility option to edit a file. ;;^UTILITY(U,$J,.84,9024,2,0) ;;=^^1^1^2931105^^^ ;;^UTILITY(U,$J,.84,9024,2,1,0) ;;=This code will be executed whenever an entry is selected from the file. ;;^UTILITY(U,$J,.84,9024,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9024,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,9025,0) ;;=9025^3^^5 ;;^UTILITY(U,$J,.84,9025,1,0) ;;=^^1^1^2931105^^ ;;^UTILITY(U,$J,.84,9025,1,1,0) ;;=General help for MUMPS type fields. ;;^UTILITY(U,$J,.84,9025,2,0) ;;=^^1^1^2931105^ ;;^UTILITY(U,$J,.84,9025,2,1,0) ;;=Enter a line of standard MUMPS code. ;;^UTILITY(U,$J,.84,9025,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9025,5,1,0) ;;=DIOU^6 ;;^UTILITY(U,$J,.84,9026,0) ;;=9026^3^^5 ;;^UTILITY(U,$J,.84,9026,1,0) ;;=^^3^3^2931105^^ ;;^UTILITY(U,$J,.84,9026,1,1,0) ;;=The DD for the file of files is not completely FileMan compatible. This ;;^UTILITY(U,$J,.84,9026,1,2,0) ;;=is the standard help prompt for the LOOK-UP PROGRAM field on the file of ;;^UTILITY(U,$J,.84,9026,1,3,0) ;;=files. Prompt appears when file attributes are being edited. ;;^UTILITY(U,$J,.84,9026,2,0) ;;=^^2^2^2931105^^ ;;^UTILITY(U,$J,.84,9026,2,1,0) ;;=This special lookup routine will be executed instead of the standard ;;^UTILITY(U,$J,.84,9026,2,2,0) ;;=FileMan lookup logic, whenever a call is made to ^DIC. DINIT00N DINIT00N ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;06:19 PM 21 Aug 2002 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,9026,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9026,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,9027,0) ;;=9027^3^^5 ;;^UTILITY(U,$J,.84,9027,1,0) ;;=^^3^3^2931105^ ;;^UTILITY(U,$J,.84,9027,1,1,0) ;;=The DD for the file of files is not completely FileMan compatible. This ;;^UTILITY(U,$J,.84,9027,1,2,0) ;;=is the standard help prompt for the CROSS-REFERENCE ROUTINE field on the ;;^UTILITY(U,$J,.84,9027,1,3,0) ;;=file of files. Prompt appears when file attributes are being edited. ;;^UTILITY(U,$J,.84,9027,2,0) ;;=^^5^5^2931109^ ;;^UTILITY(U,$J,.84,9027,2,1,0) ;;=If a NEW routine name is entered, but the cross-references are not ;;^UTILITY(U,$J,.84,9027,2,2,0) ;;=compiled at this time, the routine name will be automatically deleted. ;;^UTILITY(U,$J,.84,9027,2,3,0) ;;= ;;^UTILITY(U,$J,.84,9027,2,4,0) ;;=If the routine name is deleted, the cross-references are considered ;;^UTILITY(U,$J,.84,9027,2,5,0) ;;=uncompiled, and FileMan will not use the routine for re-indexing. ;;^UTILITY(U,$J,.84,9027,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9027,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,9028,0) ;;=9028^3^^5 ;;^UTILITY(U,$J,.84,9028,1,0) ;;=^^3^3^2931109^ ;;^UTILITY(U,$J,.84,9028,1,1,0) ;;=Help prompt for CROSS-REFERENCE ROUTINE name when editing file attributes. ;;^UTILITY(U,$J,.84,9028,1,2,0) ;;= If the user does not changes the name of the CROSS-REFERENCE ROUTINE, ;;^UTILITY(U,$J,.84,9028,1,3,0) ;;=then recompilation is not required, and they will see this help prompt. ;;^UTILITY(U,$J,.84,9028,2,0) ;;=^^2^2^2931109^ ;;^UTILITY(U,$J,.84,9028,2,1,0) ;;=It is not necessary to recompile the cross-references, since the name of ;;^UTILITY(U,$J,.84,9028,2,2,0) ;;=the CROSS-REFERENCE ROUTINE was not changed. ;;^UTILITY(U,$J,.84,9028,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9028,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,9029,0) ;;=9029^3^^5 ;;^UTILITY(U,$J,.84,9029,1,0) ;;=^^5^5^2931109^ ;;^UTILITY(U,$J,.84,9029,1,1,0) ;;=Help prompt for CROSS-REFERENCE ROUTINE name when editing file attributes. ;;^UTILITY(U,$J,.84,9029,1,2,0) ;;= If the user changes the name of the CROSS-REFERENCE ROUTINE, or enters a ;;^UTILITY(U,$J,.84,9029,1,3,0) ;;=name for the first time, they must also compile the routines at this time. ;;^UTILITY(U,$J,.84,9029,1,4,0) ;;= If they don't the routine name they just entered will be deleted from the ;;^UTILITY(U,$J,.84,9029,1,5,0) ;;=DD. ;;^UTILITY(U,$J,.84,9029,2,0) ;;=^^2^2^2931109^ ;;^UTILITY(U,$J,.84,9029,2,1,0) ;;=If the cross-references are not recompiled at this time, the ;;^UTILITY(U,$J,.84,9029,2,2,0) ;;=CROSS-REFERENCE ROUTINE name will NOT be saved in the data dictionary. ;;^UTILITY(U,$J,.84,9029,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9029,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,9030,0) ;;=9030^3^^5 ;;^UTILITY(U,$J,.84,9030,1,0) ;;=^^2^2^2931109^^^^ ;;^UTILITY(U,$J,.84,9030,1,1,0) ;;=Help for prompting for compiled routine name, when compiling templates ;;^UTILITY(U,$J,.84,9030,1,2,0) ;;=or cross-references. ;;^UTILITY(U,$J,.84,9030,2,0) ;;=^^1^1^2931109^ ;;^UTILITY(U,$J,.84,9030,2,1,0) ;;=This will become the namespace of the compiled routine(s). ;;^UTILITY(U,$J,.84,9030,5,0) ;;=^.841^4^4 ;;^UTILITY(U,$J,.84,9030,5,1,0) ;;=DIU0^6 ;;^UTILITY(U,$J,.84,9030,5,2,0) ;;=DIKZ^ ;;^UTILITY(U,$J,.84,9030,5,3,0) ;;=DIPZ^ ;;^UTILITY(U,$J,.84,9030,5,4,0) ;;=DIEZ^ ;;^UTILITY(U,$J,.84,9031,0) ;;=9031^2^^5 ;;^UTILITY(U,$J,.84,9031,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9031,1,1,0) ;;=Help for the reader: Freetext ;;^UTILITY(U,$J,.84,9031,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9031,2,1,0) ;;=This response can be free text ;;^UTILITY(U,$J,.84,9032,0) ;;=9032^2^^5 ;;^UTILITY(U,$J,.84,9032,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9032,1,1,0) ;;=Help for the reader: Set of codes ;;^UTILITY(U,$J,.84,9032,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9032,2,1,0) ;;=Enter a code from the list. ;;^UTILITY(U,$J,.84,9033,0) ;;=9033^2^^5 ;;^UTILITY(U,$J,.84,9033,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9033,1,1,0) ;;=Help for the reader: End of page ;;^UTILITY(U,$J,.84,9033,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9033,2,1,0) ;;=Enter either or '^' ;;^UTILITY(U,$J,.84,9034,0) ;;=9034^2^^5 ;;^UTILITY(U,$J,.84,9034,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9034,1,1,0) ;;=Help for the reader: Numbers ;;^UTILITY(U,$J,.84,9034,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9034,2,1,0) ;;=This response must be a number ;;^UTILITY(U,$J,.84,9035,0) ;;=9035^2^^5 ;;^UTILITY(U,$J,.84,9035,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9035,1,1,0) ;;=Help for the reader: dates ;;^UTILITY(U,$J,.84,9035,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9035,2,1,0) ;;=This response must be a date ;;^UTILITY(U,$J,.84,9036,0) ;;=9036^2^^5 ;;^UTILITY(U,$J,.84,9036,1,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9036,1,1,0) ;;=Help for the reader: List ;;^UTILITY(U,$J,.84,9036,2,0) ;;=^^1^1^2940310^ ;;^UTILITY(U,$J,.84,9036,2,1,0) ;;=This response must be a list or range, e.g., 1,3,5 or 2-4,8 ;;^UTILITY(U,$J,.84,9037,0) ;;=9037^3^^5 ;;^UTILITY(U,$J,.84,9037,1,0) ;;=^^1^1^2940316^^ ;;^UTILITY(U,$J,.84,9037,1,1,0) ;;=Help for leaving form ;;^UTILITY(U,$J,.84,9037,2,0) ;;=^^3^3^2940316^^ ;;^UTILITY(U,$J,.84,9037,2,1,0) ;;=Enter 'Y' to save before exiting. ;;^UTILITY(U,$J,.84,9037,2,2,0) ;;=Enter 'N' or '^' to exit without saving. ;;^UTILITY(U,$J,.84,9037,2,3,0) ;;=Press to return to form ;;^UTILITY(U,$J,.84,9038,0) ;;=9038^3^^5 ;;^UTILITY(U,$J,.84,9038,1,0) ;;=^^1^1^2940316^ ;;^UTILITY(U,$J,.84,9038,1,1,0) ;;=Help for (Sub)record delete in forms ;;^UTILITY(U,$J,.84,9038,2,0) ;;=^^2^2^2940316^ ;;^UTILITY(U,$J,.84,9038,2,1,0) ;;=Enter 'Y' to delete. ;;^UTILITY(U,$J,.84,9038,2,2,0) ;;=Enter 'N' or to return to form. ;;^UTILITY(U,$J,.84,9040,0) ;;=9040^2^^5 ;;^UTILITY(U,$J,.84,9040,1,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,9040,1,1,0) ;;=Reader Help for Yes/No question ;;^UTILITY(U,$J,.84,9040,2,0) ;;=^^1^1^2940314^ ;;^UTILITY(U,$J,.84,9040,2,1,0) ;;=Enter either 'Y' or 'N'. ;;^UTILITY(U,$J,.84,9041,0) ;;=9041^3^^5 ;;^UTILITY(U,$J,.84,9041,1,0) ;;=^^2^2^2940608^^^^ ;;^UTILITY(U,$J,.84,9041,1,1,0) ;;=Help message for why the Compare/Merge options should be run during ;;^UTILITY(U,$J,.84,9041,1,2,0) ;;=non-peak hours. ;;^UTILITY(U,$J,.84,9041,2,0) ;;=^^8^8^2940608^ DINIT00O DINIT00O ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;3:18 PM 25 May 2001 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,9041,2,1,0) ;;= ;;^UTILITY(U,$J,.84,9041,2,2,0) ;;=Enter 'NO' to compare and display the two entries. ;;^UTILITY(U,$J,.84,9041,2,3,0) ;;=Enter 'YES' to choose valid fields from each entry then merge into the ;;^UTILITY(U,$J,.84,9041,2,4,0) ;;=record selected as the default. ;;^UTILITY(U,$J,.84,9041,2,5,0) ;;= ;;^UTILITY(U,$J,.84,9041,2,6,0) ;;=If you merge two entries within a file that is pointed-to by many other ;;^UTILITY(U,$J,.84,9041,2,7,0) ;;=files (such as the PATIENT file), then the re-pointing process can be time ;;^UTILITY(U,$J,.84,9041,2,8,0) ;;=consuming and can create many tasked jobs. ;;^UTILITY(U,$J,.84,9101,0) ;;=9101^3^^5 ;;^UTILITY(U,$J,.84,9101,1,0) ;;=^^1^1^2930810^ ;;^UTILITY(U,$J,.84,9101,1,1,0) ;;=The "CHOOSE FROM:" prompt. ;;^UTILITY(U,$J,.84,9101,2,0) ;;=^^1^1^2930908^^ ;;^UTILITY(U,$J,.84,9101,2,1,0) ;;=Choose from: ;;^UTILITY(U,$J,.84,9103,0) ;;=9103^3^^5 ;;^UTILITY(U,$J,.84,9103,1,0) ;;=^^2^2^2930810^^ ;;^UTILITY(U,$J,.84,9103,1,1,0) ;;=First line of Variable Pointer help that shows the Prefixes and Messages ;;^UTILITY(U,$J,.84,9103,1,2,0) ;;=for a field. ;;^UTILITY(U,$J,.84,9103,2,0) ;;=^^1^1^2930810^ ;;^UTILITY(U,$J,.84,9103,2,1,0) ;;=Enter one of the following: ;;^UTILITY(U,$J,.84,9105,0) ;;=9105^3^y^5 ;;^UTILITY(U,$J,.84,9105,1,0) ;;=^^2^2^2931229^ ;;^UTILITY(U,$J,.84,9105,1,1,0) ;;=The beginning of the help text used to give list of fields that can ;;^UTILITY(U,$J,.84,9105,1,2,0) ;;=be used for a look-up. ;;^UTILITY(U,$J,.84,9105,2,0) ;;=^^1^1^2931229^ ;;^UTILITY(U,$J,.84,9105,2,1,0) ;;=Answer with |1|. ;;^UTILITY(U,$J,.84,9105,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,9105,3,1,0) ;;=1^File name and list of fields that can be used for look-up. ;;^UTILITY(U,$J,.84,9105,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9105,5,1,0) ;;=DIE^HELP ;;^UTILITY(U,$J,.84,9107,0) ;;=9107^3^y^5 ;;^UTILITY(U,$J,.84,9107,1,0) ;;=^^1^1^2940513^ ;;^UTILITY(U,$J,.84,9107,1,1,0) ;;=LAYGO allowed. ;;^UTILITY(U,$J,.84,9107,2,0) ;;=^^1^1^2940513^ ;;^UTILITY(U,$J,.84,9107,2,1,0) ;;=You may enter a new |1| if you wish. ;;^UTILITY(U,$J,.84,9107,3,0) ;;=^.845^1^1 ;;^UTILITY(U,$J,.84,9107,3,1,0) ;;=1^File Name. ;;^UTILITY(U,$J,.84,9110,0) ;;=9110^3^y^5 ;;^UTILITY(U,$J,.84,9110,1,0) ;;=^^1^1^2990323^^^^ ;;^UTILITY(U,$J,.84,9110,1,1,0) ;;=Instructions for entering date data. ;;^UTILITY(U,$J,.84,9110,2,0) ;;=^^7^7^2990323^^^ ;;^UTILITY(U,$J,.84,9110,2,1,0) ;;=Examples of Valid Dates: ;;^UTILITY(U,$J,.84,9110,2,2,0) ;;= JAN 20 1957 or 20 JAN 57 or 1/20/57 |1| ;;^UTILITY(U,$J,.84,9110,2,3,0) ;;= T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc. ;;^UTILITY(U,$J,.84,9110,2,4,0) ;;= T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc. ;;^UTILITY(U,$J,.84,9110,2,5,0) ;;=If the year is omitted, the computer |2| ;;^UTILITY(U,$J,.84,9110,2,6,0) ;;=|3| ;;^UTILITY(U,$J,.84,9110,2,7,0) ;;=|4| ;;^UTILITY(U,$J,.84,9110,3,0) ;;=^.845^4^4 ;;^UTILITY(U,$J,.84,9110,3,1,0) ;;=1^If numeric dates are allowed, " or 012057" is written. ;;^UTILITY(U,$J,.84,9110,3,2,0) ;;=2^Conditionally, indicates if past, future, or current year is assumed. ;;^UTILITY(U,$J,.84,9110,3,3,0) ;;=3^Conditionally indicates the way FileMan determines century to use if 2 digit year is provided, or indicates that day is not needed if past or future year assumed. ;;^UTILITY(U,$J,.84,9110,3,4,0) ;;=4^Conditionally, indicates that day is not needed (unless past or future date is assumed, in which case this information goes into parameter 3). ;;^UTILITY(U,$J,.84,9110,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9110,5,1,0) ;;=DIEH1^DT ;;^UTILITY(U,$J,.84,9110.7,0) ;;=9110.7^3^y^5^Instructions for entering date data. ;;^UTILITY(U,$J,.84,9110.7,1,0) ;;=^.842^1^1^3010525^^^^ ;;^UTILITY(U,$J,.84,9110.7,1,1,0) ;;=Instructions for entering date data, when the "M" flag is used. ;;^UTILITY(U,$J,.84,9110.7,2,0) ;;=^.844^8^8^3010525^^^ ;;^UTILITY(U,$J,.84,9110.7,2,1,0) ;;=Examples of Valid Dates: ;;^UTILITY(U,$J,.84,9110.7,2,2,0) ;;= JAN 1957 or JAN 57 |1| ;;^UTILITY(U,$J,.84,9110.7,2,3,0) ;;= T (for this month) ;;^UTILITY(U,$J,.84,9110.7,2,4,0) ;;= T+3M (for 3 months in the future) ;;^UTILITY(U,$J,.84,9110.7,2,5,0) ;;= T-3M (for 3 months ago) ;;^UTILITY(U,$J,.84,9110.7,2,6,0) ;;=Only month and year are accepted. You must omit the precise day. ;;^UTILITY(U,$J,.84,9110.7,2,7,0) ;;=If the year is omitted, the computer |2| ;;^UTILITY(U,$J,.84,9110.7,2,8,0) ;;=|3| ;;^UTILITY(U,$J,.84,9110.7,3,0) ;;=^.845^3^3 ;;^UTILITY(U,$J,.84,9110.7,3,1,0) ;;=1^If numeric dates are allowed, " or 0157" is written. ;;^UTILITY(U,$J,.84,9110.7,3,2,0) ;;=2^Conditionally, indicates if past, future, or current year is assumed. ;;^UTILITY(U,$J,.84,9110.7,3,3,0) ;;=3^Conditionally indicates the way FileMan determines century to use if 2 digit year is provided. ;;^UTILITY(U,$J,.84,9110.7,5,0) ;;=^.841^1^1 ;;^UTILITY(U,$J,.84,9110.7,5,1,0) ;;=DIEH1^DT ;;^UTILITY(U,$J,.84,9111,0) ;;=9111^3^y^5 ;;^UTILITY(U,$J,.84,9111,1,0) ;;=^^1^1^2930806^ ;;^UTILITY(U,$J,.84,9111,1,1,0) ;;=Instructions for entering time data. ;;^UTILITY(U,$J,.84,9111,2,0) ;;=^^5^5^2931104^^ ;;^UTILITY(U,$J,.84,9111,2,1,0) ;;=If the date is omitted, the current date is assumed. ;;^UTILITY(U,$J,.84,9111,2,2,0) ;;=Follow the date with a time, such as JAN 20@10, T@10AM, 10:30, etc. ;;^UTILITY(U,$J,.84,9111,2,3,0) ;;=You may enter NOON, MIDNIGHT, or NOW to indicate the time. ;;^UTILITY(U,$J,.84,9111,2,4,0) ;;=|1| ;;^UTILITY(U,$J,.84,9111,2,5,0) ;;=|2| ;;^UTILITY(U,$J,.84,9111,3,0) ;;=^.845^2^2 ;;^UTILITY(U,$J,.84,9111,3,1,0) ;;=1^Conditionally, give instructions for entering seconds. ;;^UTILITY(U,$J,.84,9111,3,2,0) ;;=2^Conditionally, state that time is required. ;;^UTILITY(U,$J,.84,9115,0) ;;=9115^3^^5 ;;^UTILITY(U,$J,.84,9115,1,0) ;;=^^1^1^2930810^ ;;^UTILITY(U,$J,.84,9115,1,1,0) ;;=The short help for variable pointers. ;;^UTILITY(U,$J,.84,9115,2,0) ;;=^^1^1^2930810^ ;;^UTILITY(U,$J,.84,9115,2,1,0) ;;=To see the entries in any particular file, type . ;;^UTILITY(U,$J,.84,9116,0) ;;=9116^3^^5 ;;^UTILITY(U,$J,.84,9116,1,0) ;;=^^1^1^2930810^ ;;^UTILITY(U,$J,.84,9116,1,1,0) ;;=Long help for variable pointers. ;;^UTILITY(U,$J,.84,9116,2,0) ;;=^^15^15^2930810^ ;;^UTILITY(U,$J,.84,9116,2,1,0) ;;=If you enter just a name, the system will search each of the ;;^UTILITY(U,$J,.84,9116,2,2,0) ;;=above files for the name you have entered. If a match is found, ;;^UTILITY(U,$J,.84,9116,2,3,0) ;;=the system will ask you if it is the entry you desire. ;;^UTILITY(U,$J,.84,9116,2,4,0) ;;= ;;^UTILITY(U,$J,.84,9116,2,5,0) ;;=However, if you know the file the entry should be in, you can ;;^UTILITY(U,$J,.84,9116,2,6,0) ;;=speed processing by using the following syntax to select an entry: ;;^UTILITY(U,$J,.84,9116,2,7,0) ;;= ;;^UTILITY(U,$J,.84,9116,2,8,0) ;;= . ;;^UTILITY(U,$J,.84,9116,2,9,0) ;;= or ;;^UTILITY(U,$J,.84,9116,2,10,0) ;;= . ;;^UTILITY(U,$J,.84,9116,2,11,0) ;;= or ;;^UTILITY(U,$J,.84,9116,2,12,0) ;;= . ;;^UTILITY(U,$J,.84,9116,2,13,0) ;;= ;;^UTILITY(U,$J,.84,9116,2,14,0) ;;=You do not need to enter the entire file name or message. ;;^UTILITY(U,$J,.84,9116,2,15,0) ;;=The first few characters will suffice. ;;^UTILITY(U,$J,.84,9117,0) ;;=9117^3^y^5 ;;^UTILITY(U,$J,.84,9117,1,0) ;;=^^1^1^2930810^^ ;;^UTILITY(U,$J,.84,9117,1,1,0) ;;=Variable pointer help - prefix and message. ;;^UTILITY(U,$J,.84,9117,2,0) ;;=^^1^1^2930810^^^ ;;^UTILITY(U,$J,.84,9117,2,1,0) ;;=|1|.EntryName to select a |2|. ;;^UTILITY(U,$J,.84,9117,3,0) ;;=^.845^2^2 DINIT00P DINIT00P ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ; 11DEC2012 ;;22.2;VA FILEMAN;;Mar 28, 2013 ;Per VHA Directive 2004-038, this routine should not be modified. ; F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,9117,3,1,0) ;;=1^The prefix for a variable pointer file. ;;^UTILITY(U,$J,.84,9117,3,2,0) ;;=2^The message for a variable pointer file. ;;^UTILITY(U,$J,.84,9201,0) ;;=9201^3^^5 ;;^UTILITY(U,$J,.84,9201,1,0) ;;=^^1^1^2950511^^ ;;^UTILITY(U,$J,.84,9201,1,1,0) ;;=Browser help ;;^UTILITY(U,$J,.84,9201,2,-1,"DATE") ;;=62796,32024 ;;^UTILITY(U,$J,.84,9201,2,-1,"TITLE") ;;=9201 ;;^UTILITY(U,$J,.84,9201,2,0) ;;=^^221^221^3121205^ ;;^UTILITY(U,$J,.84,9201,2,1,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,2,0) ;;= HELP SUMMARY ;;^UTILITY(U,$J,.84,9201,2,3,0) ;;= ============ ;;^UTILITY(U,$J,.84,9201,2,4,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,5,0) ;;=NAVIGATION: ;;^UTILITY(U,$J,.84,9201,2,6,0) ;;============ ;;^UTILITY(U,$J,.84,9201,2,7,0) ;;= Scroll Down (one line) ARROW DOWN ;;^UTILITY(U,$J,.84,9201,2,8,0) ;;= Scroll Up (one line) ARROW UP ;;^UTILITY(U,$J,.84,9201,2,9,0) ;;= Page Down ARROW DOWN ;;^UTILITY(U,$J,.84,9201,2,10,0) ;;= Page Up ARROW UP ;;^UTILITY(U,$J,.84,9201,2,11,0) ;;= Scroll Right (default 22 columns) ARROW RIGHT ;;^UTILITY(U,$J,.84,9201,2,12,0) ;;= Scroll Left (default 22 columns) ARROW LEFT ;;^UTILITY(U,$J,.84,9201,2,13,0) ;;= Scroll Horizontally to the end ARROW RIGHT ;;^UTILITY(U,$J,.84,9201,2,14,0) ;;= Scroll Horizontally to the end ARROW LEFT ;;^UTILITY(U,$J,.84,9201,2,15,0) ;;= Jump to the Top T ;;^UTILITY(U,$J,.84,9201,2,16,0) ;;= Jump to the Bottom B ;;^UTILITY(U,$J,.84,9201,2,17,0) ;;= Goto G ;;^UTILITY(U,$J,.84,9201,2,18,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,19,0) ;;=SEARCH: ;;^UTILITY(U,$J,.84,9201,2,20,0) ;;======== ;;^UTILITY(U,$J,.84,9201,2,21,0) ;;= Find text F ;;^UTILITY(U,$J,.84,9201,2,22,0) ;;= Next (occurrence) N ;;^UTILITY(U,$J,.84,9201,2,23,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,24,0) ;;= Direction-terminate find text with: ;;^UTILITY(U,$J,.84,9201,2,25,0) ;;= ----------------------------------- ;;^UTILITY(U,$J,.84,9201,2,26,0) ;;= Down ARROW DOWN ;;^UTILITY(U,$J,.84,9201,2,27,0) ;;= Up ARROW UP ;;^UTILITY(U,$J,.84,9201,2,28,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,29,0) ;;=BRANCH: ;;^UTILITY(U,$J,.84,9201,2,30,0) ;;======== ;;^UTILITY(U,$J,.84,9201,2,31,0) ;;= Switch to another document S ;;^UTILITY(U,$J,.84,9201,2,32,0) ;;= Return to previous document(s) R ;;^UTILITY(U,$J,.84,9201,2,33,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,34,0) ;;=SCREEN: ;;^UTILITY(U,$J,.84,9201,2,35,0) ;;======== ;;^UTILITY(U,$J,.84,9201,2,36,0) ;;= Repaint screen P ;;^UTILITY(U,$J,.84,9201,2,37,0) ;;= Print document P ;;^UTILITY(U,$J,.84,9201,2,38,0) ;;= Split screen S ;;^UTILITY(U,$J,.84,9201,2,39,0) ;;= restore Full screen F ;;^UTILITY(U,$J,.84,9201,2,40,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,41,0) ;;= Split Screen Mode Navigation: ;;^UTILITY(U,$J,.84,9201,2,42,0) ;;= ----------------------------- ;;^UTILITY(U,$J,.84,9201,2,43,0) ;;= Navigate to bottom screen ARROW DOWN ;;^UTILITY(U,$J,.84,9201,2,44,0) ;;= Navigate to top screen ARROW UP ;;^UTILITY(U,$J,.84,9201,2,45,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,46,0) ;;= Resize Split Screen: ;;^UTILITY(U,$J,.84,9201,2,47,0) ;;= -------------------- ;;^UTILITY(U,$J,.84,9201,2,48,0) ;;= Top/Bottom screen larger/smaller ARROW DOWN ;;^UTILITY(U,$J,.84,9201,2,49,0) ;;= Bottom/Top screen larger/smaller ARROW UP ;;^UTILITY(U,$J,.84,9201,2,50,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,51,0) ;;=CLIPBOARD: ;;^UTILITY(U,$J,.84,9201,2,52,0) ;;=========== ;;^UTILITY(U,$J,.84,9201,2,53,0) ;;= Copy to VA FileMan's Clipboard C ;;^UTILITY(U,$J,.84,9201,2,54,0) ;;= View VA FileMan's Clipboard V ;;^UTILITY(U,$J,.84,9201,2,55,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,56,0) ;;=TITLE BAR: ;;^UTILITY(U,$J,.84,9201,2,57,0) ;;=========== ;;^UTILITY(U,$J,.84,9201,2,58,0) ;;= Change content of title bar, ARROW DOWN ;;^UTILITY(U,$J,.84,9201,2,59,0) ;;= Or ARROW UP ;;^UTILITY(U,$J,.84,9201,2,60,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,61,0) ;;=HELP: ;;^UTILITY(U,$J,.84,9201,2,62,0) ;;====== ;;^UTILITY(U,$J,.84,9201,2,63,0) ;;= Browse Key Summary H ;;^UTILITY(U,$J,.84,9201,2,64,0) ;;= More Help H ;;^UTILITY(U,$J,.84,9201,2,65,0) ;;= Print this help text H ;;^UTILITY(U,$J,.84,9201,2,66,0) ;;= To Return to document from this help R ;;^UTILITY(U,$J,.84,9201,2,67,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,68,0) ;;=EXIT: ;;^UTILITY(U,$J,.84,9201,2,69,0) ;;====== ;;^UTILITY(U,$J,.84,9201,2,70,0) ;;= Exit Browser or help text E or "EXIT" ;;^UTILITY(U,$J,.84,9201,2,71,0) ;;= Quit Q or ;;^UTILITY(U,$J,.84,9201,2,72,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,73,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,74,0) ;;= MORE HELP ;;^UTILITY(U,$J,.84,9201,2,75,0) ;;= ========= ;;^UTILITY(U,$J,.84,9201,2,76,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,77,0) ;;= To EXIT the VA FileMan Browser, press followed by the letter ;;^UTILITY(U,$J,.84,9201,2,78,0) ;;= 'E'. This is also true for this HELP document which is being ;;^UTILITY(U,$J,.84,9201,2,79,0) ;;= presented by the Browser. ;;^UTILITY(U,$J,.84,9201,2,80,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,81,0) ;;= To SCROLL DOWN one line at a time, press the ARROW DOWN key. ;;^UTILITY(U,$J,.84,9201,2,82,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,83,0) ;;= To SCROLL UP one line at a time, press the ARROW UP key. ;;^UTILITY(U,$J,.84,9201,2,84,0) ;;= DINIT00Q DINIT00Q ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;11:33 AM 5 Dec 2012 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 19 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,9201,2,85,0) ;;= To SCROLL RIGHT, press the ARROW RIGHT key. ;;^UTILITY(U,$J,.84,9201,2,86,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,87,0) ;;= To SCROLL LEFT, press the ARROW LEFT key. ;;^UTILITY(U,$J,.84,9201,2,88,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,89,0) ;;= Try pressing these keys at this time and observe the behavior. Get a ;;^UTILITY(U,$J,.84,9201,2,90,0) ;;= feel for 'browsing' through a document. Press the arrow down key a ;;^UTILITY(U,$J,.84,9201,2,91,0) ;;= few times, then press the arrow up key. Also notice that the 'Line>' ;;^UTILITY(U,$J,.84,9201,2,92,0) ;;= and 'Screen>' indicator numbers are changing. To see more of this ;;^UTILITY(U,$J,.84,9201,2,93,0) ;;= text keep pressing the ARROW DOWN key. Now try the arrow right key, ;;^UTILITY(U,$J,.84,9201,2,94,0) ;;= then the arrow left key. Notice that the 'Col>' indicator number is ;;^UTILITY(U,$J,.84,9201,2,95,0) ;;= also changing. This shows what column the left most edge of the ;;^UTILITY(U,$J,.84,9201,2,96,0) ;;= document is on. As you can see, the VA FileMan Browser is like a ;;^UTILITY(U,$J,.84,9201,2,97,0) ;;= window placed over a document. You are in control of this window ;;^UTILITY(U,$J,.84,9201,2,98,0) ;;= which moves over the document by pressing the functional key ;;^UTILITY(U,$J,.84,9201,2,99,0) ;;= sequences. Here are a few more functions. ;;^UTILITY(U,$J,.84,9201,2,100,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,101,0) ;;= To PAGE DOWN one screen at one time, press the NEXT SCREEN key, PAGE ;;^UTILITY(U,$J,.84,9201,2,102,0) ;;= DOWN or F1 followed by the ARROW DOWN key, depending on what kind of ;;^UTILITY(U,$J,.84,9201,2,103,0) ;;= CRT or workstation that is being used. ;;^UTILITY(U,$J,.84,9201,2,104,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,105,0) ;;= To PAGE UP one screen at one time, press the PREV SCREEN key, PAGE UP ;;^UTILITY(U,$J,.84,9201,2,106,0) ;;= or F1 followed by the ARROW UP key, depending on what kind of CRT or ;;^UTILITY(U,$J,.84,9201,2,107,0) ;;= workstation that is being used. ;;^UTILITY(U,$J,.84,9201,2,108,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,109,0) ;;= To return to the TOP, back to the beginning of the document, press ;;^UTILITY(U,$J,.84,9201,2,110,0) ;;= the key followed by the letter 'T'. ;;^UTILITY(U,$J,.84,9201,2,111,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,112,0) ;;= To go to the BOTTOM, end of the document, press the key ;;^UTILITY(U,$J,.84,9201,2,113,0) ;;= followed by the letter 'B'. ;;^UTILITY(U,$J,.84,9201,2,114,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,115,0) ;;= To GOTO a specific screen, line or column press the key ;;^UTILITY(U,$J,.84,9201,2,116,0) ;;= followed by the letter 'G'. This will cause a prompt to be displayed ;;^UTILITY(U,$J,.84,9201,2,117,0) ;;= where a screen, line or column number can be entered preceded by a ;;^UTILITY(U,$J,.84,9201,2,118,0) ;;= 'S' , 'L' or 'C'. The default is screen, meaning that the 'S' is ;;^UTILITY(U,$J,.84,9201,2,119,0) ;;= optional when entering a screen number. 10 or S10 will go to screen ;;^UTILITY(U,$J,.84,9201,2,120,0) ;;= 10, if screen 10 is a valid screen. L99 will go to line 99 and C33 ;;^UTILITY(U,$J,.84,9201,2,121,0) ;;= will go to column 33. ;;^UTILITY(U,$J,.84,9201,2,122,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,123,0) ;;= To FIND a string of characters, on a line, press the key ;;^UTILITY(U,$J,.84,9201,2,124,0) ;;= followed by the letter 'F' or 'FIND' key. A prompt will appear where ;;^UTILITY(U,$J,.84,9201,2,125,0) ;;= a search string of characters can be entered. The Find facility will ;;^UTILITY(U,$J,.84,9201,2,126,0) ;;= search the document and immediately stop when it finds a match and ;;^UTILITY(U,$J,.84,9201,2,127,0) ;;= 'Goto' the line/screen. The matched text will be highlighted in ;;^UTILITY(U,$J,.84,9201,2,128,0) ;;= reverse video, if available, so it can be found easily. However, if ;;^UTILITY(U,$J,.84,9201,2,129,0) ;;= a string contains two or more words, matching will only be done if ;;^UTILITY(U,$J,.84,9201,2,130,0) ;;= the words are found on the same line. The default direction of the ;;^UTILITY(U,$J,.84,9201,2,131,0) ;;= search is down. This can be controlled by using the ARROW UP or ;;^UTILITY(U,$J,.84,9201,2,132,0) ;;= ARROW DOWN keys instead of the key to terminate the search ;;^UTILITY(U,$J,.84,9201,2,133,0) ;;= string. ;;^UTILITY(U,$J,.84,9201,2,134,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,135,0) ;;= To, NEXT FIND, find the next occurrence of the same search string, ;;^UTILITY(U,$J,.84,9201,2,136,0) ;;= press the letter 'N' or followed by the letter 'N'. The FIND ;;^UTILITY(U,$J,.84,9201,2,137,0) ;;= facility keeps track of the last find string including the direction ;;^UTILITY(U,$J,.84,9201,2,138,0) ;;= and continues searching through the document and brings up the next ;;^UTILITY(U,$J,.84,9201,2,139,0) ;;= screen. If no match is found a message appears indicating this and ;;^UTILITY(U,$J,.84,9201,2,140,0) ;;= the screen is repainted at it's original location. ;;^UTILITY(U,$J,.84,9201,2,141,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,142,0) ;;= To rePAINT the screen, press the key followed by the letter ;;^UTILITY(U,$J,.84,9201,2,143,0) ;;= 'P'. ;;^UTILITY(U,$J,.84,9201,2,144,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,145,0) ;;= To PRINT the document on the screen, press the followed by ;;^UTILITY(U,$J,.84,9201,2,146,0) ;;= the letter 'P'. You will be prompted whether to print a header on ;;^UTILITY(U,$J,.84,9201,2,147,0) ;;= each page, whether to wrap the text and interpret wp windows (|), ;;^UTILITY(U,$J,.84,9201,2,148,0) ;;= and for a DEVICE to print to. ;;^UTILITY(U,$J,.84,9201,2,149,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,150,0) ;;= To SWITCH to another document press the key followed by the ;;^UTILITY(U,$J,.84,9201,2,151,0) ;;= letter 'S'. This will allow the selection of another file, (wp)field ;;^UTILITY(U,$J,.84,9201,2,152,0) ;;= and entry. The document is put on an active list and Browse ;;^UTILITY(U,$J,.84,9201,2,153,0) ;;= switches to the newly selected document. Subsequent use of Switch ;;^UTILITY(U,$J,.84,9201,2,154,0) ;;= will allow choosing from the active list if desired or branch to ;;^UTILITY(U,$J,.84,9201,2,155,0) ;;= select file, (wp)field and entry prompts. This function CAN BE ;;^UTILITY(U,$J,.84,9201,2,156,0) ;;= RESTRICTED depending on how the running application calls the Browser ;;^UTILITY(U,$J,.84,9201,2,157,0) ;;= utility. ;;^UTILITY(U,$J,.84,9201,2,158,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,159,0) ;;= To RETURN to the previous document after using Switch or Help, press DINIT00R DINIT00R ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;11:34 AM 5 Dec 2012 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 19 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,9201,2,160,0) ;;= 'R'. A separate list keeps track of the documents chosen during the ;;^UTILITY(U,$J,.84,9201,2,161,0) ;;= current Browse session. R will return all the way back to the very ;;^UTILITY(U,$J,.84,9201,2,162,0) ;;= first document when used repeatedly. ;;^UTILITY(U,$J,.84,9201,2,163,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,164,0) ;;= To COPY text to VA FileMan's Clipboard, press followed by the ;;^UTILITY(U,$J,.84,9201,2,165,0) ;;= letter C. A prompt will appear where a range of lines can be entered ;;^UTILITY(U,$J,.84,9201,2,166,0) ;;= separated with a colon (:), or wild card such as (*), to copy the ;;^UTILITY(U,$J,.84,9201,2,167,0) ;;= entire text. If the letter 'A' is appended, the text will be ;;^UTILITY(U,$J,.84,9201,2,168,0) ;;= appended to the existing content of the VA FileMan Clipboard, when ;;^UTILITY(U,$J,.84,9201,2,169,0) ;;= applicable. The text in the clipboard may then be retrieved by VA ;;^UTILITY(U,$J,.84,9201,2,170,0) ;;= FileMan's Screen Editor. ;;^UTILITY(U,$J,.84,9201,2,171,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,172,0) ;;= To VIEW the content of the VA FileMan's Clipboard, press ;;^UTILITY(U,$J,.84,9201,2,173,0) ;;= followed by the letter V. A new Browser screen appears, which ;;^UTILITY(U,$J,.84,9201,2,174,0) ;;= displays the text. Many functions are restricted, when in the 'View ;;^UTILITY(U,$J,.84,9201,2,175,0) ;;= Clipboard' mode. ;;^UTILITY(U,$J,.84,9201,2,176,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,177,0) ;;= To SPLIT SCREEN, while in Full (Browse Region) Screen mode, press ;;^UTILITY(U,$J,.84,9201,2,178,0) ;;= followed by the letter 'S'. This causes the screen to split ;;^UTILITY(U,$J,.84,9201,2,179,0) ;;= into two separate scroll regions. ;;^UTILITY(U,$J,.84,9201,2,180,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,181,0) ;;= To navigate to the bottom screen, while in Split Screen mode, press ;;^UTILITY(U,$J,.84,9201,2,182,0) ;;= followed by pressing the ARROW DOWN key. ;;^UTILITY(U,$J,.84,9201,2,183,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,184,0) ;;= To navigate to the top screen, while in Split Screen mode, press ;;^UTILITY(U,$J,.84,9201,2,185,0) ;;= followed by pressing the ARROW UP key. ;;^UTILITY(U,$J,.84,9201,2,186,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,187,0) ;;= To return to FULL SCREEN mode, while in Split Screen mode, press ;;^UTILITY(U,$J,.84,9201,2,188,0) ;;= followed by the letter 'F'. This causes the entire browse ;;^UTILITY(U,$J,.84,9201,2,189,0) ;;= region to return to one Full (Browse) Screen scroll region. ;;^UTILITY(U,$J,.84,9201,2,190,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,191,0) ;;= To RESIZE screens, while in Split Screen mode, press ;;^UTILITY(U,$J,.84,9201,2,192,0) ;;= followed by the ARROW UP key. This makes the top window smaller and ;;^UTILITY(U,$J,.84,9201,2,193,0) ;;= the bottom window larger. followed by the ARROW DOWN key ;;^UTILITY(U,$J,.84,9201,2,194,0) ;;= makes the top window larger and the bottom window smaller. ;;^UTILITY(U,$J,.84,9201,2,195,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,196,0) ;;= The TITLE BAR, at the top, is a non scrolling region which contains ;;^UTILITY(U,$J,.84,9201,2,197,0) ;;= static information, while browsing in the selected document. The ;;^UTILITY(U,$J,.84,9201,2,198,0) ;;= title bar information only changes when switching documents or ;;^UTILITY(U,$J,.84,9201,2,199,0) ;;= requesting help. To move text header into the Title Bar, one line at ;;^UTILITY(U,$J,.84,9201,2,200,0) ;;= a time, press ARROW DOWN or ARROW UP. This ;;^UTILITY(U,$J,.84,9201,2,201,0) ;;= replaces the text in the Title Bar with the content of the text in ;;^UTILITY(U,$J,.84,9201,2,202,0) ;;= the scroll region, one line at a time. This can be usefull, when ;;^UTILITY(U,$J,.84,9201,2,203,0) ;;= Browser is called via the Device Handler (Browser Device), for ;;^UTILITY(U,$J,.84,9201,2,204,0) ;;= Browsing through standard VA FileMan Prints. This allows a user to ;;^UTILITY(U,$J,.84,9201,2,205,0) ;;= move the field headers into the Title Bar. ;;^UTILITY(U,$J,.84,9201,2,206,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,207,0) ;;= The STATUS BAR, at the bottom, is also a non scroll region. It shows ;;^UTILITY(U,$J,.84,9201,2,208,0) ;;= the column indicator, how to get help, how to exit, line information ;;^UTILITY(U,$J,.84,9201,2,209,0) ;;= and screen information. The "Col>" indicates the column number the ;;^UTILITY(U,$J,.84,9201,2,210,0) ;;= left edge of the browse window is over in the document. The "Line>" ;;^UTILITY(U,$J,.84,9201,2,211,0) ;;= shows the current line at the bottom of the scroll region and the ;;^UTILITY(U,$J,.84,9201,2,212,0) ;;= total number of lines in the document. The "Screen>" shows the ;;^UTILITY(U,$J,.84,9201,2,213,0) ;;= current screen and the total number of screens in the document. ;;^UTILITY(U,$J,.84,9201,2,214,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,215,0) ;;= The SCROLLING REGION, between the TITLE BAR and the STATUS BAR, is ;;^UTILITY(U,$J,.84,9201,2,216,0) ;;= where the Browser displays the text being viewed. ;;^UTILITY(U,$J,.84,9201,2,217,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,218,0) ;;= To print the help text, press H. This will prompt for ;;^UTILITY(U,$J,.84,9201,2,219,0) ;;= a Device. Only valid print devices can be selected. ;;^UTILITY(U,$J,.84,9201,2,220,0) ;;= ;;^UTILITY(U,$J,.84,9201,2,221,0) ;;= <<'E' to exit this help document>>> ;;^UTILITY(U,$J,.84,9202,0) ;;=9202^3^^5 ;;^UTILITY(U,$J,.84,9202,1,0) ;;=^^1^1^2950511^^^ ;;^UTILITY(U,$J,.84,9202,1,1,0) ;;=Browser help text, for hypertext mode. ;;^UTILITY(U,$J,.84,9202,2,-1,"DATE") ;;=62796,32034 ;;^UTILITY(U,$J,.84,9202,2,-1,"TITLE") ;;=9202 ;;^UTILITY(U,$J,.84,9202,2,0) ;;=^^127^127^3121205^^ ;;^UTILITY(U,$J,.84,9202,2,1,0) ;;=VA FileMan Browser Help for Hypertext Mode ;;^UTILITY(U,$J,.84,9202,2,2,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,3,0) ;;=Hypertext jumps are represented in 'bold' text. Press the Tab or 'Q' keys to ;;^UTILITY(U,$J,.84,9202,2,4,0) ;;=navigate forward and backward, in order to select a jump. Once a jump is DINIT00S DINIT00S ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;7:41 AM 6 Dec 2012 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 19 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,9202,2,5,0) ;;=selected, pressing the arrow right key causes the jump to occur. To return to ;;^UTILITY(U,$J,.84,9202,2,6,0) ;;=the previous jump location from the jump, press the arrow left key. On the ;;^UTILITY(U,$J,.84,9202,2,7,0) ;;=return, the selected hypertext represent the previous jump made. ;;^UTILITY(U,$J,.84,9202,2,8,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,9,0) ;;=To EXIT the VA FileMan Browser, in hypertext mode, press followed by the ;;^UTILITY(U,$J,.84,9202,2,10,0) ;;=letter 'E'. This is also true for this HELP document which is being presented ;;^UTILITY(U,$J,.84,9202,2,11,0) ;;=by the Browser, in hypertext mode. Pressing the letter 'R', returns the Browser ;;^UTILITY(U,$J,.84,9202,2,12,0) ;;=to the hypertext document. ;;^UTILITY(U,$J,.84,9202,2,13,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,14,0) ;;=For help, select, using TAB and press ARROW RIGHT to jump: ;;^UTILITY(U,$J,.84,9202,2,15,0) ;;= * $.%#NAVIGATION^Navigation$.% ;;^UTILITY(U,$J,.84,9202,2,16,0) ;;= * $.%#SEARCH^Search$.% ;;^UTILITY(U,$J,.84,9202,2,17,0) ;;= * $.%#SCREEN^Screen$.% ;;^UTILITY(U,$J,.84,9202,2,18,0) ;;= * $.%#CLIPBOARD^Clipboard$.% ;;^UTILITY(U,$J,.84,9202,2,19,0) ;;= * $.%#HELP^Help$.% ;;^UTILITY(U,$J,.84,9202,2,20,0) ;;= * $.%#EXIT^Exit$.% ;;^UTILITY(U,$J,.84,9202,2,21,0) ;;= * $.%#MORE_HELP^More Help$.% ;;^UTILITY(U,$J,.84,9202,2,22,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,23,0) ;;= --------------------------------------------------------------------------- ;;^UTILITY(U,$J,.84,9202,2,24,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,25,0) ;;=$.$NAVIGATION$.$NAVIGATION: ;;^UTILITY(U,$J,.84,9202,2,26,0) ;;============ ;;^UTILITY(U,$J,.84,9202,2,27,0) ;;=Select hypertext, left to right and down TAB ;;^UTILITY(U,$J,.84,9202,2,28,0) ;;=Select hypertext right to left and up Q ;;^UTILITY(U,$J,.84,9202,2,29,0) ;;=Invoke hypertext jump, selected ARROW RIGHT ;;^UTILITY(U,$J,.84,9202,2,30,0) ;;=Return from hypertext jump ARROW LEFT ;;^UTILITY(U,$J,.84,9202,2,31,0) ;;=Scroll Down (one line) ARROW DOWN ;;^UTILITY(U,$J,.84,9202,2,32,0) ;;=Scroll Up (one line) ARROW UP ;;^UTILITY(U,$J,.84,9202,2,33,0) ;;=Page Down ARROW DOWN ;;^UTILITY(U,$J,.84,9202,2,34,0) ;;=Page Up ARROW UP ;;^UTILITY(U,$J,.84,9202,2,35,0) ;;=Jump to the Top T ;;^UTILITY(U,$J,.84,9202,2,36,0) ;;=Jump to the Bottom B ;;^UTILITY(U,$J,.84,9202,2,37,0) ;;=Goto G ;;^UTILITY(U,$J,.84,9202,2,38,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,39,0) ;;=$.$SEARCH$.$SEARCH: ;;^UTILITY(U,$J,.84,9202,2,40,0) ;;======== ;;^UTILITY(U,$J,.84,9202,2,41,0) ;;=Find text F ;;^UTILITY(U,$J,.84,9202,2,42,0) ;;=Next (occurrence) N ;;^UTILITY(U,$J,.84,9202,2,43,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,44,0) ;;=Direction-terminate find text with: ;;^UTILITY(U,$J,.84,9202,2,45,0) ;;=----------------------------------- ;;^UTILITY(U,$J,.84,9202,2,46,0) ;;=Down ARROW DOWN ;;^UTILITY(U,$J,.84,9202,2,47,0) ;;=Up ARROW UP ;;^UTILITY(U,$J,.84,9202,2,48,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,49,0) ;;=$.$SCREEN$.$SCREEN: ;;^UTILITY(U,$J,.84,9202,2,50,0) ;;======== ;;^UTILITY(U,$J,.84,9202,2,51,0) ;;=Repaint screen P ;;^UTILITY(U,$J,.84,9202,2,52,0) ;;=Split screen S ;;^UTILITY(U,$J,.84,9202,2,53,0) ;;=Restore Full screen F ;;^UTILITY(U,$J,.84,9202,2,54,0) ;;=Print document P ;;^UTILITY(U,$J,.84,9202,2,55,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,56,0) ;;=Split Screen Mode Navigation: ;;^UTILITY(U,$J,.84,9202,2,57,0) ;;=----------------------------- ;;^UTILITY(U,$J,.84,9202,2,58,0) ;;=Navigate to bottom screen ARROW DOWN ;;^UTILITY(U,$J,.84,9202,2,59,0) ;;=Navigate to top screen ARROW UP ;;^UTILITY(U,$J,.84,9202,2,60,0) ;;=Resize Split Screen: ;;^UTILITY(U,$J,.84,9202,2,61,0) ;;=-------------------- ;;^UTILITY(U,$J,.84,9202,2,62,0) ;;=Top/Bottom screen larger/smaller ARROW DOWN ;;^UTILITY(U,$J,.84,9202,2,63,0) ;;=Bottom/Top screen larger/smaller ARROW UP ;;^UTILITY(U,$J,.84,9202,2,64,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,65,0) ;;=$.$HELP$.$HELP: ;;^UTILITY(U,$J,.84,9202,2,66,0) ;;====== ;;^UTILITY(U,$J,.84,9202,2,67,0) ;;=Browse Key Summary H ;;^UTILITY(U,$J,.84,9202,2,68,0) ;;=More Help H ;;^UTILITY(U,$J,.84,9202,2,69,0) ;;=Print Help H ;;^UTILITY(U,$J,.84,9202,2,70,0) ;;=Return to hypertext document, from HELP R ;;^UTILITY(U,$J,.84,9202,2,71,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,72,0) ;;=$.$CLIPBOARD$.$CLIPBOARD: ;;^UTILITY(U,$J,.84,9202,2,73,0) ;;=========== ;;^UTILITY(U,$J,.84,9202,2,74,0) ;;=Copy to FileMan's Clipboard C ;;^UTILITY(U,$J,.84,9202,2,75,0) ;;=View FileMan's Clipboard V ;;^UTILITY(U,$J,.84,9202,2,76,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,77,0) ;;=$.$EXIT$.$EXIT: ;;^UTILITY(U,$J,.84,9202,2,78,0) ;;====== ;;^UTILITY(U,$J,.84,9202,2,79,0) ;;=Exit Browser or help text E or "EXIT" ;;^UTILITY(U,$J,.84,9202,2,80,0) ;;=Quit Q or ;;^UTILITY(U,$J,.84,9202,2,81,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,82,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,83,0) ;;= --------------------------------------------------------------------------- ;;^UTILITY(U,$J,.84,9202,2,84,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,85,0) ;;=$.$MORE_HELP$.$MORE HELP ;;^UTILITY(U,$J,.84,9202,2,86,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,87,0) ;;=To GOTO a specific screen or line press the key followed by the letter ;;^UTILITY(U,$J,.84,9202,2,88,0) ;;='G'. This will cause a prompt to be displayed where a screen or line number can ;;^UTILITY(U,$J,.84,9202,2,89,0) ;;=be entered preceded by an 'S' or 'L'. The default is screen, meaning that the DINIT00T DINIT00T ; SFISC/TKW-DIALOG & LANGUAGE FILE INITS ;7:42 AM 6 Dec 2012 ;;22.2;VA FILEMAN;;Mar 28, 2013;Build 19 ;Per VHA Directive 2004-038, this routine should not be modified. F I=1:2 S X=$T(Q+I) Q:X="" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y Q Q ;;^UTILITY(U,$J,.84,9202,2,90,0) ;;='S' is optional when entering a screen number. 10 or S10 will Goto screen 10, ;;^UTILITY(U,$J,.84,9202,2,91,0) ;;=if screen 10 is a valid screen. L99 will go to line 99. ;;^UTILITY(U,$J,.84,9202,2,92,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,93,0) ;;=To change the content of the Title Bar, press ARROW DOWN or ARROW ;;^UTILITY(U,$J,.84,9202,2,94,0) ;;=UP. This function replaces the content of the Title Bar with the text in the ;;^UTILITY(U,$J,.84,9202,2,95,0) ;;=body of the document. Users with programmer access can also use 'T', to ;;^UTILITY(U,$J,.84,9202,2,96,0) ;;=permanently change the title of a hypertext document. ;;^UTILITY(U,$J,.84,9202,2,97,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,98,0) ;;=To copy text to VA FileMan's Clipboard, press C. This open up a ;;^UTILITY(U,$J,.84,9202,2,99,0) ;;=dialog screen and prompts for a line or range of lines to copy or append to the ;;^UTILITY(U,$J,.84,9202,2,100,0) ;;=clipboard. A range of lines are represented by two numeric values separated by ;;^UTILITY(U,$J,.84,9202,2,101,0) ;;=a colon (:), the wild card (*) may also be used if the entire text is ;;^UTILITY(U,$J,.84,9202,2,102,0) ;;=desired. To append to the existing clipboard text, enter the letter 'A' ;;^UTILITY(U,$J,.84,9202,2,103,0) ;;=as the last character, when entering the range of lines to copy. This ;;^UTILITY(U,$J,.84,9202,2,104,0) ;;=text is then retrieved for word-processing fields, when using VA FileMan's ;;^UTILITY(U,$J,.84,9202,2,105,0) ;;=Screen Editor. ;;^UTILITY(U,$J,.84,9202,2,106,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,107,0) ;;=To SPLIT SCREEN, while in Full (Browse Region) Screen mode, press ;;^UTILITY(U,$J,.84,9202,2,108,0) ;;=followed by the letter 'S'. This causes the screen to split into two separate ;;^UTILITY(U,$J,.84,9202,2,109,0) ;;=scroll regions. ;;^UTILITY(U,$J,.84,9202,2,110,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,111,0) ;;=To navigate to the bottom screen, while in Split Screen mode, press ;;^UTILITY(U,$J,.84,9202,2,112,0) ;;=followed by pressing the DOWN ARROW key. ;;^UTILITY(U,$J,.84,9202,2,113,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,114,0) ;;=To navigate to the top screen, while in Split Screen mode, press followed ;;^UTILITY(U,$J,.84,9202,2,115,0) ;;=by pressing the UP ARRAY key. ;;^UTILITY(U,$J,.84,9202,2,116,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,117,0) ;;=To return to FULL SCREEN mode, while in Split Screen mode, press followed ;;^UTILITY(U,$J,.84,9202,2,118,0) ;;=by the letter 'F'. This causes the entire browse region to return to one Full ;;^UTILITY(U,$J,.84,9202,2,119,0) ;;=(Browse) Screen scroll region. ;;^UTILITY(U,$J,.84,9202,2,120,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,121,0) ;;=The BOTTOM STATUS LINE shows that the Browser is in hypertext mode. It ;;^UTILITY(U,$J,.84,9202,2,122,0) ;;=indicates the line numbers that correspond to the bottom text line on the ;;^UTILITY(U,$J,.84,9202,2,123,0) ;;=screen, in the display text section, and provides the total line count. The ;;^UTILITY(U,$J,.84,9202,2,124,0) ;;=screen indicator shows what screen the last line is on and also provides the ;;^UTILITY(U,$J,.84,9202,2,125,0) ;;=total number of screens. ;;^UTILITY(U,$J,.84,9202,2,126,0) ;;= ;;^UTILITY(U,$J,.84,9202,2,127,0) ;;=<<'E' to exit this help document>>> ;;^UTILITY(U,$J,.84,9211,0) ;;=9211^3^^5 ;;^UTILITY(U,$J,.84,9211,1,0) ;;=^^1^1^2960423^^^^ ;;^UTILITY(U,$J,.84,9211,1,1,0) ;;=Screen 1 of Screen Editor help. ;;^UTILITY(U,$J,.84,9211,2,0) ;;=^^18^18^2961212^ ;;^UTILITY(U,$J,.84,9211,2,1,0) ;;= \BHelp Screen 1 of 4\n ;;^UTILITY(U,$J,.84,9211,2,2,0) ;;= ;;^UTILITY(U,$J,.84,9211,2,3,0) ;;=\BSUMMARY OF KEY SEQUENCES\n ;;^UTILITY(U,$J,.84,9211,2,4,0) ;;= ;;^UTILITY(U,$J,.84,9211,2,5,0) ;;=\BNavigation\n ;;^UTILITY(U,$J,.84,9211,2,6,0) ;;= ;;^UTILITY(U,$J,.84,9211,2,7,0) ;;= Incremental movement Arrow keys ;;^UTILITY(U,$J,.84,9211,2,8,0) ;;= One word left and right and ;;^UTILITY(U,$J,.84,9211,2,9,0) ;;= Next tab stop to the right ;;^UTILITY(U,$J,.84,9211,2,10,0) ;;= Jump left and right and ;;^UTILITY(U,$J,.84,9211,2,11,0) ;;= Beginning and end of line and ;;^UTILITY(U,$J,.84,9211,2,12,0) ;;= or: and