INHSZ2 ;JSH,DGH; 15 Oct 1999 15:50 ;Script compiler DATA section handler ; 11 Nov 91 6:42 AM
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;CHCS TOOLS_460; GEN 4; 4-SEP-1997
;COPYRIGHT 1988, 1989, 1990 SAIC
;
L G L^INHSZ1
;
IN ;Enter code
Q
;
OUT ;Exit code
S A=" D:'INVS MC^INHS" D L
Q
;
DATA ;Handle lines in DATA section
;Enter here with LINE array set to current line
;Get command
N COMM
S COMM=$P($TR(LINE,"=("," ")," ") I '$$CMD^INHSZ1(COMM,"ERROR^SUBDELIM^DELIM^SET^LINE^WHILE^ENDWHILE^TEMPLATE^GROUP^ENDGROUP^IF^ENDIF^SCREEN^BHLMIEN") D ERROR^INHSZ0("Invalid command in DATA section.",1) Q ;cmi/maw added BHLMIEN
S X=$$CASECONV^UTIL(COMM,"U") G:$T(@X)]"" @X
G @(X_"^INHSZ21")
;
TEMPLATE ;Invoke a print template to generate lines
G TEMPLATE^INHSZ20
;
LINE ;LINE statement
N %1,I,%2,V,F,POS,LC,OUT,P,%0,PM,W
S %1=$$LB^UTIL($P(LINE," ",2,999)),LC=0,OUT=0,%0=$P(LINE," ")
I INSTD="NC",%1["NCID" D LINENC^INHSZ23 Q
I MODE="O" Q:'$$SYNTAX^INHSZ0(%1,"1.ANP")
I %0["(",MODE="O" D ERROR^INHSZ0("Pattern check only allowed in INPUT mode.",1) Q
I %0["(" Q:'$$SYNTAX^INHSZ0($P(%0,"LINE",2),"1""(""1.ANP1"")""")
S PM=$P($P(%0,"(",2),")")
S A=" D:'INVS MC^INHS" D L
G LINEO^INHSZ20:MODE="O"
LINEI ;Input mode
S A=" D GET^INHOU(UIF,0) S LINE=$G(LINE),DO="_'GROUP D L S POS=1
; Initial lookup/processing logic for segment. PM is null at this point.
I PM]"" D
. I INSTD="NC",$G(INIDF) D Q
.. S WHPRE=""""""_$TR(PM,"*","")_""""","
.. S A=" I 'MATCH,$$CHKNC^INHUT11(.LINE,"_INIDF_","""_INIDV_""") S DO=1,MATCH=1" D L
.. S A=" E S LCT=LCT-CNT,DO=0" D L
. S A=" I "_$S(GROUP:"'MATCH,",1:"")_"LINE?"_$$PMTO(PM)_" S DO=1"_$S(GROUP:",MATCH=1",1:"") D L
. S A=" E S LCT=LCT-CNT,DO=0" D L
;Loop through all fields in LINE and create extraction logic for each
S I=1,P=0 F D Q:ER!OUT S I=I+1,P=P+1
. ;Determine type of field
. I I=$L(%1,"^"),$O(LINE(LC)) S LC=LC+1,%1=$P(%1,"^",I)_LINE(LC),I=1
. S %2=$P(%1,"^",I),V=$$LBTB^UTIL($P(%2,"=")),F=$$LBTB^UTIL($P(%2,"=",2)) K V(0)
. I I>$L(%1,"^")!(I=$L(%1,"^")&(%2="")) S OUT=1 Q
. Q:V="" S:F="" F="V"
. I INSTD="NC"&('$G(INIDF)!'$L($G(INIDV))) D ERROR^INHSZ0("NCPDP segment "_$G(PM)_" must have an ID FIELD and an ID VALUE") Q
. I '$$FORMAT(F) D ERROR^INHSZ0("Illegal format: '"_F_"'",1) Q
. I V'["," D Q:ER
.. ;I $D(DICOMPX(V)) D WARN^INHSZ0("Duplicate Variable Usage: '"_V_"'",1)
.. S DICOMPX(V)="$G(@INV@("""_V_"""))" S:WHILE LVARS(V)=WHILE
. I V["," S V(0)=V D Q:V=""
.. F K=$L(V(0),","):-1:0 Q:'K Q:$$LBTB^UTIL($P(V(0),",",K))]""
.. S V="" S:K V=$$LBTB^UTIL($P(V(0),",",K))
. ;--Extraction logic for variable-length fields.
. I $E(F)="V" D Q:ER
.. I 'DELIM D ERROR^INHSZ0("Delimiter not defined. Cannot interpret a variable field.",1) Q
..;NCPDP variable fields are at end of LINE and must be recognized by last two characters of field id--but stored with full identifier.
.. I $G(INSTD)="NC" S A=" I DO F I=2:1 S X=$$PIECE^INHU(.LINE,DELIM,I) Q:'$L(X) S:$E(X,1,2)="""_$E(V,$L(V)-1,$L(V))_""" @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,3,$L(X))" D L Q
.. I $E(V,1,3)'="MSH" S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$$PIECE^INHU(.LINE,DELIM,"_(P+1)_")" D L Q
.. ; MSH line 1 set to delimeter
.. I $E(V,1,3)="MSH",P=1 S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E($G(LINE),4)" D L Q
.. ; MSH line everything else
.. S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$$PIECE^INHU(.LINE,DELIM,"_P_")" D L Q
. ;--Extraction logic for fixed-length fields.
. I $E(F)="F" D
.. ;--Fixed length logic is not currently specific to data types
.. ;--In the future, it may be necessary to handle numeric fields
.. ;--differently than alpha because the logic that strips pad
.. ;--characters (variable PD) leaves 0000 equal to "", which
.. ;--fails the required field check downstream.
.. S PC=$P($P(F,"(",2),")")
.. S A=" S:DO X=$$EXTRACT^INHU(.LINE,"_POS_","_(POS+$P(F,")",2)-1)_")",POS=POS+$P(F,")",2) D L
.. ;For NCPCP, variable WHPRE is used to fully subscript the INV
.. ;array into the nest. This may also work for X12. The NCPDP
.. ;logic would work for HL7 if WHPRE is set to null, but needs
.. ;extensive testing before replacing HL7 logic.
.. I $G(INSTD)="NC" D Q
... I PC="" S A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=X" D L Q
... S:"Rr"[$E(F,2) A=" I DO F I=1:1:$L(X) " S:"Ll"[$E(F,2) A=" I DO F I=$L(X):-1:1 " S A=A_"Q:$E(X,I)'="""_PC_"""" D L
... I "Ll"[$E(F,2) S A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,1,$S($E(X,I)'="""_PC_""":I,1:0))" D L
... I "Rr"[$E(F,2) S A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,$S($E(X,I)'="""_PC_""":I,1:I+1),$L(X))" D L
...;----end of NCPDP logic
.. I PC="" S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=X" D L Q
.. S:"Rr"[$E(F,2) A=" I DO F I=1:1:$L(X) " S:"Ll"[$E(F,2) A=" I DO F I=$L(X):-1:1 " S A=A_"Q:$E(X,I)'="""_PC_"""" D L
.. I "Ll"[$E(F,2) S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E(X,1,$S($E(X,I)'="""_PC_""":I,1:0))" D L
.. I "Rr"[$E(F,2) S A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E(X,$S($E(X,I)'="""_PC_""":I,1:I+1),$L(X))" D L
. I $D(V(0)) D
.. I 'SUBDELIM D ERROR^INHSZ0("Sub-delimiter not defined.",1) Q
.. N I
.. F I=1:1:$L(V(0),",") S V1=$$LBTB^UTIL($P(V(0),",",I)) Q:V1="" D Q:ER
... ;I $D(DICOMPX(V1)) D WARN^INHSZ0("Duplicate Variable Usage: '"_V1_"'",1)
... S A=" S:DO @(""@INV@("""""_V1_""""""_WHSUB_")"")=$P(@(""@INV@("""""_V_""""""_WHSUB_")""),SUBDELIM,"_I_")" D L S DICOMPX(V1)="$G(@INV@("""_V1_"""))" S:WHILE LVARS(V1)=WHILE
I GROUP S A=" Q:MATCH" D L
K INIDF,INIDV
Q
;
FORMAT(%F) ;Check format string (Modified 6/1/95 to support M and V)
;%F = string to verify Function returns 1 if OK, 0 otherwise
;Allowable formats are F=fixed, V=Variable, M=Minimum/Maximum
N ER,MIN
I "FVfvMm"'[$E(%F) Q 0
;NCPDP format for V allows more than single character
I "Vv"[$E(%F),$G(INSTD)="NC" Q 1
S ER=0 I "Vv"[$E(%F) Q $S($L(%F)>1:0,1:1)
I %F["," S MIN=$P(%F,",",2),%F=$P(%F,",")
I $E(%F,2,999)'?1A1"(".1ANP1")"1.N!("LRlr"'[$E(%F,2)) Q 0
I $D(MIN),MIN'?.N Q 0
Q 1
;
;
PMTO(%P) ;Convert Script Pattern string to MUMPS Pattern Match equivalent
;%P = script pattern
;Function returns MUMPS equivalent or "" if an error occured
I %P="*" Q "1.E"
N PAT,POS,C
S PAT="" F I=1:1:$L(%P) S C=$E(%P,I) D
. ;Following pattern matches changed from ANP to ANPC to meet
. ;PWS need to have control characters in ZIL segment. This may not
. ;be a permanent solution
. I C="*" S PAT=PAT_".ANPC" Q
. I C="?" S PAT=PAT_"1ANPC" Q
. S PAT=PAT_"1"""_C_"""" Q
Q PAT
;
SCREEN G SCREEN^INHSZ20
INHSZ2 ;JSH,DGH; 15 Oct 1999 15:50 ;Script compiler DATA 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 ;CHCS TOOLS_460; GEN 4; 4-SEP-1997
+4 ;COPYRIGHT 1988, 1989, 1990 SAIC
+5 ;
L GOTO L^INHSZ1
+1 ;
IN ;Enter code
+1 QUIT
+2 ;
OUT ;Exit code
+1 SET A=" D:'INVS MC^INHS"
DO L
+2 QUIT
+3 ;
DATA ;Handle lines in DATA section
+1 ;Enter here with LINE array set to current line
+2 ;Get command
+3 NEW COMM
+4 ;cmi/maw added BHLMIEN
SET COMM=$PIECE($TRANSLATE(LINE,"=("," ")," ")
IF '$$CMD^INHSZ1(COMM,"ERROR^SUBDELIM^DELIM^SET^LINE^WHILE^ENDWHILE^TEMPLATE^GROUP^ENDGROUP^IF^ENDIF^SCREEN^BHLMIEN")
DO ERROR^INHSZ0("Invalid command in DATA section.",1)
QUIT
+5 SET X=$$CASECONV^UTIL(COMM,"U")
IF $TEXT(@X)]""
GOTO @X
+6 GOTO @(X_"^INHSZ21")
+7 ;
TEMPLATE ;Invoke a print template to generate lines
+1 GOTO TEMPLATE^INHSZ20
+2 ;
LINE ;LINE statement
+1 NEW %1,I,%2,V,F,POS,LC,OUT,P,%0,PM,W
+2 SET %1=$$LB^UTIL($PIECE(LINE," ",2,999))
SET LC=0
SET OUT=0
SET %0=$PIECE(LINE," ")
+3 IF INSTD="NC"
IF %1["NCID"
DO LINENC^INHSZ23
QUIT
+4 IF MODE="O"
IF '$$SYNTAX^INHSZ0(%1,"1.ANP")
QUIT
+5 IF %0["("
IF MODE="O"
DO ERROR^INHSZ0("Pattern check only allowed in INPUT mode.",1)
QUIT
+6 IF %0["("
IF '$$SYNTAX^INHSZ0($PIECE(%0,"LINE",2),"1""(""1.ANP1"")""")
QUIT
+7 SET PM=$PIECE($PIECE(%0,"(",2),")")
+8 SET A=" D:'INVS MC^INHS"
DO L
+9 IF MODE="O"
GOTO LINEO^INHSZ20
LINEI ;Input mode
+1 SET A=" D GET^INHOU(UIF,0) S LINE=$G(LINE),DO="_'GROUP
DO L
SET POS=1
+2 ; Initial lookup/processing logic for segment. PM is null at this point.
+3 IF PM]""
Begin DoDot:1
+4 IF INSTD="NC"
IF $GET(INIDF)
Begin DoDot:2
+5 SET WHPRE=""""""_$TRANSLATE(PM,"*","")_""""","
+6 SET A=" I 'MATCH,$$CHKNC^INHUT11(.LINE,"_INIDF_","""_INIDV_""") S DO=1,MATCH=1"
DO L
+7 SET A=" E S LCT=LCT-CNT,DO=0"
DO L
End DoDot:2
QUIT
+8 SET A=" I "_$SELECT(GROUP:"'MATCH,",1:"")_"LINE?"_$$PMTO(PM)_" S DO=1"_$SELECT(GROUP:",MATCH=1",1:"")
DO L
+9 SET A=" E S LCT=LCT-CNT,DO=0"
DO L
End DoDot:1
+10 ;Loop through all fields in LINE and create extraction logic for each
+11 SET I=1
SET P=0
FOR
Begin DoDot:1
+12 ;Determine type of field
+13 IF I=$LENGTH(%1,"^")
IF $ORDER(LINE(LC))
SET LC=LC+1
SET %1=$PIECE(%1,"^",I)_LINE(LC)
SET I=1
+14 SET %2=$PIECE(%1,"^",I)
SET V=$$LBTB^UTIL($PIECE(%2,"="))
SET F=$$LBTB^UTIL($PIECE(%2,"=",2))
KILL V(0)
+15 IF I>$LENGTH(%1,"^")!(I=$LENGTH(%1,"^")&(%2=""))
SET OUT=1
QUIT
+16 IF V=""
QUIT
IF F=""
SET F="V"
+17 IF INSTD="NC"&('$GET(INIDF)!'$LENGTH($GET(INIDV)))
DO ERROR^INHSZ0("NCPDP segment "_$GET(PM)_" must have an ID FIELD and an ID VALUE")
QUIT
+18 IF '$$FORMAT(F)
DO ERROR^INHSZ0("Illegal format: '"_F_"'",1)
QUIT
+19 IF V'[","
Begin DoDot:2
+20 ;I $D(DICOMPX(V)) D WARN^INHSZ0("Duplicate Variable Usage: '"_V_"'",1)
+21 SET DICOMPX(V)="$G(@INV@("""_V_"""))"
IF WHILE
SET LVARS(V)=WHILE
End DoDot:2
IF ER
QUIT
+22 IF V[","
SET V(0)=V
Begin DoDot:2
+23 FOR K=$LENGTH(V(0),","):-1:0
IF 'K
QUIT
IF $$LBTB^UTIL($PIECE(V(0),",",K))]""
QUIT
+24 SET V=""
IF K
SET V=$$LBTB^UTIL($PIECE(V(0),",",K))
End DoDot:2
IF V=""
QUIT
+25 ;--Extraction logic for variable-length fields.
+26 IF $EXTRACT(F)="V"
Begin DoDot:2
+27 IF 'DELIM
DO ERROR^INHSZ0("Delimiter not defined. Cannot interpret a variable field.",1)
QUIT
+28 ;NCPDP variable fields are at end of LINE and must be recognized by last two characters of field id--but stored with full identifier.
+29 IF $GET(INSTD)="NC"
SET A=" I DO F I=2:1 S X=$$PIECE^INHU(.L">LINE,DEL">LIM,I) Q:'$L">L(X) S:$E(X,1,2)="""_$EXTRACT(V,$L">LENGTH(V)-1,$L">LENGTH(V))_""" @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,3,$L">L(X))"
DO L
QUIT
+30 IF $EXTRACT(V,1,3)'="MSH"
SET A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$$PIECE^INHU(.LINE,DELIM,"_(P+1)_")"
DO L
QUIT
+31 ; MSH line 1 set to delimeter
+32 IF $EXTRACT(V,1,3)="MSH"
IF P=1
SET A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E($G(LINE),4)"
DO L
QUIT
+33 ; MSH line everything else
+34 SET A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$$PIECE^INHU(.LINE,DELIM,"_P_")"
DO L
QUIT
End DoDot:2
IF ER
QUIT
+35 ;--Extraction logic for fixed-length fields.
+36 IF $EXTRACT(F)="F"
Begin DoDot:2
+37 ;--Fixed length logic is not currently specific to data types
+38 ;--In the future, it may be necessary to handle numeric fields
+39 ;--differently than alpha because the logic that strips pad
+40 ;--characters (variable PD) leaves 0000 equal to "", which
+41 ;--fails the required field check downstream.
+42 SET PC=$PIECE($PIECE(F,"(",2),")")
+43 SET A=" S:DO X=$$EXTRACT^INHU(.LINE,"_POS_","_(POS+$PIECE(F,")",2)-1)_")"
SET POS=POS+$PIECE(F,")",2)
DO L
+44 ;For NCPCP, variable WHPRE is used to fully subscript the INV
+45 ;array into the nest. This may also work for X12. The NCPDP
+46 ;logic would work for HL7 if WHPRE is set to null, but needs
+47 ;extensive testing before replacing HL7 logic.
+48 IF $GET(INSTD)="NC"
Begin DoDot:3
+49 IF PC=""
SET A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=X"
DO L
QUIT
+50 IF "Rr"[$EXTRACT(F,2)
SET A=" I DO F I=1:1:$L(X) "
IF "Ll"[$EXTRACT(F,2)
SET A=" I DO F I=$L(X):-1:1 "
SET A=A_"Q:$E(X,I)'="""_PC_""""
DO L
+51 IF "Ll"[$EXTRACT(F,2)
SET A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,1,$S($E(X,I)'="""_PC_""":I,1:0))"
DO L
+52 IF "Rr"[$EXTRACT(F,2)
SET A=" S:DO @(""@INV@("_WHPRE_""""""_V_""""""_WHSUB_")"")=$E(X,$S($E(X,I)'="""_PC_""":I,1:I+1),$L(X))"
DO L
+53 ;----end of NCPDP logic
End DoDot:3
QUIT
+54 IF PC=""
SET A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=X"
DO L
QUIT
+55 IF "Rr"[$EXTRACT(F,2)
SET A=" I DO F I=1:1:$L(X) "
IF "Ll"[$EXTRACT(F,2)
SET A=" I DO F I=$L(X):-1:1 "
SET A=A_"Q:$E(X,I)'="""_PC_""""
DO L
+56 IF "Ll"[$EXTRACT(F,2)
SET A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E(X,1,$S($E(X,I)'="""_PC_""":I,1:0))"
DO L
+57 IF "Rr"[$EXTRACT(F,2)
SET A=" S:DO @(""@INV@("""""_V_""""""_WHSUB_")"")=$E(X,$S($E(X,I)'="""_PC_""":I,1:I+1),$L(X))"
DO L
End DoDot:2
+58 IF $DATA(V(0))
Begin DoDot:2
+59 IF 'SUBDELIM
DO ERROR^INHSZ0("Sub-delimiter not defined.",1)
QUIT
+60 NEW I
+61 FOR I=1:1:$LENGTH(V(0),",")
SET V1=$$LBTB^UTIL($PIECE(V(0),",",I))
IF V1=""
QUIT
Begin DoDot:3
+62 ;I $D(DICOMPX(V1)) D WARN^INHSZ0("Duplicate Variable Usage: '"_V1_"'",1)
+63 SET A=" S:DO @(""@INV@("""""_V1_""""""_WHSUB_")"")=$P(@(""@INV@("""""_V_""""""_WHSUB_")""),SUBDELIM,"_I_")"
DO L
SET DICOMPX(V1)="$G(@INV@("""_V1_"""))"
IF WHILE
SET LVARS(V1)=WHILE
End DoDot:3
IF ER
QUIT
End DoDot:2
End DoDot:1
IF ER!OUT
QUIT
SET I=I+1
SET P=P+1
+64 IF GROUP
SET A=" Q:MATCH"
DO L
+65 KILL INIDF,INIDV
+66 QUIT
+67 ;
FORMAT(%F) ;Check format string (Modified 6/1/95 to support M and V)
+1 ;%F = string to verify Function returns 1 if OK, 0 otherwise
+2 ;Allowable formats are F=fixed, V=Variable, M=Minimum/Maximum
+3 NEW ER,MIN
+4 IF "FVfvMm"'[$EXTRACT(%F)
QUIT 0
+5 ;NCPDP format for V allows more than single character
+6 IF "Vv"[$EXTRACT(%F)
IF $GET(INSTD)="NC"
QUIT 1
+7 SET ER=0
IF "Vv"[$EXTRACT(%F)
QUIT $SELECT($LENGTH(%F)>1:0,1:1)
+8 IF %F[","
SET MIN=$PIECE(%F,",",2)
SET %F=$PIECE(%F,",")
+9 IF $EXTRACT(%F,2,999)'?1A1"(".1ANP1")"1.N!("LRlr"'[$EXTRACT(%F,2))
QUIT 0
+10 IF $DATA(MIN)
IF MIN'?.N
QUIT 0
+11 QUIT 1
+12 ;
+13 ;
PMTO(%P) ;Convert Script Pattern string to MUMPS Pattern Match equivalent
+1 ;%P = script pattern
+2 ;Function returns MUMPS equivalent or "" if an error occured
+3 IF %P="*"
QUIT "1.E"
+4 NEW PAT,POS,C
+5 SET PAT=""
FOR I=1:1:$LENGTH(%P)
SET C=$EXTRACT(%P,I)
Begin DoDot:1
+6 ;Following pattern matches changed from ANP to ANPC to meet
+7 ;PWS need to have control characters in ZIL segment. This may not
+8 ;be a permanent solution
+9 IF C="*"
SET PAT=PAT_".ANPC"
QUIT
+10 IF C="?"
SET PAT=PAT_"1ANPC"
QUIT
+11 SET PAT=PAT_"1"""_C_""""
QUIT
End DoDot:1
+12 QUIT PAT
+13 ;
SCREEN GOTO SCREEN^INHSZ20
