INHSZ21 ;JSH,DGH; 20 Dec 1999 09:35 ;INHSZ2 continued outbound msg; 19 Dec 91 1:00PM
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;CHCS TOOLS_460; GEN 10; 23-JUL-1997
;COPYRIGHT 1988, 1989, 1990 SAIC
;Changes needed for X12, NOT for NCPDP after redesign.
L G L^INHSZ1
;
DELIM ;Set delimiter character
N %1 S %1=$$LBTB^UTIL($P(LINE,"=",2))
I MODE="I" D DELI G DELQ
Q:'$$SYNTAX^INHSZ0($P(LINE,COMM,2,99),"."" ""1""=""."" ""1"""""""".E.""""""""")
S A=" S DELIM="""_$P($P(%1,"""",2),"""")_"""" D L
DELQ S DELIM=1,DICOMPX("DELIM")=""""_$P($P(%1,"""",2),"""")_""""
Q
DELI ;INPUT mode version of delimiter set.
N DICOMPX S DICOMPX("DATA")="$$GL^INHOU(UIF,LCT)",X=%1 D DICOMP(.X)
I '$D(X) D ERROR^INHSZ0("Invalid expression to set the DELIMITER.",1) Q
S A=" "_X_" S DELIM=X K DXS" D L Q
;
SUBDELIM ;set subdelimiter character
N %1 S %1=$$LBTB^UTIL($P(LINE,"=",2))
I MODE="I" D SUBI G SUBQ
Q:'$$SYNTAX^INHSZ0($P(LINE,COMM,2,99),"."" ""1""=""."" ""1"""""""".E1""""""""")
S A=" S SUBDELIM="""_$P($P(%1,"""",2),"""")_"""" D L
SUBQ S SUBDELIM=1,DICOMPX("SUBDELIM")=""""_$P($P(%1,"""",2),"""")_""""
Q
SUBI ;INPUT mode version of subdelimiter set
N DICOMPX S DICOMPX("DATA")="$$GL^INHOU(UIF,LCT)",X=%1 D DICOMP(.X)
I '$D(X) D ERROR^INHSZ0("Invalid expression to set the SUBDELIMITER.",1) Q
S A=" "_X_" S SUBDELIM=X K DXS S INDELIMS=DELIM_$P(Y(1),DELIM,2)" D L
Q
;
SET ;SET statement
I MODE="I" D ERROR^INHSZ0("SET statement allow in Output scripts only.",1) Q
Q:'$$SYNTAX^INHSZ0($$LB^UTIL($P(LINE,COMM,2,99)),"."" ""1.ANP1""=""1.E")
N %1,I,J,V,X,INXFRM,INCONV
S V=$$LBTB^UTIL($P($P(LINE,"SET",2),"="))
S A=" ;"_LINE D L
S X=$$LB^UTIL($P(LINE,"=",2)) S:X X="#"_X
;Following replaces old INSGX function
I $E(X,1,5)="INSGX" S INXFRM=$P(X,"\",2),INCONV=$P(X,"\",3),LEN=$P(X,"\",4),X=$P(X,"\",5,99)
S DICOMPX=""
D ATSET(X),DICOMP(.X,0,1)
I FILE="",$P(DICOMPX,U)=0 K X
I '$D(X) D ERROR^INHSZ0("Invalid expression in SET statement.",1) Q
S A=" S D0=INDA "_X D L
;To replace INSGX function create another line in compiled code which
;will execute the transform or the conversion.
I ($L($G(INXFRM))!$L($G(INCONV))) D
.I $L($G(INXFRM)) S A=" S X1="""_INXFRM_""" X:$L($G(@X1)) $G(@X1)"
.S A=A_" S X=$E(X,1,"_LEN_")"
.I $L($G(INCONV)) S A=A_" S X1="""_INCONV_""" X:$L($G(@X1)) $G(@X1)"
.D L
S A=" S @INV@("""_V_""")=X K DXS,D0" D L S SET(V)="",DICOMPX(V)="@INV@("""_V_""")"
Q
;
IF ;IF statement
Q:'$$SYNTAX^INHSZ0($P(LINE,COMM,2,99),"1."" ""1.ANP")
N I,J,DA,DQI,X,Q,D0,%1 S D0=0
S A=" ;"_LINE D L
S (%1,X)=$$LBTB^UTIL($P(LINE," ",2,999))
D ATSET(X),DICOMP(.X)
G:'$D(X) IFM
I Y'["B" D ERROR^INHSZ0("Expression is not Boolean in structure.",1) Q
S:X["D0" D0=1
I MODE="I",SECT'="STORE",D0 D ERROR^INHSZ0("Expression involves a file entry which is not yet determined.",1) Q
S A=" "_X_" K DXS,D0 I X" D L
IFQ S IF=IF+1,A=" D:$T" D L,DOWN^INHSZ1("I") Q
;
IFM ;IF may be MUMPS code
S X="I "_%1 D ^DIM I '$D(X) D ERROR^INHSZ0("Expression INVALID.",1) Q
S A=" "_X D L G IFQ
;
ENDIF ;end of an IF block
I 'IF D ERROR^INHSZ0("No active IF to end.",0) Q
I $P(INDS(DOTLVL),U)'="I" D ERROR^INHSZ0("Misplaced ENDIF",0) Q
S IF=IF-1 D UP^INHSZ1 Q
;
DICOMP(X,%N,%W) ;Run DICOMP to evaluate expression
;X= expression to evaluate (pass by reference)
;If %N=1 then DICOMPX will not be used
;If %W=1 then WP fields may be specified - first line will be used
N %,V,V1,I,J,DICOMP,DS,DL,DE,DICMX,INOLDX N:$G(%N) DICOMPX
S:$G(%W) DICMX="S INX=$P(X,""|CR|"") Q "
S DA="DXS(",DQI="Y(",DICOMP="",I(0)="^"_$P(FILE,U,2),J(0)=+FILE,DICOMP="",INOLDX=X
D ^DICOMP I '$D(X) D Q:'$D(X)
. Q:$G(MODE)="I" ;Don't double check inbound scripts
. S %=$P($G(^DIC(+FILE,0)),U,1) S:'$L(%) %=$P($G(^DD(+FILE,0)),U,1)
. W *7,!!,"Ambiguity in the following expression:"
. W !,"Current base file: ",%," (#",+FILE,")",!,"Expression: ",INOLDX,!
. S X=INOLDX,DICOMP="?" D ^DICOMP S DICOMP=""
. W !,"Ambiguity ",$S($D(X):"",1:"NOT "),"resolved.",!
F I=0:0 S I=$O(X(I)) Q:'I S:X(I)["D0" D0=1 S A=" S DXS("_I_")="""_$$REPLACE^UTIL(X(I),"""","""""")_"""" D L
S:Y["w"!(Y["l") X="K INX "_X_" S X=$G(INX)"
Q
;
ATSET(X) ;Set DICOMPX array for any @variables in the code
;X = code to process
N Q,I,J
S Q=0 F I=1:1:$L(X) D
. I $E(X,I)="""" S Q='Q Q
. Q:$E(X,I)'="@"
. F J=I+1:1 Q:$E(X,J)'?1AN
. S DICOMPX($E(X,I,J-1))="$G(INA("""_$E(X,I+1,J-1)_""""_$G(WHSUB)_"))",I=J
Q
;
WHILE ;WHILE loop initiate
N %E I $D(LINE)>9 D ERROR^INHSZ0("Line too long.",1)
S %E=$$LBTB^UTIL($P(LINE,"WHILE",2,99))
S:$P(%E," ")="~REQUIRED~" %E=$$LBTB^UTIL($P(LINE,"~REQUIRED~",2,99))
I '$L(%E) D ERROR^INHSZ0("Condition missing from WHILE statement.",1) Q
G:MODE="O" WHILE^INHSZ20
S X="I "_%E D ^DIM I '$D(X) D ERROR^INHSZ0("Condition not valid.",1) Q
S A=" ;"_LINE D L S WHILE=WHILE+1
I $P(LINE," ",1,2)="WHILE ~REQUIRED~" S A=" I $P($$GL^INHOU(UIF,LCT),DELIM)'="_$P(%E,"=",2)_" Q:'$$CHECKSEG^INHOU("_$P(%E,"=",2)_",1,"_WHILE_")"_$S(WHILE>1:"",1:" 2") D L
S A=" S INI("_WHILE_")=1 F "_$S(MODE="I":"S DATA=$$GL^INHOU(UIF,LCT) Q:'$$CHECKSEG^INHOU("_$P(%E,"=",2)_",0,"_WHILE_")",1:"Q:'("_%E_")")_" D S INI("_WHILE_")=INI("_WHILE_")+1" D L
D DOWN^INHSZ1("W")
S WHSUB=WHSUB_",INI("_WHILE_")"
Q
;
ENDWHILE ;End of while loop
I 'DOTLVL D ERROR^INHSZ0("No active WHILE to end.",1) Q
I $P(INDS(DOTLVL),U)'="W" D ERROR^INHSZ0("Misplaced ENDWHILE.",1) Q
G:MODE="O" ENDWHILE^INHSZ20
S WHILE=WHILE-1 D UP^INHSZ1 S WHSUB=$P(WHSUB,",",1,WHILE+1) S:'WHILE WHSUB=""
Q
;
GROUP ;Initiate a GROUP
I $P(LINE,COMM,2)]"" D WARN^INHSZ0("Characters after GROUP ignored.",1)
S A=" ;Start of GROUP" D L
S A=" F S MATCH=0 D Q:'MATCH" D L
D DOWN^INHSZ1("G") S GROUP=1 Q
;
ENDGROUP ;End of group
I 'DOTLVL D ERROR^INHSZ0("No active GROUP to end.",1) Q
I $P(INDS(DOTLVL),U)'="G" D ERROR^INHSZ0("Misplaced ENDGROUP.",1) Q
D UP^INHSZ1 S GROUP=0 Q
;
ERROR ;ERROR command
Q:'$$SYNTAX^INHSZ0($P(LINE,COMM,2),"."" ""1""=""."" ""1""""""""1.ANP1""""""""."" "".1"";""."" "".1N")
N M,T
S M=$$LBTB^UTIL($P($P(LINE,"=",2),";"))
S T=$$LBTB^UTIL($P(LINE,";",2))
I T]"",$L(T)>1!("12"'[T) D ERROR^INHSZ0("Illegal error type '"_T_"' in ERROR statement.",1) Q
S:T="" T=2
S A=" D ERROR^INHS("_M_","_T_")" D L
Q
;
BHLMIEN ;Set Message IEN
N %1 S %1=$$LBTB^UTIL($P(LINE,"=",2))
Q:'$$SYNTAX^INHSZ0($P(LINE,COMM,2,99),"."" ""1""=""."" ""1"""""""".E.""""""""")
S A=" S BHLMIEN="""_$P($P(%1,"""",2),"""")_"""" D L
S BHLMIEN=1,DICOMPX("BHLMIEN")=""""_$P($P(%1,"""",2),"""")_""""
Q
INHSZ21 ;JSH,DGH; 20 Dec 1999 09:35 ;INHSZ2 continued outbound msg; 19 Dec 91 1:00PM
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;CHCS TOOLS_460; GEN 10; 23-JUL-1997
+4 ;COPYRIGHT 1988, 1989, 1990 SAIC
+5 ;Changes needed for X12, NOT for NCPDP after redesign.
L GOTO L^INHSZ1
+1 ;
DELIM ;Set delimiter character
+1 NEW %1
SET %1=$$LBTB^UTIL($PIECE(LINE,"=",2))
+2 IF MODE="I"
DO DELI
GOTO DELQ
+3 IF '$$SYNTAX^INHSZ0($PIECE(LINE,COMM,2,99),"."" ""1""=""."" ""1"""""""".E.""""""""")
QUIT
+4 SET A=" S DELIM="""_$PIECE($PIECE(%1,"""",2),"""")_""""
DO L
DELQ SET DELIM=1
SET DICOMPX("DELIM")=""""_$PIECE($PIECE(%1,"""",2),"""")_""""
+1 QUIT
DELI ;INPUT mode version of delimiter set.
+1 NEW DICOMPX
SET DICOMPX("DATA")="$$GL^INHOU(UIF,LCT)"
SET X=%1
DO DICOMP(.X)
+2 IF '$DATA(X)
DO ERROR^INHSZ0("Invalid expression to set the DELIMITER.",1)
QUIT
+3 SET A=" "_X_" S DELIM=X K DXS"
DO L
QUIT
+4 ;
SUBDELIM ;set subdelimiter character
+1 NEW %1
SET %1=$$LBTB^UTIL($PIECE(LINE,"=",2))
+2 IF MODE="I"
DO SUBI
GOTO SUBQ
+3 IF '$$SYNTAX^INHSZ0($PIECE(LINE,COMM,2,99),"."" ""1""=""."" ""1"""""""".E1""""""""")
QUIT
+4 SET A=" S SUBDELIM="""_$PIECE($PIECE(%1,"""",2),"""")_""""
DO L
SUBQ SET SUBDELIM=1
SET DICOMPX("SUBDELIM")=""""_$PIECE($PIECE(%1,"""",2),"""")_""""
+1 QUIT
SUBI ;INPUT mode version of subdelimiter set
+1 NEW DICOMPX
SET DICOMPX("DATA")="$$GL^INHOU(UIF,LCT)"
SET X=%1
DO DICOMP(.X)
+2 IF '$DATA(X)
DO ERROR^INHSZ0("Invalid expression to set the SUBDELIMITER.",1)
QUIT
+3 SET A=" "_X_" S SUBDELIM=X K DXS S INDELIMS=DELIM_$P(Y(1),DELIM,2)"
DO L
+4 QUIT
+5 ;
SET ;SET statement
+1 IF MODE="I"
DO ERROR^INHSZ0("SET statement allow in Output scripts only.",1)
QUIT
+2 IF '$$SYNTAX^INHSZ0($$LB^UTIL($PIECE(LINE,COMM,2,99)),"."" ""1.ANP1""=""1.E")
QUIT
+3 NEW %1,I,J,V,X,INXFRM,INCONV
+4 SET V=$$LBTB^UTIL($PIECE($PIECE(LINE,"SET",2),"="))
+5 SET A=" ;"_LINE
DO L
+6 SET X=$$LB^UTIL($PIECE(LINE,"=",2))
IF X
SET X="#"_X
+7 ;Following replaces old INSGX function
+8 IF $EXTRACT(X,1,5)="INSGX"
SET INXFRM=$PIECE(X,"\",2)
SET INCONV=$PIECE(X,"\",3)
SET LEN=$PIECE(X,"\",4)
SET X=$PIECE(X,"\",5,99)
+9 SET DICOMPX=""
+10 DO ATSET(X)
DO DICOMP(.X,0,1)
+11 IF FILE=""
IF $PIECE(DICOMPX,U)=0
KILL X
+12 IF '$DATA(X)
DO ERROR^INHSZ0("Invalid expression in SET statement.",1)
QUIT
+13 SET A=" S D0=INDA "_X
DO L
+14 ;To replace INSGX function create another line in compiled code which
+15 ;will execute the transform or the conversion.
+16 IF ($LENGTH($GET(INXFRM))!$LENGTH($GET(INCONV)))
Begin DoDot:1
+17 IF $LENGTH($GET(INXFRM))
SET A=" S X1="""_INXFRM_""" X:$L($G(@X1)) $G(@X1)"
+18 SET A=A_" S X=$E(X,1,"_LEN_")"
+19 IF $LENGTH($GET(INCONV))
SET A=A_" S X1="""_INCONV_""" X:$L($G(@X1)) $G(@X1)"
+20 DO L
End DoDot:1
+21 SET A=" S @INV@("""_V_""")=X K DXS,D0"
DO L
SET SET(V)=""
SET DICOMPX(V)="@INV@("""_V_""")"
+22 QUIT
+23 ;
IF ;IF statement
+1 IF '$$SYNTAX^INHSZ0($PIECE(LINE,COMM,2,99),"1."" ""1.ANP")
QUIT
+2 NEW I,J,DA,DQI,X,Q,D0,%1
SET D0=0
+3 SET A=" ;"_LINE
DO L
+4 SET (%1,X)=$$LBTB^UTIL($PIECE(LINE," ",2,999))
+5 DO ATSET(X)
DO DICOMP(.X)
+6 IF '$DATA(X)
GOTO IFM
+7 IF Y'["B"
DO ERROR^INHSZ0("Expression is not Boolean in structure.",1)
QUIT
+8 IF X["D0"
SET D0=1
+9 IF MODE="I"
IF SECT'="STORE"
IF D0
DO ERROR^INHSZ0("Expression involves a file entry which is not yet determined.",1)
QUIT
+10 SET A=" "_X_" K DXS,D0 I X"
DO L
IFQ SET IF=IF+1
SET A=" D:$T"
DO L
DO DOWN^INHSZ1("I")
QUIT
+1 ;
IFM ;IF may be MUMPS code
+1 SET X="I "_%1
DO ^DIM
IF '$DATA(X)
DO ERROR^INHSZ0("Expression INVALID.",1)
QUIT
+2 SET A=" "_X
DO L
GOTO IFQ
+3 ;
ENDIF ;end of an IF block
+1 IF 'IF
DO ERROR^INHSZ0("No active IF to end.",0)
QUIT
+2 IF $PIECE(INDS(DOTLVL),U)'="I"
DO ERROR^INHSZ0("Misplaced ENDIF",0)
QUIT
+3 SET IF=IF-1
DO UP^INHSZ1
QUIT
+4 ;
DICOMP(X,%N,%W) ;Run DICOMP to evaluate expression
+1 ;X= expression to evaluate (pass by reference)
+2 ;If %N=1 then DICOMPX will not be used
+3 ;If %W=1 then WP fields may be specified - first line will be used
+4 NEW %,V,V1,I,J,DICOMP,DS,DL,DE,DICMX,INOLDX
IF $GET(%N)
NEW DICOMPX
+5 IF $GET(%W)
SET DICMX="S INX=$P(X,""|CR|"") Q "
+6 SET DA="DXS("
SET DQI="Y("
SET DICOMP=""
SET I(0)="^"_$PIECE(FILE,U,2)
SET J(0)=+FILE
SET DICOMP=""
SET INOLDX=X
+7 DO ^DICOMP
IF '$DATA(X)
Begin DoDot:1
+8 ;Don't double check inbound scripts
IF $GET(MODE)="I"
QUIT
+9 SET %=$PIECE($GET(^DIC(+FILE,0)),U,1)
IF '$LENGTH(%)
SET %=$PIECE($GET(^DD(+FILE,0)),U,1)
+10 WRITE *7,!!,"Ambiguity in the following expression:"
+11 WRITE !,"Current base file: ",%," (#",+FILE,")",!,"Expression: ",INOLDX,!
+12 SET X=INOLDX
SET DICOMP="?"
DO ^DICOMP
SET DICOMP=""
+13 WRITE !,"Ambiguity ",$SELECT($DATA(X):"",1:"NOT "),"resolved.",!
End DoDot:1
IF '$DATA(X)
QUIT
+14 FOR I=0:0
SET I=$ORDER(X(I))
IF 'I
QUIT
IF X(I)["D0"
SET D0=1
SET A=" S DXS("_I_")="""_$$REPLACE^UTIL(X(I),"""","""""")_""""
DO L
+15 IF Y["w"!(Y["l")
SET X="K INX "_X_" S X=$G(INX)"
+16 QUIT
+17 ;
ATSET(X) ;Set DICOMPX array for any @variables in the code
+1 ;X = code to process
+2 NEW Q,I,J
+3 SET Q=0
FOR I=1:1:$LENGTH(X)
Begin DoDot:1
+4 IF $EXTRACT(X,I)=""""
SET Q='Q
QUIT
+5 IF $EXTRACT(X,I)'="@"
QUIT
+6 FOR J=I+1:1
IF $EXTRACT(X,J)'?1AN
QUIT
+7 SET DICOMPX($EXTRACT(X,I,J-1))="$G(INA("""_$EXTRACT(X,I+1,J-1)_""""_$GET(WHSUB)_"))"
SET I=J
End DoDot:1
+8 QUIT
+9 ;
WHILE ;WHILE loop initiate
+1 NEW %E
IF $DATA(LINE)>9
DO ERROR^INHSZ0("Line too long.",1)
+2 SET %E=$$LBTB^UTIL($PIECE(LINE,"WHILE",2,99))
+3 IF $PIECE(%E," ")="~REQUIRED~"
SET %E=$$LBTB^UTIL($PIECE(LINE,"~REQUIRED~",2,99))
+4 IF '$LENGTH(%E)
DO ERROR^INHSZ0("Condition missing from WHILE statement.",1)
QUIT
+5 IF MODE="O"
GOTO WHILE^INHSZ20
+6 SET X="I "_%E
DO ^DIM
IF '$DATA(X)
DO ERROR^INHSZ0("Condition not valid.",1)
QUIT
+7 SET A=" ;"_LINE
DO L
SET WHILE=WHILE+1
+8 IF $PIECE(LINE," ",1,2)="WHILE ~REQUIRED~"
SET A=" I $P($$GL^INHOU(UIF,LCT),DELIM)'="_$PIECE(%E,"=",2)_" Q:'$$CHECKSEG^INHOU("_$PIECE(%E,"=",2)_",1,"_WHILE_")"_$SELECT(WHILE>1:"",1:" 2")
DO L
+9 SET A=" S INI("_WHILE_")=1 F "_$SELECT(MODE="I":"S DATA=$$GL^INHOU(UIF,LCT) Q:'$$CHECKSEG^INHOU("_$PIECE(%E,"=",2)_",0,"_WHILE_")",1:"Q:'("_%E_")")_" D S INI("_WHILE_")=INI("_WHILE_")+1"
DO L
+10 DO DOWN^INHSZ1("W")
+11 SET WHSUB=WHSUB_",INI("_WHILE_")"
+12 QUIT
+13 ;
ENDWHILE ;End of while loop
+1 IF 'DOTLVL
DO ERROR^INHSZ0("No active WHILE to end.",1)
QUIT
+2 IF $PIECE(INDS(DOTLVL),U)'="W"
DO ERROR^INHSZ0("Misplaced ENDWHILE.",1)
QUIT
+3 IF MODE="O"
GOTO ENDWHILE^INHSZ20
+4 SET WHILE=WHILE-1
DO UP^INHSZ1
SET WHSUB=$PIECE(WHSUB,",",1,WHILE+1)
IF 'WHILE
SET WHSUB=""
+5 QUIT
+6 ;
GROUP ;Initiate a GROUP
+1 IF $PIECE(LINE,COMM,2)]""
DO WARN^INHSZ0("Characters after GROUP ignored.",1)
+2 SET A=" ;Start of GROUP"
DO L
+3 SET A=" F S MATCH=0 D Q:'MATCH"
DO L
+4 DO DOWN^INHSZ1("G")
SET GROUP=1
QUIT
+5 ;
ENDGROUP ;End of group
+1 IF 'DOTLVL
DO ERROR^INHSZ0("No active GROUP to end.",1)
QUIT
+2 IF $PIECE(INDS(DOTLVL),U)'="G"
DO ERROR^INHSZ0("Misplaced ENDGROUP.",1)
QUIT
+3 DO UP^INHSZ1
SET GROUP=0
QUIT
+4 ;
ERROR ;ERROR command
+1 IF '$$SYNTAX^INHSZ0($PIECE(LINE,COMM,2),"."" ""1""=""."" ""1""""""""1.ANP1""""""""."" "".1"";""."" "".1N")
QUIT
+2 NEW M,T
+3 SET M=$$LBTB^UTIL($PIECE($PIECE(LINE,"=",2),";"))
+4 SET T=$$LBTB^UTIL($PIECE(LINE,";",2))
+5 IF T]""
IF $LENGTH(T)>1!("12"'[T)
DO ERROR^INHSZ0("Illegal error type '"_T_"' in ERROR statement.",1)
QUIT
+6 IF T=""
SET T=2
+7 SET A=" D ERROR^INHS("_M_","_T_")"
DO L
+8 QUIT
+9 ;
BHLMIEN ;Set Message IEN
+1 NEW %1
SET %1=$$LBTB^UTIL($PIECE(LINE,"=",2))
+2 IF '$$SYNTAX^INHSZ0($PIECE(LINE,COMM,2,99),"."" ""1""=""."" ""1"""""""".E.""""""""")
QUIT
+3 SET A=" S BHLMIEN="""_$PIECE($PIECE(%1,"""",2),"""")_""""
DO L
+4 SET BHLMIEN=1
SET DICOMPX("BHLMIEN")=""""_$PIECE($PIECE(%1,"""",2),"""")_""""
+5 QUIT
