- 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 ;