INHSZ5 ;JSH; 16 Mar 92 08:35;Script compiler LOOKUP section handler ; 11 Nov 91 6:42 AM
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
L G L^INHSZ1
;
IN ;Enter code
D QCHK^INHSZ0
Q
;
OUT ;Exit code
Q:REPEAT1&'REPEAT!LOOKUP
D DOIT Q
;
DOIT ;Perform the lookup
S:LPARAM="" LPARAM="N"
I 'IDENT D ERROR^INHSZ0("LOOKUP cannot be done without an IDENT command.",1) Q
S A=" S INDAS=$G(INDA) K @INV@(""IDENT.001"") I '$G(INDA) D" D L,DOWN^INHSZ1("")
;First Try to find a match
D:LPARAM'="F"
. N F S F="^"_$$REPLACE^UTIL($P(FILE,"^",2),"""","""""")
. S A=" K DA F I=1:1:MULT S DA(I)=INDA(I)" D L
. S Q="""""""""" S A=" K DO,DIC S:$D(FIELD) DIC(""S"")=""N X,Z I 1 S INF="_Q_",D0=Y F S INF=$O(FIELD(INF)) Q:INF="_Q_"!'$T X FIELD(INF) X """"S Z=""""_FIELD(INF,1) I ((X="_Q_"!(Z="_Q_"))&(FIELD(INF,0)=""""N""""))!(X=Z)""" D L
. I MULT,MULT0["P" S A=" I IDENT?1""`""1.NP S (@INV@(""IDENT.001""),Y)=$P(IDENT,""`"",2),C=$P(^DD("_+MULT0_",.01,0),""^"",2) D Y^DIQ S IDENT=Y,MDESC(2)="".01 = ""_Y" D L D
.. N LINE,V,DICOMPX S V="IDENT.001",DICOMPX("IDENT.001")="",LINE="MATCH IDENT.001=INTERNAL(#.01);E" D MATCH
. S A=" S DIC="""_F_""",DIC(0)=""Y"",X=IDENT K Y S Y=-1 D:$O(@(DIC_""0)"")) ^DIC K DIC S INDA=+Y" D L
. S A=" I 'INDA S MDESC(1)=""Ambiguous lookup - multiple matched found in '"_$S(MULT:$P(^DD(+FILE,0),U)_"' in the '",1:"")_$P(^DIC(+FILE1,0),U)_"' file"" D ERROR^INHS(.MDESC,2)" D L
I LPARAM="N" D
. S A=" I INDA<0 S MDESC(1)=""Entry not found in '"_$S(MULT:$P(^DD(+FILE,0),U)_"' in the '",1:"")_$P(^DIC(+FILE1,0),U)_"' file"" D ERROR^INHS(.MDESC,1)" D L
I LPARAM="L" D
. S A=" D:INDA<0" D L S INDL(INRL)=""
. D LAYGO^INHSZ51
. I 'MULT S A=" I INDA<0 S MDESC(1)=""Could not create new entry in file #"_+FILE_" ("_$P(^DIC(+FILE,0),U)_")"" D ERROR^INHS(.MDESC,2)" D L
. I MULT S A=" I INDA<0 S MDESC(1)=""Could not create new entry in "_$P(^DD(+FILE,0),U)_" in the "_$P(^DIC(+FILE1,0),U)_" file"" D ERROR^INHS(.MDESC,2)" D L
I LPARAM="F" D
. S A=" D" D L S INDL(INRL)=""
. D LAYGO^INHSZ51
. I 'MULT S A=" I INDA<0 S MDESC(1)=""Could not create new entry in file #"_+FILE_" ("_$P(^DIC(+FILE,0),U)_")"" D ERROR^INHS(.MDESC,2)" D L
. I MULT S A=" I INDA<0 S MDESC(1)=""Could not create new entry in "_$P(^DD(+FILE,0),U)_" in the "_$P(^DIC(+FILE1,0),U)_" file"" D ERROR^INHS(.MDESC,2)" D L
S LOOKUP=1 D UP^INHSZ1
S A=" K @INV@(""IDENT.001"") I $G(INDAS)<0 D ERROR^INHS(""Programmer lookup failed (""_INDAS_"") in file #"_+FILE_""",$S(INDAS=-1:2,1:1))" D L
I 'REPEAT,'OTHER,'MULT D QCHK^INHSZ0
Q
;
LOOKUP ;Handle lines in LOOKUP section
;Enter here with LINE array set
N COMM
S COMM=$$LBTB^UTIL($P(LINE," ")) I '$$CMD^INHSZ1(COMM,"SAVE^IF^ENDIF^IDENT^MATCH^PARAM^ERROR^REPEAT^ENDREPEAT^TEMPLATE^ROUTINE^LOOK") D ERROR^INHSZ0("Invalid command in LOOKUP section.",1) Q
S X=$E($$CASECONV^UTIL(COMM,"U"),1,8) G:$T(@X)]"" @X
G @(X_"^INHSZ51")
;
IF G IF^INHSZ21
;
ENDIF G ENDIF^INHSZ21
;
ERROR G ERROR^INHSZ21
;
IDENT ;
Q:'$$SYNTAX^INHSZ0($P(LINE,COMM,2,99),"1."" ""1.ANP")
N V
S V=$$LBTB^UTIL($P(LINE," ",2,999))
I '$D(DICOMPX(V)) D ERROR^INHSZ0("Variable '"_V_"' was not defined.",1) Q
I $D(LVARS(V)),'REPEAT D ERROR^INHSZ0("Variable '"_V_"' was defined in a loop and cannot be used as identifier.",1) Q
S A=" S IDENT=$G(@INV@("""_V_""")),MDESC(2)="" .01 = ""_IDENT" D L
S IDENT=1,MCNT=2 Q
;
MATCH ;Match other fields
N %1,M,F,V,V1,A1
S %1=$$LBTB^UTIL($P(LINE," ",2,999))
Q:'$$SYNTAX^INHSZ0(%1,"1.ANP1""=""1.ANP")
S:%1'?1.ANP1";"1A %1=%1_";E"
S V=$$LBTB^UTIL($P(%1,"=")),F=$$LBTB^UTIL($P($P(%1,"=",2),";")),M=$$CASECONV^UTIL($$LBTB^UTIL($P(%1,";",2)),"U")
I '$D(DICOMPX(V)) D WARN^INHSZ0("Variable '"_V_"' was not defined.",1) S DICOMPX(V)="$G(@INV@("""_V_"""))"
I $D(LVARS(V)),LVARS(V)'=SLVL D ERROR^INHSZ0("Variable '"_V_"' was defined at a different level.",1) Q
I "EN"'[M D ERROR^INHSZ0("Match specifier '"_M_"' is invalid.",1) Q
S:+F F="#"_F
S I(0)="^"_$P(FILE,U,2),J(0)=+FILE,DQI="Y(",DA="FIELD("""_V_""",",DICOMP="",X=F
D
. N DS,DL,DE,V,F,M,DICOMPX D ^DICOMP
. I $D(X),Y["D" S X=X_" S Y=X D DD^%DT S X=Y"
I '$D(X) D ERROR^INHSZ0("Invalid field or expression: "_F,1) Q
S A=" S FIELD("""_V_""")=""N Y "_$$REPLACE^UTIL(X,"""","""""")_"""" D L
S I=0 F S I=$O(X(I)) Q:'I S A=" S FIELD("""_V_""","_I_")="""_$$REPLACE^UTIL(X(I),"""","""""")_"""" D L
S V1=$$VEXP^INHSZ51(V),A1="$S($D("_V1_")#2:"_V1_",1:$G(@INV@("""_V_""")))",A=" S FIELD("""_V_""",1)="""_$$REPLACE^UTIL(A1,"""","""""")_"""" D L
S MCNT=MCNT+1,A=" S FIELD("""_V_""",0)="""_M_""",MDESC("_MCNT_")="" "_$$REPLACE^UTIL(F,"""","""""")_" = ""_"_A1_"_"" ("_$S(M="E":"Exact Match",1:"Null Matches anything")_")""" D L
Q
;
LOOK ;command used in REPEAT block to perform lookup
I 'REPEAT D ERROR^INHSZ0("LOOK command only used within a REPEAT block in the LOOKUP section.",1) Q
D DOIT Q
;
PARAM ;Set Lookup parameter
S LPARAM=$$CASECONV^UTIL($$LBTB^UTIL($P(LINE," ",2,999)),"U") I "NFL"'[LPARAM!($L(LPARAM)>1) D ERROR^INHSZ0("Invalid LOOKUP specifier.",1)
Q
;
INHSZ5 ;JSH; 16 Mar 92 08:35;Script compiler LOOKUP section handler ; 11 Nov 91 6:42 AM
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
L GOTO L^INHSZ1
+1 ;
IN ;Enter code
+1 DO QCHK^INHSZ0
+2 QUIT
+3 ;
OUT ;Exit code
+1 IF REPEAT1&'REPEAT!LOOKUP
QUIT
+2 DO DOIT
QUIT
+3 ;
DOIT ;Perform the lookup
+1 IF LPARAM=""
SET LPARAM="N"
+2 IF 'IDENT
DO ERROR^INHSZ0("LOOKUP cannot be done without an IDENT command.",1)
QUIT
+3 SET A=" S INDAS=$G(INDA) K @INV@(""IDENT.001"") I '$G(INDA) D"
DO L
DO DOWN^INHSZ1("")
+4 ;First Try to find a match
+5 IF LPARAM'="F"
Begin DoDot:1
+6 NEW F
SET F="^"_$$REPLACE^UTIL($PIECE(FILE,"^",2),"""","""""")
+7 SET A=" K DA F I=1:1:MULT S DA(I)=INDA(I)"
DO L
+8 SET Q=""""""""""
SET A=" K DO,DIC S:$D(FIELD) DIC(""S"")=""N X,Z I 1 S INF="_Q_",D0=Y F S INF=$O(FIELD(INF)) Q:INF="_Q_"!'$T X FIELD(INF) X """"S Z=""""_FIELD(INF,1) I ((X="_Q_"!(Z="_Q_"))&(FIELD(INF,0)=""""N""""))!(X=Z)"""
DO L
+9 IF MULT
IF MULT0["P"
SET A=" I IDENT?1""`""1.NP S (@INV@(""IDENT.001""),Y)=$P(IDENT,""`"",2),C=$P(^DD("_+MULT0_",.01,0),""^"",2) D Y^DIQ S IDENT=Y,MDESC(2)="".01 = ""_Y"
DO L
Begin DoDot:2
+10 NEW LINE,V,DICOMPX
SET V="IDENT.001"
SET DICOMPX("IDENT.001")=""
SET LINE="MATCH IDENT.001=INTERNAL(#.01);E"
DO MATCH
End DoDot:2
+11 SET A=" S DIC="""_F_""",DIC(0)=""Y"",X=IDENT K Y S Y=-1 D:$O(@(DIC_""0)"")) ^DIC K DIC S INDA=+Y"
DO L
+12 SET A=" I 'INDA S MDESC(1)=""Ambiguous lookup - multiple matched found in '"_$SELECT(MULT:$PIECE(^DD(+FILE,0),U)_"' in the '",1:"")_$PIECE(^DIC(+FILE1,0),U)_"' file"" D ERROR^INHS(.MDESC,2)"
DO L
End DoDot:1
+13 IF LPARAM="N"
Begin DoDot:1
+14 SET A=" I INDA<0 S MDESC(1)=""Entry not found in '"_$SELECT(MULT:$PIECE(^DD(+FILE,0),U)_"' in the '",1:"")_$PIECE(^DIC(+FILE1,0),U)_"' file"" D ERROR^INHS(.MDESC,1)"
DO L
End DoDot:1
+15 IF LPARAM="L"
Begin DoDot:1
+16 SET A=" D:INDA<0"
DO L
SET INDL(INRL)=""
+17 DO LAYGO^INHSZ51
+18 IF 'MULT
SET A=" I INDA<0 S MDESC(1)=""Could not create new entry in file #"_+FILE_" ("_$PIECE(^DIC(+FILE,0),U)_")"" D ERROR^INHS(.MDESC,2)"
DO L
+19 IF MULT
SET A=" I INDA<0 S MDESC(1)=""Could not create new entry in "_$PIECE(^DD(+FILE,0),U)_" in the "_$PIECE(^DIC(+FILE1,0),U)_" file"" D ERROR^INHS(.MDESC,2)"
DO L
End DoDot:1
+20 IF LPARAM="F"
Begin DoDot:1
+21 SET A=" D"
DO L
SET INDL(INRL)=""
+22 DO LAYGO^INHSZ51
+23 IF 'MULT
SET A=" I INDA<0 S MDESC(1)=""Could not create new entry in file #"_+FILE_" ("_$PIECE(^DIC(+FILE,0),U)_")"" D ERROR^INHS(.MDESC,2)"
DO L
+24 IF MULT
SET A=" I INDA<0 S MDESC(1)=""Could not create new entry in "_$PIECE(^DD(+FILE,0),U)_" in the "_$PIECE(^DIC(+FILE1,0),U)_" file"" D ERROR^INHS(.MDESC,2)"
DO L
End DoDot:1
+25 SET LOOKUP=1
DO UP^INHSZ1
+26 SET A=" K @INV@(""IDENT.001"") I $G(INDAS)<0 D ERROR^INHS(""Programmer lookup failed (""_INDAS_"") in file #"_+FILE_""",$S(INDAS=-1:2,1:1))"
DO L
+27 IF 'REPEAT
IF 'OTHER
IF 'MULT
DO QCHK^INHSZ0
+28 QUIT
+29 ;
LOOKUP ;Handle lines in LOOKUP section
+1 ;Enter here with LINE array set
+2 NEW COMM
+3 SET COMM=$$LBTB^UTIL($PIECE(LINE," "))
IF '$$CMD^INHSZ1(COMM,"SAVE^IF^ENDIF^IDENT^MATCH^PARAM^ERROR^REPEAT^ENDREPEAT^TEMPLATE^ROUTINE^LOOK")
DO ERROR^INHSZ0("Invalid command in LOOKUP section.",1)
QUIT
+4 SET X=$EXTRACT($$CASECONV^UTIL(COMM,"U"),1,8)
IF $TEXT(@X)]""
GOTO @X
+5 GOTO @(X_"^INHSZ51")
+6 ;
IF GOTO IF^INHSZ21
+1 ;
ENDIF GOTO ENDIF^INHSZ21
+1 ;
ERROR GOTO ERROR^INHSZ21
+1 ;
IDENT ;
+1 IF '$$SYNTAX^INHSZ0($PIECE(LINE,COMM,2,99),"1."" ""1.ANP")
QUIT
+2 NEW V
+3 SET V=$$LBTB^UTIL($PIECE(LINE," ",2,999))
+4 IF '$DATA(DICOMPX(V))
DO ERROR^INHSZ0("Variable '"_V_"' was not defined.",1)
QUIT
+5 IF $DATA(LVARS(V))
IF 'REPEAT
DO ERROR^INHSZ0("Variable '"_V_"' was defined in a loop and cannot be used as identifier.",1)
QUIT
+6 SET A=" S IDENT=$G(@INV@("""_V_""")),MDESC(2)="" .01 = ""_IDENT"
DO L
+7 SET IDENT=1
SET MCNT=2
QUIT
+8 ;
MATCH ;Match other fields
+1 NEW %1,M,F,V,V1,A1
+2 SET %1=$$LBTB^UTIL($PIECE(LINE," ",2,999))
+3 IF '$$SYNTAX^INHSZ0(%1,"1.ANP1""=""1.ANP")
QUIT
+4 IF %1'?1.ANP1";"1A
SET %1=%1_";E"
+5 SET V=$$LBTB^UTIL($PIECE(%1,"="))
SET F=$$LBTB^UTIL($PIECE($PIECE(%1,"=",2),";"))
SET M=$$CASECONV^UTIL($$LBTB^UTIL($PIECE(%1,";",2)),"U")
+6 IF '$DATA(DICOMPX(V))
DO WARN^INHSZ0("Variable '"_V_"' was not defined.",1)
SET DICOMPX(V)="$G(@INV@("""_V_"""))"
+7 IF $DATA(LVARS(V))
IF LVARS(V)'=SLVL
DO ERROR^INHSZ0("Variable '"_V_"' was defined at a different level.",1)
QUIT
+8 IF "EN"'[M
DO ERROR^INHSZ0("Match specifier '"_M_"' is invalid.",1)
QUIT
+9 IF +F
SET F="#"_F
+10 SET I(0)="^"_$PIECE(FILE,U,2)
SET J(0)=+FILE
SET DQI="Y("
SET DA="FIELD("""_V_""","
SET DICOMP=""
SET X=F
+11 Begin DoDot:1
+12 NEW DS,DL,DE,V,F,M,DICOMPX
DO ^DICOMP
+13 IF $DATA(X)
IF Y["D"
SET X=X_" S Y=X D DD^%DT S X=Y"
End DoDot:1
+14 IF '$DATA(X)
DO ERROR^INHSZ0("Invalid field or expression: "_F,1)
QUIT
+15 SET A=" S FIELD("""_V_""")=""N Y "_$$REPLACE^UTIL(X,"""","""""")_""""
DO L
+16 SET I=0
FOR
SET I=$ORDER(X(I))
IF 'I
QUIT
SET A=" S FIELD("""_V_""","_I_")="""_$$REPLACE^UTIL(X(I),"""","""""")_""""
DO L
+17 SET V1=$$VEXP^INHSZ51(V)
SET A1="$S($D("_V1_")#2:"_V1_",1:$G(@INV@("""_V_""")))"
SET A=" S FIELD("""_V_""",1)="""_$$REPLACE^UTIL(A1,"""","""""")_""""
DO L
+18 SET MCNT=MCNT+1
SET A=" S FIELD("""_V_""",0)="""_M_""",MDESC("_MCNT_")="" "_$$REPLACE^UTIL(F,"""","""""")_" = ""_"_A1_"_"" ("_$SELECT(M="E":"Exact Match",1:"Null Matches anything")_")"""
DO L
+19 QUIT
+20 ;
LOOK ;command used in REPEAT block to perform lookup
+1 IF 'REPEAT
DO ERROR^INHSZ0("LOOK command only used within a REPEAT block in the LOOKUP section.",1)
QUIT
+2 DO DOIT
QUIT
+3 ;
PARAM ;Set Lookup parameter
+1 SET LPARAM=$$CASECONV^UTIL($$LBTB^UTIL($PIECE(LINE," ",2,999)),"U")
IF "NFL"'[LPARAM!($LENGTH(LPARAM)>1)
DO ERROR^INHSZ0("Invalid LOOKUP specifier.",1)
+2 QUIT
+3 ;
