Routine: INHSGZ20

INHSGZ20 ;JSH,DGH; 20 Dec 1999 09:29 ;INHSGZ2 Inbound script cont'd

 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 ;COPYRIGHT 1991-2000 SAIC

 ;CHCS TOOLS_460; GEN 5; 17-JUL-1997

 ;COPYRIGHT 1988, 1989, 1990 SAIC

L(%L,%C) ;Place a line in the global

 G L1^INHSGZ2

FIELD ;Handle a field

 I $O(^INTHL7F(FIELD,10,0)) D  G:INSTD'="NC" SUB

 .I INSTD="NC" D WARN^INHSGZ2("Sub-fields not supported for NCPDP. Ignoring.")

 S (LVAR,SVAR)=$P(SEG(0),U,2)_INF

FD1 ;one field

 W "." S FIELD(0)=^INTHL7F(FIELD,0),DTY=+$P(FIELD(0),U,2),DTY(0)=$G(^INTHL7FT(DTY,0))

 I 'DTY D ERROR^INHSGZ2("Field '"_$P(FIELD(0),U)_"' does not have a Data Type.") Q

 ;--Add support for fixed and min/max fields - dgh

 ;Determine if field length is Variable, Fixed or Min/Max.

 N LENTYP,MIN,PADC,PADP,DLM,FID,LEN

 S LENTYP=$P(FIELD(0),U,7),FID=$P(FIELD(0),U,14),LEN=$P(FIELD(0),U,3)

 ;NCPDP formats will identify fields by id instead of position

 ;so SVAR is replaced by FID. (Subfields not supported for fixed)

 I $G(INSTD)="NC" S (LVAR,SVAR)=FID I '$L(FID) D ERROR^INHSGZ2("Field '"_$P(FIELD(0),U)_" requires an ID.") Q

 .S:LENTYP="" LENTYP="V"

 .;Variable field length is the default

 .I LENTYP="V" D  Q

 ..Q:$G(INSTD)'="NC"

 ..;If interface standard is NCPDP, set field identifier in FLEN array

 ..;NOTE, MINMAX FORMAT WAS DONE FOR OUTGOING, NOT YET SUPPORTING INCOM.

 ..I '$L(FID) D ERROR^INHSGZ2("Field '"_$P(FIELD(0),U)_"' does not have a field identifier.") Q

 ..S FLEN(INF)="V("_FID_")"

 .S MIN=+$P(FIELD(0),U,8),PADC=$P(FIELD(0),U,9),PADP=$P(FIELD(0),U,10)

 .;Indicate Delimiter - LD (Some fixed formats use delims, others no)

 .S DLM=$P(FIELD(0),U,13)

 .;Set NCPDP defaults

 .I $G(INSTD)="NC" D  Q

 ..S PADP=$S($L(PADP):PADP,$P(DTY(0),U,2)="NM":"R",$P(DTY(0),U,2)="DL":"R",1:"L")

 ..S PADC=$S($L(PADC):PADC,$P(DTY(0),U,2)="NM":0,$P(DTY(0),U,2)="DL":0,1:" ")

 .;Otherwise default pad position is right/justify left

 .S:PADP="" PADP="L" S:PADC="" PADC=" "

 .;Inbound parsing of Min/Max will be identical to Variable

 .I LENTYP="M" S LENTYP="V"

 ;Reset LVAR to include fixed format information (not yet min/max)

 I $G(LENTYP)'="V" S LVAR=LVAR_"="_LENTYP_PADP_"("_PADC_")"_LEN

