DICM0 ;SF/XAK,TKW - LOOKUP WHEN INPUT MUST BE TRANSFORMED ;2/15/00 14:40
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICM0 6120 printed Oct 16, 2024@18:46:51 Page 2
DICM0 ;SF/XAK,TKW - LOOKUP WHEN INPUT MUST BE TRANSFORMED ;2/15/00 14:40
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
P ;Pointers, called by ^DICM1
+1 SET D=""
NEW DICODE,DIASKOK,DIPTRIX
+2 SET DICR(DICR,1)=DIC
SET DIC=U_$PIECE(DS,U,3)
SET Y=DIC(0)
SET DIC(0)=$TRANSLATE(Y,"L","")
+3 SET DICR(DICR,2)=$SELECT($$OKTOADD(.DIFILEI,.DINDEX,.DIFINDER):Y,1:DIC(0))
+4 SET DICR(DICR,2.1)=$SELECT($PIECE(DS,U,2)["'":DIC(0),1:Y)
+5 if '$DATA(DIVPSEL)
NEW DIVPSEL
SET DIVPSEL(DICR)=0
+6 IF DIC(0)["B"
SET DIC(0)=$TRANSLATE(DIC(0),"M","")
SET DICR(DICR,2.1)=$TRANSLATE(DICR(DICR,2.1),"M","")
+7 SET DIC(0)=$TRANSLATE(DIC(0),"NV","")
+8 FOR Y="DR","S","P","W"
IF $DATA(DIC(Y))
MERGE DICR(DICR,Y)=DIC(Y)
KILL DIC(Y)
+9 SET DIPTRIX=$GET(DIC("PTRIX",DIFILEI,+DINDEX(1,"FIELD"),+$PIECE($PIECE(DS,U,2),"P",2)))
AST ; Process screens on pointers.
+1 IF $PIECE(DS,U,2)["*"
IF DICR(DICR,2)["L"
NEW DID,DF
Begin DoDot:1
+2 FOR DICODE=" D ^DIC"," D IX^DIC"," D MIX^DIC1"
Begin DoDot:2
+3 SET Y=$FIND(DS,DICODE)
if 'Y
QUIT
+4 NEW I
SET I=$PIECE($EXTRACT(DS,1,Y-$LENGTH(DICODE)-1),U,5,99)
+5 DO SETSCR(I,.DICR,.DIC,.D,DICODE,.DID,.DF,+$PIECE($PIECE(DS,U,2),"P",2))
QUIT
End DoDot:2
+6 QUIT
End DoDot:1
P1 ; Build screen to make sure selected entry is pointed-to.
+1 SET Y="("_DICR(DICR,1)
if '$DATA(DO)
GOTO L1
KILL DO
IF @("$O"_Y_"0))'>0")
GOTO L1
+2 SET I="DIC"_DICR
SET DICODE="X ""I 0"" N "_I
Begin DoDot:1
+3 IF DINDEX("#")=1
IF $DATA(DICR(DICR,"S"))
SET DICODE=DICODE_",%Y"_DICR
+4 SET DICODE=DICODE_" F "_I_"=0:0 S "_I_"=$O"_Y
SET %=""""_%_""""
End DoDot:1
+5 Begin DoDot:1
+6 IF $GET(DINDEX("#"))>1
DO BLDC(Y,%,DINDEX("#"),DIFILEI,"",.DICODE,.DICR)
QUIT
+7 IF @("$O"_Y_%_",0))>0")
SET DICODE=DICODE_%_",Y,"_I_")) Q:"_I_"'>0 I $D"_Y_I_",0))"_$$CHKTMP(.DIC,DICR,DIFILEI,I)
QUIT
+8 IF DS["DINUM=X"
SET DICODE="I $D"_Y_"Y,0))"_$$CHKTMP(.DIC,DICR,DIFILEI,"Y")_" S "_I_"=Y"
QUIT
+9 IF $PIECE(DS,U,4)="0;1"
SET DICODE=DICODE_I_")) Q:"_I_"'>0 I $P(^("_I_",0),U)=Y"_$$CHKTMP(.DIC,DICR,DIFILEI,I)
QUIT
+10 SET DICODE=""
QUIT
End DoDot:1
if DICODE=""
GOTO L1
+11 IF DINDEX("#")=1
IF $DATA(DICR(DICR,"S"))
SET DICODE=DICODE_" S %Y"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I "
+12 SET DIC("S")=DICODE_" Q"
+13 ; If user passed list of indexes for lookup on pointed-to file, set-up.
+14 IF DIPTRIX]""
SET D=DIPTRIX
DO SETIX(.D,.DIC,.DID,.DF,.DICR,+$PIECE($PIECE(DS,U,2),"P",2))
+15 if $GET(D)=""
SET D="B"
SET Y=0
+16 NEW DS,DINDEX,DIFILEI
DO X^DIC
L1 KILL DIC("S"),@("DIC"_DICR)
+1 IF Y'>0
IF $GET(DTOUT)!($GET(DIROUT))
GOTO R
+2 IF Y'>0
IF '$DATA(DICR(DICR,8))
Begin DoDot:1
+3 IF $GET(DICR(DICR,31.2))
SET DIC("S")="I Y-"_DICR(DICR,31.2)
+4 if '$DATA(DICR(DICR,31))
QUIT
+5 SET DIC("S")=$SELECT($DATA(DIC("S")):DIC("S")_" ",1:"")_DICR(DICR,31)
QUIT
End DoDot:1
GOTO RETRY
+6 IF DICR(DICR,2)["L"
IF DICR(DICR,2)["E"
IF @("$P("_DIC_"0),U,2)'[""O""")
IF $PIECE(@(DICR(DICR,1)_"0)"),U,2)'["O"
IF 'DIVPSEL(DICR)
Begin DoDot:1
+7 NEW I
FOR I=(DICR-1):-1
if '$DATA(DIVPSEL(I))
QUIT
SET DIVPSEL(I)=1
+8 SET DST=" ...OK"
SET %=1
DO Y^DICN
if '$DATA(DDS)
WRITE !
QUIT
End DoDot:1
if %-1
GOTO L2
R KILL DICS,DICW,DO,DIC("W"),DIC("S")
+1 SET DIC=DICR(DICR,1)
SET %=DICR(DICR,2)
SET DIC(0)=$PIECE(%,"M")_$PIECE(%,"M",2)
+2 FOR X="DR","S","P","W"
IF $DATA(DICR(DICR,X))
MERGE DIC(X)=DICR(DICR,X)
+3 IF $DATA(DIC("P"))
IF +DIC("P")=.12
SET DIC(0)=DIC(0)_"X"
+4 DO DO^DIC1
SET X=+Y
if X'>0
KILL X
QUIT
+5 ;
L2 if %-2
GOTO NO
SET DIC("S")="I Y-"_+Y_$SELECT($DATA(DICR(DICR,31)):" "_DICR(DICR,31),1:"")
SET X=DICR(DICR)
if '$DATA(DDS)
WRITE " "_X
IF $DATA(DDS)
IF $GET(DDH)
DO LIST^DDSU
+1 ;
KILL DST
RETRY DO DO^DIC1
KILL DICR(U,+DO(2))
+1 SET D=$GET(DICR(DICR,2.2))
if D]""
SET DF=D
if D=""
SET D="B"
+2 SET DIC(0)=DICR(DICR,2.1)
if "^"[X
SET X=DICR(DICR)
+3 IF $DATA(DIFILEI)
NEW DS,DINDEX,DIFILEI
+4 IF $DATA(DICR(DICR,31))
IF $GET(DA(1))
IF '$GET(DA)
MERGE DS=DA
NEW DA
MERGE DA=DS
SET DA=DA(1)
KILL DS
+5 IF $DATA(DICR(DICR,31.1))
SET DID=DICR(DICR,31.1)
SET DID(1)=2
SET DF=D
+6 DO X^DIC
KILL DICR(DICR,6)
+7 GOTO R
+8 ;
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
+1 NEW %,I,C,X,Y,DISB
SET Y="Y"
+2 IF $GET(DIPGBL)]""
SET Y="(+Y_"";"_$EXTRACT(DIPGBL,2,99)_""")"
+3 SET %=DIGBL_DIXNAM_","_Y
+4 SET DICODE="N DICROUT,DIC"_DICR
Begin DoDot:1
+5 IF $DATA(DICR(DICR,"S"))
SET DICODE=DICODE_",%Y"_DICR
+6 SET DICODE=DICODE_" X ""I 0"" I $D"_%_")) S DICROUT=0 X DICR("_DICR_",""SUB"",2)"
QUIT
End DoDot:1
+7 FOR I=2:1:DIXNO
SET C="N DISB"_I_" S DISB"_I_"="""" "
Begin DoDot:1
+8 SET C=C_"F S DISB"_I_"=$O"_%_",DISB"_I_")) Q:DISB"_I_"="""" X DICR("_DICR_",""SUB"","_(I+1)_") Q:DICROUT"
+9 SET DICR(DICR,"SUB",I)=C
+10 SET %=%_",DISB"_I
QUIT
End DoDot:1
+11 SET I="DIC"_DICR
+12 SET X="S "_I_"=0 F S "_I_"=$O"_%_","_I_")) Q:'"_I_" I $D"_DIGBL_I_",0))"_$$CHKTMP(.DIC,DICR,DIFILEI,I)
+13 IF $DATA(DICR(DICR,"S"))
SET X=X_" S %Y"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I"
+14 SET DICR(DICR,"SUB",DIXNO+1)=X_" S DICROUT=1 Q"
+15 QUIT
+16 ;
CHKTMP(DIC,DICR,DIFILEI,DIVAR) ; If DIC(0)["T", add check to make sure entry hasn't already been presented once before.
+1 IF DIC(0)'["T"!(DICR'=1)
QUIT ""
+2 QUIT ",'$D(^TMP($J,""DICSEEN"","_DIFILEI_","_DIVAR_"))"
+3 ;
SETSCR(DICODE,DICR,DIC,D,DICALL,DID,DF,DIFILEI) ; Execute screening logic for screened pointers and var.ptrs.
+1 NEW DISAV0
SET DISAV0=DIC(0)
Begin DoDot:1
+2 NEW DISAV0
XECUTE DICODE
QUIT
End DoDot:1
SET DIC(0)=DISAV0
+3 if DIC(0)["B"
SET D="B"
+4 IF $DATA(DIC("S"))
SET DICR(DICR,31)=DIC("S")
+5 if $GET(D)=""
QUIT
+6 IF $PIECE(D,U,2)=""
IF DICALL["IX^DIC"
IF DIC(0)["M"
DO SETIX(.D,.DIC,.DID,.DF,.DICR,DIFILEI)
QUIT
+7 IF $PIECE(D,U,2)]""
IF DICALL["MIX^DIC1"
DO SETIX(.D,.DIC,.DID,.DF,.DICR,DIFILEI)
QUIT
+8 SET DICR(DICR,2.2)=D
+9 QUIT
+10 ;
SETIX(D,DIC,DID,DF,DICR,DIFILEI) ; If user passes list of indexes to use on pointed-to file, set up to use them.
+1 IF '$GET(DICR)
NEW DICR
SET DICR=0
+2 IF DICR
Begin DoDot:1
+3 NEW %
SET %=DICR(DICR,2.1)
+4 IF %["L"
IF (U_D_U)'["^B^"
NEW D
SET D=I_"^B"
+5 IF $PIECE(D,U,2)=""
Begin DoDot:2
+6 IF %["M"
SET DICR(DICR,2.1)=$TRANSLATE(%,"M")
+7 KILL DICR(DICR,31.1)
QUIT
End DoDot:2
+8 IF $PIECE(D,U,2)]""
Begin DoDot:2
+9 IF %'["M"
SET DICR(DICR,2.1)=%_"M"
+10 SET DICR(DICR,31.1)=D_"^-1"
QUIT
End DoDot:2
+11 SET DICR(DICR,2.2)=$PIECE(D,U)
QUIT
End DoDot:1
+12 IF DIC(0)["L"
IF (U_D_U)'["^B^"
SET D=D_"^B"
+13 IF $PIECE(D,U,2)=""
Begin DoDot:1
+14 IF DIC(0)["M"
SET DIC(0)=$TRANSLATE(DIC(0),"M")
+15 SET (D,DF)=$PIECE(D,U)
KILL DID
QUIT
End DoDot:1
+16 IF $PIECE(D,U,2)]""
Begin DoDot:1
+17 SET DID=D_"^-1"
SET DID(1)=2
SET (D,DF)=$PIECE(D,U)
+18 if DIC(0)'["M"
SET DIC(0)=DIC(0)_"M"
QUIT
End DoDot:1
+19 QUIT
+20 ;
NO SET Y=-1
GOTO R
+1 ;
OKTOADD(DIFILEI,DINDEX,DIFINDER) ; Return 1 if index is OK for LAYGO.
+1 if $GET(DINDEX(1,"TRANCODE"))]""
QUIT 0
+2 if $GET(DIFINDER)="p"
QUIT 1
+3 if DINDEX="B"
QUIT 1
+4 if DINDEX("#")=1
QUIT 0
+5 if $DATA(DICR("^",DIFILEI,.01,"B"))
QUIT 0
+6 if DINDEX(1,"FILE")'=DIFILEI
QUIT 0
+7 if DINDEX(1,"FIELD")'=.01
QUIT 0
+8 QUIT 1
+9 ;
