INHSZ1(SCR) ; cmi/flag/maw - JSH 20 Dec 1999 09:32 Script Compiler - perform compilation 07 Oct 91 6:44 AM ; [ 02/11/2005 11:43 AM ]
;;3.01;BHL IHS Interfaces with GIS;**2,14**;JULY 1, 2001
;COPYRIGHT 1991-2000 SAIC
;
;SCR = script entry number to compile
;Main compile loop.
I '$D(^INRHS(SCR,0)) D ERROR^INHSZ0("Script not found!",0) Q 0
D K,EN,K Q X
K K SECT,DELIM,LCT,ER,INRL,WHILE,WARN,N,SET,DICOMPX,DOTLVL,CALL,WHSUB,LOOKUP,IDENT,IF,SUBDELIM,MCNT,LPARAM,REPEAT,REPEAT1,LVARS,MULT,FILE,FILE1,MODE,MNODE,OTHER,SLVL,INHSZ,FILEB,INDELIMS Q
;
EN S (FILEB,CALL,CALL(0,0),DOTLVL,LCT,ER,INRL,WARN,WHILE,GROUP,IF,LOOKUP,IDENT,DELIM,SUBDELIM,MCNT,REPEAT,REPEAT(0),REPEAT1,MULT,OTHER,SLVL)=0,(SECT,WHSUB,LPARAM,INDELIMS)="",CALL(0)=SCR,INHSZ=1
S FILE=$P(^INRHS(SCR,0),U,3) I 'FILE D ERROR^INHSZ0("File not specified for this script!",0) S X=0 Q
I '$D(^DIC(+FILE,0)) D ERROR^INHSZ0("File #"_+FILE_" does not exist!",0) S X=0 Q
S (FILE1,FILE)=FILE_^DIC(+FILE,0,"GL")
S MODE=$E($P(^INRHS(SCR,0),U,2))
D INITCOD
F D GETLINE^INHSZ0 D:'$D(LINE) CALLU Q:CALL<0 D:$D(LINE) Q:ER
. W "." Q:LINE=""
. Q:$E(LINE)=";"
. I $E($$CASECONV^UTIL(LINE),1,7)="INCLUDE" D CALL Q
. S LCT=LCT+1
. I $E(LINE)="^" S LINE=$E(LINE,2,256) D MUMPS Q
. I LINE?1.A1":" D Q
.. I SECT="END" D ERROR^INHSZ0("No other sections can follow END:",1) Q
.. S SECT(0)=SECT,SECT=$$CASECONV^UTIL($P(LINE,":"),"U") I '$$CMD(SECT,"MUMPS^DATA^TRANS^REQUIRED^LOOKUP^STORE^END") D ERROR^INHSZ0("Invalid section name.",1) Q
.. D SECTST
. I SECT="" D ERROR^INHSZ0("Invalid command.",1) Q
. I SECT="END" D WARN^INHSZ0("Line after END: ignored.",1) Q
. D @SECT
I ER W !!,"Compile aborted due to above error." S X=0 Q
I SECT'="END" D ERROR^INHSZ0("Script ended without an END:") S X=0 Q
W !!,"Compile completed with ",WARN," warnings and 0 errors."
S X=1 Q
;
CALLU ;Up one call level
S CALL=CALL-1 Q
;
CALL ;Down one call level
N CS,CSN
S CS=$$CASECONV^UTIL($$LBTB^UTIL($P(LINE," ",2,999)))
S CSN=$O(^INRHS("B",CS,0)) I 'CSN D ERROR^INHSZ0("Script '"_CS_"' not found.",1) Q
S CALL=CALL+1,CALL(CALL,0)=0,CALL(CALL)=CSN
Q
;
SECTST ;Start of a new section
I SECT(0)]"","MUMPS^DATA^TRANS^REQUIRED^LOOKUP^STORE^"[(SECT(0)_"^") D @("OUT^INHSZ"_$S(SECT(0)="DATA":2,SECT(0)="TRANS":3,SECT(0)="REQUIRED":4,SECT(0)="LOOKUP":5,SECT(0)="STORE":7,1:1))
I SECT="MUMPS"
I IF D ERROR^INHSZ0("IF not terminated before leaving "_SECT(0)_" section.",0) Q
I MULT D ERROR^INHSZ0("All MULT blocks must be terminated before leaving "_SECT(0)_" section.",0) Q
I OTHER D ERROR^INHSZ0("OTHER block must be terminated before leaving "_SECT(0)_" section.",0) Q
I DOTLVL D ERROR^INHSZ0("All Loops not terminated before leaving "_SECT(0)_" sections",0) Q
I MODE="O","TRANS^LOOKUP^STORE^"[(SECT_U) D ERROR^INHSZ0(SECT_" section not permitted in Output Mode.",1) Q
W !,SECT," section." S A=" ;Entering "_SECT_" section." D L
D @("IN^INHSZ"_$S(SECT="MUMPS":1,SECT="DATA":2,SECT="TRANS":3,SECT="REQUIRED":4,SECT="LOOKUP":5,SECT="END":6,SECT="STORE":7))
Q
;
INITCOD ;Create the initialization code
S A=" S X=""ERROR^"_ROU_""",@^%ZOSF(""TRAP"")" D L
S A=" G START" D L
S A="ERROR ;" D L
S A=" S X="""",@^%ZOSF(""TRAP"") X ^INTHOS(1,3) D ERROR^INHS($$GETERR^%ZTOS)" D L
S A=" Q 2" D L
S A="START ;Initialize variables" D L
I MODE="I" D
. S A=" K FIELD,MDESC,INDA,DIPA S (INAUDIT,INLAYGO)=0" D L
I MODE="O" D
. S A=" K ^UTILITY(""INH"",$J) S (MESSID,INA(""MESSID""))=$$MESSID^INHD" D L
.;X12 needs a number in addition to MESSID
. I $G(INSTD)="X12" S A=" S INA(""INSEQ"")=$P(MESSID,$P($G(^INRHSITE(1,0)),U,8),2)#10000000" D L
. S A=" K INUIF6 M INUIF6=INDA" D L ; selective routing - pass INDA in msg
S A=" K INREQERR,INHERR,INHERCNT,INV "
;cmi/maw - there is a possibility of changing the duz to something else
;S A=A_"D SETDT^UTDT S:'$G(DUZ) DUZ=.5,DUZ(0)=""@"",DUZ(""AG"")=""^1"",DTIME=1 S (LCT,GERR)=0,INMODE="""_MODE_""",INVS=$P(^INRHSITE(1,0),U,12),INV=$S(INVS<2:""INV"",1:""^UTILITY(""""INV"""",$J)""),(MULT,INSTERR)=0" D L ;cmi/maw orig 8/9/2001
S A=A_"D SETDT^UTDT S DUZ(0)=""@"",DUZ(""AG"")=""^1"",DTIME=1 S (LCT,GERR)=0,INMODE="""_MODE_""",INVS=$P(^INRHSITE(1,0),U,12),INV=$S(INVS<2:""INV"",1:""^UTILITY(""""INV"""",$J)""),(MULT,INSTERR)=0" D L ;cmi/maw mod 8/9/2001
S A=" S INHLDUZ=$O(^VA(200,""B"",""GIS,USER"",0)),DUZ=$S($G(INHLDUZ):INHLDUZ,1:.5)" D L ;cmi/maw added for set of duz to gis user
;Support for HL7 Set ID
S A=" S BHLMIEN="""_MESS_"""" D L ;cmi/maw added to pass Message IEN
;cmi/anch/maw added the following to execute code before message
S A=" I $G(^INTHL7M(BHLMIEN,4,1,0))]"""" X $G(^INTHL7M(BHLMIEN,4,1,0))" D L
I INSTD="X12" S A=" S INEOSM="""_$G(INEOSM)_"""" D L ;cmi/maw pass in eosm for x12
S A=" K INSETID" D L
S A=" S INSMIN=$S($P($G(^INRHSITE(1,0)),U,14):$P(^(0),U,14),1:2500)" D L
;Set up the field, component, and subcomponent separators for HL7
S A=" S (DELIM,INDELIM)=$$FIELD^INHUT(),(SUBDELIM,INSUBDEL)=$$COMP^INHUT(),INSUBCOM=$$SUBCOMP^INHUT()" D L
;If outbound message set delimeter characters to CHCS default
I MODE="O" S A=" S INDELIMS=$$FIELD^INHUT_$$COMP^INHUT_$$REP^INHUT_$$ESC^INHUT_$$SUBCOMP^INHUT" D L
Q
;
MUMPS ;A line of MUMPS code
I $D(LINE(1)) D ERROR^INHSZ0("Line of MUMPS code too long.",1) Q
;The DIM checker in IHS/VA does not allow a quit with value. The
;following strips out the quit code and checks only the user's
;lookup/store value.
;The following strips a specific instance of this from X before check
S X=LINE
I X["Q:$G(INSTERR)" S X=$P(X,"Q:$G(INSTERR) $S($G(INREQERR)>INSTERR:INREQERR,1:INSTERR) ",2)
D ^DIM I '$D(X) D ERROR^INHSZ0("Invalid MUMPS code.",1) Q
S A=" "_LINE D L
Q
;
OUT ;Check for error signaled during MUMPS section
D:MODE="I" QCHK^INHSZ0 Q
;
IN ;Code done at the start of every MUMPS section
Q
;
L ;Place a line in the routine
I DOTLVL S A=$P(A," ")_" "_$E("................",1,DOTLVL)_$P(A," ",2,999)
S INRL=INRL+1,^UTILITY("IN",$J,"R",INRL)=A,A="" Q
;
DATA ;A line from the DATA section
D DATA^INHSZ2 Q
;
TRANS ;A line from the TRANSFORM section
D TRANS^INHSZ3 Q
;
REQUIRED ;A line from the REQUIRED section
D REQUIRED^INHSZ4 Q
;
LOOKUP ;A line from the LOOKUP section
D LOOKUP^INHSZ5 Q
;
STORE ;A line from the STORE section
D STORE^INHSZ7 Q
;
CMD(%V,%L) ;Validate a command
Q (%L_U)[($$CASECONV^UTIL(%V,"U")_U)
;
DOWN(%T) ;Move down a level at current line
;%T= type of level (W=while, G=group, ""=no type)
S DOTLVL=DOTLVL+1,INDS(DOTLVL)=$G(%T)_U_INRL
Q
;
UP ;Move up one level
Q:'DOTLVL
N SL,A
S A=" Q" D L
S SL=$P(INDS(DOTLVL),U,2),INDL(SL)=INRL,INDE(INRL)=SL,DOTLVL=DOTLVL-1
Q
INHSZ1(SCR) ; cmi/flag/maw - JSH 20 Dec 1999 09:32 Script Compiler - perform compilation 07 Oct 91 6:44 AM ; [ 02/11/2005 11:43 AM ]
+1 ;;3.01;BHL IHS Interfaces with GIS;**2,14**;JULY 1, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ;SCR = script entry number to compile
+5 ;Main compile loop.
+6 IF '$DATA(^INRHS(SCR,0))
DO ERROR^INHSZ0("Script not found!",0)
QUIT 0
+7 DO K
DO EN
DO K
QUIT X
K KILL SECT,DELIM,LCT,ER,INRL,WHILE,WARN,N,SET,DICOMPX,DOTLVL,CALL,WHSUB,LOOKUP,IDENT,IF,SUBDELIM,MCNT,LPARAM,REPEAT,REPEAT1,LVARS,MULT,FILE,FILE1,MODE,MNODE,OTHER,SLVL,INHSZ,FILEB,INDELIMS
QUIT
+1 ;
EN SET (FILEB,CALL,CALL(0,0),DOTLVL,LCT,ER,INRL,WARN,WHILE,GROUP,IF,LOOKUP,IDENT,DELIM,SUBDELIM,MCNT,REPEAT,REPEAT(0),REPEAT1,MULT,OTHER,SLVL)=0
SET (SECT,WHSUB,LPARAM,INDELIMS)=""
SET CALL(0)=SCR
SET INHSZ=1
+1 SET FILE=$PIECE(^INRHS(SCR,0),U,3)
IF 'FILE
DO ERROR^INHSZ0("File not specified for this script!",0)
SET X=0
QUIT
+2 IF '$DATA(^DIC(+FILE,0))
DO ERROR^INHSZ0("File #"_+FILE_" does not exist!",0)
SET X=0
QUIT
+3 SET (FILE1,FILE)=FILE_^DIC(+FILE,0,"GL")
+4 SET MODE=$EXTRACT($PIECE(^INRHS(SCR,0),U,2))
+5 DO INITCOD
+6 FOR
DO GETLINE^INHSZ0
IF '$DATA(LINE)
DO CALLU
IF CALL<0
QUIT
IF $DATA(LINE)
Begin DoDot:1
+7 WRITE "."
IF LINE=""
QUIT
+8 IF $EXTRACT(LINE)=";"
QUIT
+9 IF $EXTRACT($$CASECONV^UTIL(LINE),1,7)="INCLUDE"
DO CALL
QUIT
+10 SET LCT=LCT+1
+11 IF $EXTRACT(LINE)="^"
SET LINE=$EXTRACT(LINE,2,256)
DO MUMPS
QUIT
+12 IF LINE?1.A1":"
Begin DoDot:2
+13 IF SECT="END"
DO ERROR^INHSZ0("No other sections can follow END:",1)
QUIT
+14 SET SECT(0)=SECT
SET SECT=$$CASECONV^UTIL($PIECE(LINE,":"),"U")
IF '$$CMD(SECT,"MUMPS^DATA^TRANS^REQUIRED^LOOKUP^STORE^END")
DO ERROR^INHSZ0("Invalid section name.",1)
QUIT
+15 DO SECTST
End DoDot:2
QUIT
+16 IF SECT=""
DO ERROR^INHSZ0("Invalid command.",1)
QUIT
+17 IF SECT="END"
DO WARN^INHSZ0("Line after END: ignored.",1)
QUIT
+18 DO @SECT
End DoDot:1
IF ER
QUIT
+19 IF ER
WRITE !!,"Compile aborted due to above error."
SET X=0
QUIT
+20 IF SECT'="END"
DO ERROR^INHSZ0("Script ended without an END:")
SET X=0
QUIT
+21 WRITE !!,"Compile completed with ",WARN," warnings and 0 errors."
+22 SET X=1
QUIT
+23 ;
CALLU ;Up one call level
+1 SET CALL=CALL-1
QUIT
+2 ;
CALL ;Down one call level
+1 NEW CS,CSN
+2 SET CS=$$CASECONV^UTIL($$LBTB^UTIL($PIECE(LINE," ",2,999)))
+3 SET CSN=$ORDER(^INRHS("B",CS,0))
IF 'CSN
DO ERROR^INHSZ0("Script '"_CS_"' not found.",1)
QUIT
+4 SET CALL=CALL+1
SET CALL(CALL,0)=0
SET CALL(CALL)=CSN
+5 QUIT
+6 ;
SECTST ;Start of a new section
+1 IF SECT(0)]""
IF "MUMPS^DATA^TRANS^REQUIRED^LOOKUP^STORE^"[(SECT(0)_"^")
DO @("OUT^INHSZ"_$SELECT(SECT(0)="DATA":2,SECT(0)="TRANS":3,SECT(0)="REQUIRED":4,SECT(0)="LOOKUP":5,SECT(0)="STORE":7,1:1))
+2 IF SECT="MUMPS"
+3 IF IF
DO ERROR^INHSZ0("IF not terminated before leaving "_SECT(0)_" section.",0)
QUIT
+4 IF MULT
DO ERROR^INHSZ0("All MULT blocks must be terminated before leaving "_SECT(0)_" section.",0)
QUIT
+5 IF OTHER
DO ERROR^INHSZ0("OTHER block must be terminated before leaving "_SECT(0)_" section.",0)
QUIT
+6 IF DOTLVL
DO ERROR^INHSZ0("All Loops not terminated before leaving "_SECT(0)_" sections",0)
QUIT
+7 IF MODE="O"
IF "TRANS^LOOKUP^STORE^"[(SECT_U)
DO ERROR^INHSZ0(SECT_" section not permitted in Output Mode.",1)
QUIT
+8 WRITE !,SECT," section."
SET A=" ;Entering "_SECT_" section."
DO L
+9 DO @("IN^INHSZ"_$SELECT(SECT="MUMPS":1,SECT="DATA":2,SECT="TRANS":3,SECT="REQUIRED":4,SECT="LOOKUP":5,SECT="END":6,SECT="STORE":7))
+10 QUIT
+11 ;
INITCOD ;Create the initialization code
+1 SET A=" S X=""ERROR^"_ROU_""",@^%ZOSF(""TRAP"")"
DO L
+2 SET A=" G START"
DO L
+3 SET A="ERROR ;"
DO L
+4 SET A=" S X="""",@^%ZOSF(""TRAP"") X ^INTHOS(1,3) D ERROR^INHS($$GETERR^%ZTOS)"
DO L
+5 SET A=" Q 2"
DO L
+6 SET A="START ;Initialize variables"
DO L
+7 IF MODE="I"
Begin DoDot:1
+8 SET A=" K FIELD,MDESC,INDA,DIPA S (INAUDIT,INLAYGO)=0"
DO L
End DoDot:1
+9 IF MODE="O"
Begin DoDot:1
+10 SET A=" K ^UTILITY(""INH"",$J) S (MESSID,INA(""MESSID""))=$$MESSID^INHD"
DO L
+11 ;X12 needs a number in addition to MESSID
+12 IF $GET(INSTD)="X12"
SET A=" S INA(""INSEQ"")=$P(MESSID,$P($G(^INRHSITE(1,0)),U,8),2)#10000000"
DO L
+13 ; selective routing - pass INDA in msg
SET A=" K INUIF6 M INUIF6=INDA"
DO L
End DoDot:1
+14 SET A=" K INREQERR,INHERR,INHERCNT,INV "
+15 ;cmi/maw - there is a possibility of changing the duz to something else
+16 ;S A=A_"D SETDT^UTDT S:'$G(DUZ) DUZ=.5,DUZ(0)=""@"",DUZ(""AG"")=""^1"",DTIME=1 S (LCT,GERR)=0,INMODE="""_MODE_""",INVS=$P(^INRHSITE(1,0),U,12),INV=$S(INVS<2:""INV"",1:""^UTILITY(""""INV"""",$J)""),(MULT,INSTERR)=0" D L ;cmi/maw orig 8/9/2001
+17 ;cmi/maw mod 8/9/2001
SET A=A_"D SETDT^UTDT S DUZ(0)=""@"",DUZ(""AG"")=""^1"",DTIME=1 S (LCT,GERR)=0,INMODE="""_MODE_""",INVS=$P(^INRHSITE(1,0),U,12),INV=$S(INVS<2:""INV"",1:""^UTILITY(""""INV"""",$J)""),(MULT,INSTERR)=0"
DO L
+18 ;cmi/maw added for set of duz to gis user
SET A=" S INHLDUZ=$O(^VA(200,""B"",""GIS,USER"",0)),DUZ=$S($G(INHLDUZ):INHLDUZ,1:.5)"
DO L
+19 ;Support for HL7 Set ID
+20 ;cmi/maw added to pass Message IEN
SET A=" S BHLMIEN="""_MESS_""""
DO L
+21 ;cmi/anch/maw added the following to execute code before message
+22 SET A=" I $G(^INTHL7M(BHLMIEN,4,1,0))]"""" X $G(^INTHL7M(BHLMIEN,4,1,0))"
DO L
+23 ;cmi/maw pass in eosm for x12
IF INSTD="X12"
SET A=" S INEOSM="""_$GET(INEOSM)_""""
DO L
+24 SET A=" K INSETID"
DO L
+25 SET A=" S INSMIN=$S($P($G(^INRHSITE(1,0)),U,14):$P(^(0),U,14),1:2500)"
DO L
+26 ;Set up the field, component, and subcomponent separators for HL7
+27 SET A=" S (DELIM,INDELIM)=$$FIELD^INHUT(),(SUBDELIM,INSUBDEL)=$$COMP^INHUT(),INSUBCOM=$$SUBCOMP^INHUT()"
DO L
+28 ;If outbound message set delimeter characters to CHCS default
+29 IF MODE="O"
SET A=" S INDELIMS=$$FIELD^INHUT_$$COMP^INHUT_$$REP^INHUT_$$ESC^INHUT_$$SUBCOMP^INHUT"
DO L
+30 QUIT
+31 ;
MUMPS ;A line of MUMPS code
+1 IF $DATA(LINE(1))
DO ERROR^INHSZ0("Line of MUMPS code too long.",1)
QUIT
+2 ;The DIM checker in IHS/VA does not allow a quit with value. The
+3 ;following strips out the quit code and checks only the user's
+4 ;lookup/store value.
+5 ;The following strips a specific instance of this from X before check
+6 SET X=LINE
+7 IF X["Q:$G(INSTERR)"
SET X=$PIECE(X,"Q:$G(INSTERR) $S($G(INREQERR)>INSTERR:INREQERR,1:INSTERR) ",2)
+8 DO ^DIM
IF '$DATA(X)
DO ERROR^INHSZ0("Invalid MUMPS code.",1)
QUIT
+9 SET A=" "_LINE
DO L
+10 QUIT
+11 ;
OUT ;Check for error signaled during MUMPS section
+1 IF MODE="I"
DO QCHK^INHSZ0
QUIT
+2 ;
IN ;Code done at the start of every MUMPS section
+1 QUIT
+2 ;
L ;Place a line in the routine
+1 IF DOTLVL
SET A=$PIECE(A," ")_" "_$EXTRACT("................",1,DOTLVL)_$PIECE(A," ",2,999)
+2 SET INRL=INRL+1
SET ^UTILITY("IN",$JOB,"R",INRL)=A
SET A=""
QUIT
+3 ;
DATA ;A line from the DATA section
+1 DO DATA^INHSZ2
QUIT
+2 ;
TRANS ;A line from the TRANSFORM section
+1 DO TRANS^INHSZ3
QUIT
+2 ;
REQUIRED ;A line from the REQUIRED section
+1 DO REQUIRED^INHSZ4
QUIT
+2 ;
LOOKUP ;A line from the LOOKUP section
+1 DO LOOKUP^INHSZ5
QUIT
+2 ;
STORE ;A line from the STORE section
+1 DO STORE^INHSZ7
QUIT
+2 ;
CMD(%V,%L) ;Validate a command
+1 QUIT (%L_U)[($$CASECONV^UTIL(%V,"U")_U)
+2 ;
DOWN(%T) ;Move down a level at current line
+1 ;%T= type of level (W=while, G=group, ""=no type)
+2 SET DOTLVL=DOTLVL+1
SET INDS(DOTLVL)=$GET(%T)_U_INRL
+3 QUIT
+4 ;
UP ;Move up one level
+1 IF 'DOTLVL
QUIT
+2 NEW SL,A
+3 SET A=" Q"
DO L
+4 SET SL=$PIECE(INDS(DOTLVL),U,2)
SET INDL(SL)=INRL
SET INDE(INRL)=SL
SET DOTLVL=DOTLVL-1
+5 QUIT