;--

 I $L($TR($P($G(^INTHL7F(FIELD,2)),U,1,4),"^")) S A="^S INTHL7F2="""_$G(^INTHL7F(FIELD,2))_"""" D L(.TRANS,1)

 F J=1:1:(INF-CP) S CL=CL_"^"

 S CP=INF,CL=CL_LVAR I $L(CL)>220 S A=CL D L(.DATA,0) S CL=""

 ; Do the escape conversion first if conversion flag exists

 S GL=""

 I $P($G(^INTHL7F(FIELD,2)),U,4),$G(^INTHL7FT(DTY,4))]"" S GL="^INTHL7FT("_DTY_",4)"

 ;;Do the input override

 I $G(^INTHL7F(FIELD,4))]"" S GL=GL_"^INTHL7F("_FIELD_",4)"

 ;Do the input transform if no input override

 I $G(^INTHL7F(FIELD,4))="",$G(^INTHL7FT(DTY,2))]"" S GL=GL_"^INTHL7FT("_DTY_",2)"

 ;For NCPDP, transforms and required field checks need full subscripts

 I $G(INSTD)="NC" S SVAR=$P(SEG(0),U,2)_","_SVAR

 I GL]"" S A=SVAR_$E("$",$P(SEG(1),U,6))_"$^"_$$LB^UTIL(@GL) D L(.TRANS,1)

 S MAP=$G(^INTHL7F(FIELD,50)) I MAP,$G(^("I"))=""  D:'$D(^INVD(4090.2,MAP))  Q:ERR  S A=SVAR_$E("$",$P(SEG(1),U,6))_"$^I X]"""" S X=$$MAP^INHVA2("""_$P(^INVD(4090.2,MAP,0),U)_""",X,0)"_$S($G(^INTHL7FT(DTY,50))]"":" "_^(50),1:"") D L(.TRANS,1)

 . D ERROR^INHSGZ2("Map function for field: "_$P(FIELD(0),U)_" has broken pointer.")

 I $G(^INTHL7F(FIELD,"I"))]"" S A=SVAR_"$^"_^("I") D L(.TRANS,1)

 ;Kill 2 node local if exists

 I $L($TR($P($G(^INTHL7F(FIELD,2)),U,1,4),"^")) S A="^K INTHL7F2" D L(.TRANS,1)

 I 'NOLS D PROC^INHSGZ21 Q:ERR

 D:REQ

 . I 'REPEAT S A=SVAR_$S('$P(MESS(1),U,9):"^"_$P(SEG(0),U,2)_1_"^D KILL^INHVA1("""_$P(SEG(0),U,2)_""","""_$P(FIELD(0),U)_""")",1:" ;"_$P(FIELD(0),U)) D L(.REQUIRED,1) Q

 . S REPEAT("REQ",SVAR)=$P(FIELD(0),U)

SUB ;Handle a field with subfields

 ;Subfields not supported for NCPDP

 I INSTD="NC" D WARN^INHSGZ2("Sub-fields not supported for NCPDP. Ignoring.") Q

 N I,F,I0

 S F=FIELD,(I0,I)=0 F  S I0=$O(^INTHL7F(F,10,"AS",I0)) Q:'I0  S I=I+1,Y=$G(^INTHL7F(F,10,+$O(^(I0,0)),0)),FIELD=+Y I FIELD,$D(^INTHL7F(FIELD,0)) D

 . S FIELD(0)=^INTHL7F(FIELD,0),(LVAR,SVAR)=$P(SEG(0),U,2)_INF_"."_I

 . S REQ=$P(Y,U,3),UFL=$P(Y,U,4) D FD1

 . S:$O(^INTHL7F(F,10,"AS",I0)) CL=CL_","

WP ;Handle a segment residing in a WP field

 ;Enter here with FILE(FLVL) holding the WP fields sub-dictionay number

 ;--NCPDP messages do not use word processing fields.

 ;--Changes may be needed in the WP section if future NCPDP messages do

 N MODE

 I GROUP S A="ENDGROUP" D L(.DATA,1) S GROUP=0

 S A=";'"_$P(SEG(0),U,2)_"' segment" D L(.DATA,1)

 S A="WHILE $P(DATA,DELIM)="""_$P(SEG(0),U,2)_"""" D L(.DATA,1)

 S A="LINE ^"_$P(SEG(0),U,2)_"1" D L(.DATA,1) S A="ENDWHILE" D L(.DATA,1)

 S INF0=$O(^INTHL7S(SEG,1,"AS",0)) Q:'INF0

 S FIELD=+^INTHL7S(SEG,1,INF0,0) Q:'$D(^INTHL7F(FIELD))  S MODE=$P(^(FIELD,0),U,4)

 S SEGC=SEGC+1,A="IF $D(@INV@("""_$P(SEG(0),U,2)_1_"""))" D L(.STORE,1) S A="ROUTINE=WP^INHS("_+FILE(FLVL-1)_","_MULTF_",""DIPA("""""_$P(SEG(0),U,2)_1_""""")"","_+MODE_")" D L(.STORE,1) S A="ENDIF" D L(.STORE,1)

 S MULTF=0,FLVL=FLVL-1

ROPOST ;Post field processing for REPEAT and OTHER segments

 I '$D(SVAR(.01)),$G(INSTD)'="X12" D ERROR^INHSGZ2("Segment '"_$P(SEG(0),U)_"' does not contain the .01 field of the multiple or other file.") Q

 S FSAV(+FILE(FLVL))=$P(SEG(0),U,2)_".01"

 I $P(OTHER,U,4)]"" S A="PARAM "_$S($P(OTHER,U,4)="O":"N",1:$P(OTHER,U,4)) D L(.STORE,1)

 I $O(@MUMPS@(0)) S I=0 F  S I=$O(@MUMPS@(I)) Q:'I  S A="^"_$P(@MUMPS@(I,0),"|CR|") D:$L(A)>1 L(.STORE,1)

 I $O(@SCODE@(0)) S I=0 F  S I=$O(@SCODE@(I)) Q:'I  S A=$P(@SCODE@(I,0),"|CR|") D:$L(A) L(.STORE,1)

 S A="LOOK "_$P(SEG(0),U,2)_".01" D L(.STORE,1)

 D:'NOSTORE

 . I $P(OTHER,U,3)]""!$D(T) S A="TEMPLATE = ["_$TR($S($P(OTHER,U,3)]"":$P(OTHER,U,3),1:T),"[]")_"]" D L(.STORE,1)

 . I $G(@ROUTINE)]"" S X=@ROUTINE S:$P(X,"(")'[U X=U_X S A="ROUTINE = "_X D L(.STORE,1)

 . I INAUDIT S Z=ARSEG($P(SEG(0),U,2)),A="ROUTINE = "_$P(SEG(0),U,2)_U_ARNAME_$S(Z>1:$C(63+Z),1:"") D L(.STORE,1)

ROPOST1 ;Post segment processing

 S FLVL=FLVL-1,A=$S(OTHER:"ENDOTHER",1:"ENDMULT") D L(.STORE,1) S A="ENDIF" D L(.STORE,1) S A="" D L(.STORE,1)

INHSGZ20  ;JSH,DGH; 20 Dec 1999 09:29 ;INHSGZ2 Inbound script cont'd

 +1       ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 +2       ;COPYRIGHT 1991-2000 SAIC

 +3       ;CHCS TOOLS_460; GEN 5; 17-JUL-1997

 +4       ;COPYRIGHT 1988, 1989, 1990 SAIC

 +5       ;

L(%L,%C)  ;Place a line in the global

 +1        GOTO L1^INHSGZ2

 +2       ;

FIELD     ;Handle a field

 +1        IF $ORDER(^INTHL7F(FIELD,10,0))

               Begin DoDot:1

 +2                IF INSTD="NC"

                       DO WARN^INHSGZ2("Sub-fields not supported for NCPDP. Ignoring.")

               End DoDot:1

               IF INSTD'="NC"

                   GOTO SUB

 +3        SET (LVAR,SVAR)=$PIECE(SEG(0),U,2)_INF

FD1       ;one field

 +1        WRITE "."

           SET FIELD(0)=^INTHL7F(FIELD,0)

           SET DTY=+$PIECE(FIELD(0),U,2)

           SET DTY(0)=$GET(^INTHL7FT(DTY,0))

 +2        IF 'DTY

               DO ERROR^INHSGZ2("Field '"_$PIECE(FIELD(0),U)_"' does not have a Data Type.")

               QUIT

 +3       ;--Add support for fixed and min/max fields - dgh

 +4       ;Determine if field length is Variable, Fixed or Min/Max.

 +5        NEW LENTYP,MIN,PADC,PADP,DLM,FID,LEN

 +6        SET LENTYP=$PIECE(FIELD(0),U,7)

           SET FID=$PIECE(FIELD(0),U,14)

           SET LEN=$PIECE(FIELD(0),U,3)

 +7       ;NCPDP formats will identify fields by id instead of position

 +8       ;so SVAR is replaced by FID. (Subfields not supported for fixed)

 +9        IF $GET(INSTD)="NC"

               SET (LVAR,SVAR)=FID

               IF '$LENGTH(FID)

                   DO ERROR^INHSGZ2("Field '"_$PIECE(FIELD(0),U)_" requires an ID.")

                   QUIT

 +10       Begin DoDot:1

 +11           IF LENTYP=""

                   SET LENTYP="V"

 +12      ;Variable field length is the default

 +13           IF LENTYP="V"

                   Begin DoDot:2

 +14                   IF $GET(INSTD)'="NC"

                           QUIT

 +15      ;If interface standard is NCPDP, set field identifier in FLEN array

 +16      ;NOTE, MINMAX FORMAT WAS DONE FOR OUTGOING, NOT YET SUPPORTING INCOM.

 +17                   IF '$LENGTH(FID)

                           DO ERROR^INHSGZ2("Field '"_$PIECE(FIELD(0),U)_"' does not have a field identifier.")

                           QUIT

 +18                   SET FLEN(INF)="V("_FID_")"

                   End DoDot:2

                   QUIT

 +19           SET MIN=+$PIECE(FIELD(0),U,8)

               SET PADC=$PIECE(FIELD(0),U,9)

               SET PADP=$PIECE(FIELD(0),U,10)

 +20      ;Indicate Delimiter - LD (Some fixed formats use delims, others no)

 +21           SET DLM=$PIECE(FIELD(0),U,13)

 +22      ;Set NCPDP defaults

 +23           IF $GET(INSTD)="NC"

                   Begin DoDot:2

 +24                   SET PADP=$SELECT($LENGTH(PADP):PADP,$PIECE(DTY(0),U,2)="NM":"R",$PIECE(DTY(0),U,2)="DL":"R",1:"L")

 +25                   SET PADC=$SELECT($LENGTH(PADC):PADC,$PIECE(DTY(0),U,2)="NM":0,$PIECE(DTY(0),U,2)="DL":0,1:" ")

                   End DoDot:2

                   QUIT

 +26      ;Otherwise default pad position is right/justify left

 +27           IF PADP=""

                   SET PADP="L"

               IF PADC=""

                   SET PADC=" "

 +28      ;Inbound parsing of Min/Max will be identical to Variable

 +29           IF LENTYP="M"

                   SET LENTYP="V"

           End DoDot:1

 +30      ;Reset LVAR to include fixed format information (not yet min/max)

 +31       IF $GET(LENTYP)'="V"

               SET LVAR=LVAR_"="_LENTYP_PADP_"("_PADC_")"_LEN

 +32      ;--

 +33       IF $LENGTH($TRANSLATE($PIECE($GET(^INTHL7F(FIELD,2)),U,1,4),"^"))

               SET A="^S INTHL7F2="""_$GET(^INTHL7F(FIELD,2))_""""

               DO L(.TRANS,1)

 +34       FOR J=1:1:(INF-CP)

               SET CL=CL_"^"

 +35       SET CP=INF

           SET CL=CL_LVAR

           IF $LENGTH(CL)>220

               SET A=CL

               DO L(.DATA,0)

               SET CL=""

 +36      ; Do the escape conversion first if conversion flag exists

 +37       SET GL=""

 +38       IF $PIECE($GET(^INTHL7F(FIELD,2)),U,4)

               IF $GET(^INTHL7FT(DTY,4))]""

                   SET GL="^INTHL7FT("_DTY_",4)"

 +39      ;;Do the input override

 +40       IF $GET(^INTHL7F(FIELD,4))]""

               SET GL=GL_"^INTHL7F("_FIELD_",4)"

 +41      ;Do the input transform if no input override

 +42       IF $GET(^INTHL7F(FIELD,4))=""

               IF $GET(^INTHL7FT(DTY,2))]""

                   SET GL=GL_"^INTHL7FT("_DTY_",2)"

 +43      ;For NCPDP, transforms and required field checks need full subscripts

 +44       IF $GET(INSTD)="NC"

               SET SVAR=$PIECE(SEG(0),U,2)_","_SVAR

 +45       IF GL]""

               SET A=SVAR_$EXTRACT("$",$PIECE(SEG(1),U,6))_"$^"_$$LB^UTIL(@GL)

               DO L(.TRANS,1)

 +46       SET MAP=$GET(^INTHL7F(FIELD,50))

           IF MAP

               IF $GET(^("I"))=""

                   IF '$DATA(^INVD(4090.2,MAP))

                       Begin DoDot:1

 +47                       DO ERROR^INHSGZ2("Map function for field: "_$PIECE(FIELD(0),U)_" has broken pointer.")

                       End DoDot:1

                   IF ERR

                       QUIT

                   SET A=SVAR_$EXTRACT("$",$PIECE(SEG(1),U,6))_"$^I X]"""" S X=$$MAP^INHVA2("""_$PIECE(^INVD(4090.2,MAP,0),U)_""",X,0)"_$SELECT($GET(^INTHL7FT(DTY,50))]"":" "_^(50),1:"")

                   DO L(.TRANS,1)

 +48       IF $GET(^INTHL7F(FIELD,"I"))]""

               SET A=SVAR_"$^"_^("I")

               DO L(.TRANS,1)

 +49      ;Kill 2 node local if exists

 +50       IF $LENGTH($TRANSLATE($PIECE($GET(^INTHL7F(FIELD,2)),U,1,4),"^"))

               SET A="^K INTHL7F2"

               DO L(.TRANS,1)

 +51       IF 'NOLS

               DO PROC^INHSGZ21

               IF ERR

                   QUIT

 +52       IF REQ

               Begin DoDot:1

 +53               IF 'REPEAT

                       SET A=SVAR_$SELECT('$PIECE(MESS(1),U,9):"^"_$PIECE(SEG(0),U,2)_1_"^D KILL^INHVA1("""_$PIECE(SEG(0),U,2)_""","""_$PIECE(FIELD(0),U)_""")",1:" ;"_$PIECE(FIELD(0),U))

                       DO L(.REQUIRED,1)

                       QUIT

 +54               SET REPEAT("REQ",SVAR)=$PIECE(FIELD(0),U)

               End DoDot:1

 +55       QUIT

 +56      ;

SUB       ;Handle a field with subfields

 +1       ;Subfields not supported for NCPDP

 +2        IF INSTD="NC"

               DO WARN^INHSGZ2("Sub-fields not supported for NCPDP. Ignoring.")

               QUIT

 +3        NEW I,F,I0

 +4        SET F=FIELD

           SET (I0,I)=0

FOR

               SET I0=$ORDER(^INTHL7F(F,10,"AS",I0))

               IF 'I0

                   QUIT

               SET I=I+1

               SET Y=$GET(^INTHL7F(F,10,+$ORDER(^(I0,0)),0))

               SET FIELD=+Y

               IF FIELD

                   IF $DATA(^INTHL7F(FIELD,0))

                       Begin DoDot:1

 +5                        SET FIELD(0)=^INTHL7F(FIELD,0)

                           SET (LVAR,SVAR)=$PIECE(SEG(0),U,2)_INF_"."_I

 +6                        SET REQ=$PIECE(Y,U,3)

                           SET UFL=$PIECE(Y,U,4)

                           DO FD1

 +7                        IF $ORDER(^INTHL7F(F,10,"AS",I0))

                               SET CL=CL_","

                       End DoDot:1

 +8        QUIT

 +9       ;

WP        ;Handle a segment residing in a WP field

 +1       ;Enter here with FILE(FLVL) holding the WP fields sub-dictionay number

 +2       ;--NCPDP messages do not use word processing fields.

 +3       ;--Changes may be needed in the WP section if future NCPDP messages do

 +4        NEW MODE

 +5        IF GROUP

               SET A="ENDGROUP"

               DO L(.DATA,1)

               SET GROUP=0

 +6        SET A=";'"_$PIECE(SEG(0),U,2)_"' segment"

           DO L(.DATA,1)

 +7        SET A="WHILE $P(DATA,DELIM)="""_$PIECE(SEG(0),U,2)_""""

           DO L(.DATA,1)

 +8        SET A="LINE ^"_$PIECE(SEG(0),U,2)_"1"

           DO L(.DATA,1)

           SET A="ENDWHILE"

           DO L(.DATA,1)

 +9        SET INF0=$ORDER(^INTHL7S(SEG,1,"AS",0))

           IF 'INF0

               QUIT

 +10       SET FIELD=+^INTHL7S(SEG,1,INF0,0)

           IF '$DATA(^INTHL7F(FIELD))

               QUIT

           SET MODE=$PIECE(^(FIELD,0),U,4)

 +11       SET SEGC=SEGC+1

           SET A="IF $D(@INV@("""_$PIECE(SEG(0),U,2)_1_"""))"

           DO L(.STORE,1)

           SET A="ROUTINE=WP^INHS("_+FILE(FLVL-1)_","_MULTF_",""DIPA("""""_$PIECE(SEG(0),U,2)_1_""""")"","_+MODE_")"

           DO L(.STORE,1)

           SET A="ENDIF"

           DO L(.STORE,1)

 +12       SET MULTF=0

           SET FLVL=FLVL-1

 +13       QUIT

 +14      ;

ROPOST    ;Post field processing for REPEAT and OTHER segments

 +1        IF '$DATA(SVAR(.01))

               IF $GET(INSTD)'="X12"

                   DO ERROR^INHSGZ2("Segment '"_$PIECE(SEG(0),U)_"' does not contain the .01 field of the multiple or other file.")

                   QUIT

 +2        SET FSAV(+FILE(FLVL))=$PIECE(SEG(0),U,2)_".01"

 +3        IF $PIECE(OTHER,U,4)]""

               SET A="PARAM "_$SELECT($PIECE(OTHER,U,4)="O":"N",1:$PIECE(OTHER,U,4))

               DO L(.STORE,1)

 +4        IF $ORDER(@MUMPS@(0))

               SET I=0

FOR

                   SET I=$ORDER(@MUMPS@(I))

                   IF 'I

                       QUIT

                   SET A="^"_$PIECE(@MUMPS@(I,0),"|CR|")

                   IF $LENGTH(A)>1

                       DO L(.STORE,1)

 +5        IF $ORDER(@SCODE@(0))

               SET I=0

FOR

                   SET I=$ORDER(@SCODE@(I))

                   IF 'I

                       QUIT

                   SET A=$PIECE(@SCODE@(I,0),"|CR|")

                   IF $LENGTH(A)

                       DO L(.STORE,1)

 +6        SET A="LOOK "_$PIECE(SEG(0),U,2)_".01"

           DO L(.STORE,1)

 +7        IF 'NOSTORE

               Begin DoDot:1

 +8                IF $PIECE(OTHER,U,3)]""!$DATA(T)

                       SET A="TEMPLATE = ["_$TRANSLATE($SELECT($PIECE(OTHER,U,3)]"":$PIECE(OTHER,U,3),1:T),"[]")_"]"

                       DO L(.STORE,1)

 +9                IF $GET(@ROUTINE)]""

                       SET X=@ROUTINE

                       IF $PIECE(X,"(")'[U

                           SET X=U_X

                       SET A="ROUTINE = "_X

                       DO L(.STORE,1)

 +10               IF INAUDIT

                       SET Z=ARSEG($PIECE(SEG(0),U,2))

                       SET A="ROUTINE = "_$PIECE(SEG(0),U,2)_U_ARNAME_$SELECT(Z>1:$CHAR(63+Z),1:"")

                       DO L(.STORE,1)

               End DoDot:1

 +11       QUIT

 +12      ;

ROPOST1   ;Post segment processing

 +1        SET FLVL=FLVL-1

           SET A=$SELECT(OTHER:"ENDOTHER",1:"ENDMULT")

           DO L(.STORE,1)

           SET A="ENDIF"

           DO L(.STORE,1)

           SET A=""

           DO L(.STORE,1)

 +2        QUIT

INHSGZ20.m