Routine: INHSGZ1

INHSGZ1 ; cmi/flag/maw - JSH,DGH 20 Dec 1999 09:24 Interface - script generator for OUTPUT scripts ; [ 05/10/2002 3:16 PM ]

 ;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002

 ;COPYRIGHT 1991-2000 SAIC

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

 ;COPYRIGHT 1988, 1989, 1990 SAIC

 ;This routine enters with:

 ;  FILE = file #

 ;  MESS = entry # of message

 ;  MESS(0) = zero node of message file entry

 ;This routine will set ERR to 1 if an error has occurred.

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

 ;%C = 1: place |CR| at the end   0: do not place |CR| at the end

 S LC=LC+1,^UTILITY("INS",$J,LC)=A_$P("|CR|",U,%C) Q

OUT ;Create an outgoing script

 N LC,A,INS,SEG,X,F,LEN,FIELD,DTY,SUB,I,DL,P01,FLVL,SCREEN,INMSH9

 S BHLMIEN=MESS  ;cmi/sitka/maw setup a local variable for message ien

 S (FLVL,LC)=0,FILE(0)=FILE,MESS(7)=$G(^INTHL7M(MESS,7))

 S INSTD=$G(INSTD,"HL7")

 S A=";Script generated from '"_$P(MESS(0),U)_"' "_INSTD_" message." D L(1)

 I $D(^INTHL7M(MESS,6)) D

 . S A="MUMPS:" D L(1)

 . S X=0 F  S X=$O(^INTHL7M(MESS,6,X)) Q:'X  S A=$G(^(X,0)) D L(1)

 . S A=" " D L(1)

 S A="DATA:" D L(1)

 ;Enhance note -- dgh -- if a call is created to specify delimiters

 ;by standard, it should probably go here.

 ;Default to standard set if nothing is specified above

 .;Set field separator character ("^")

 .S A="DELIM="""_$$FIELD^INHUT()_"""" D L(1)

 .;NCPDP doesn't use subdelimiters, but null SUBDELIM needed downstream

 .I $G(INSTD)="NC" S A="SUBDELIM=""""" D L(1) Q

 .;X12 Subdelimiter - LD

 .;I $G(INSTD)="X12" S A="SUBDELIM="":""" D L(1) Q

 .I $G(INSTD)="X12" S A="SUBDELIM="":""",INEOSM=$P($G(^INTHL7M(MESS,12)),U,17) D L(1)  ;cmi/maw added set of end of segment marker 7/20/2001

 .;Set component separator character ("\")

 .S A="SUBDELIM="""_$$COMP^INHUT()_"""" D L(1)

 ;Message Header (MSH) segment. Must be conditional on standard

 I $G(INSTD)="HL" D MSH

 ;I $G(INSTD)="X12" D ISA^INHSGZ23 maw original line

 ;Event Type (EVN) segment. Must only occur for HL7 messages before 2.2

 ;I INSTD="HL",$P(MESS(0),U,4)<2.2 S A="LINE ""EVN""^"""_$P(MESS(0),U,2)_"""^" D L(1) ;cmi/maw build EVN dynamically from file/tables orig

 ;Process segments

 S INS="" F  S INS=$O(^INTHL7M(MESS,1,"AS",INS)) Q:'INS  S X=$O(^(INS,0)),SEG(1)=^INTHL7M(MESS,1,X,0) D:'$P(SEG(1),U,11) SEG(X) Q:ERR

 S A="" D L(1)

 S A="END:" D L(1)

MSH ;Set up Message header (MSH) segment

 Q  ;maw added we use the file/table build for this in IHS orig

 S A="LINE ""MSH""^""\|~&""^"_$P(MESS(7),U,1)_U_$P(MESS(7),U,2)_U

 ;this is dave's suggested code

 S A="LINE ""MSH""^@INDELIMS^"_$P(MESS(7),U,1)_U_$P(MESS(7),U,2)_U ;mod

 S A=A_$P(MESS(7),U,3)_U_$P(MESS(7),U,4)_"^INTX(NOW,""TS"")^^"

 ;Message type \ event type

 S INMSH9=$P(MESS(0),U,6) D  S A=A_INMSH9

 .  ;Check for special variable

 .  I $E(INMSH9)="@" Q

 .  S INMSH9=""""_$P(MESS(0),U,6)

 .  ;Check for event type

 .  S:$L($P(MESS(0),U,2)) INMSH9=INMSH9_"\"_$P(MESS(0),U,2)

 .  S INMSH9=INMSH9_""""

 ;        message ID   Accept Ack               Appl Ack

 S A=A_"^@MESSID^"""_$P(MESS(0),U,3)_"""^"""_$P(MESS(0),U,4)_""""

 S A=A_"^@INSEQ^^"""_$P(MESS(0),U,10)_"""^"""_$P(MESS(0),U,11)_""""

 D L(1)

SEG(SEG) ;Processes a segment

 ;SEG = internal entry number in SEGMENT multiple of MESSAGE file

 S SEG(1)=^INTHL7M(MESS,1,SEG,0),SCREEN=$G(^(4)),SEG(2)=SEG,SEG=+SEG(1)

 Q:'$D(^INTHL7S(SEG,0))

 N CH,WHILE,FDFMT,INUDI,FD,FDMT,FLEN

 S SEG(0)=^(0)

 ;Q:$P(SEG(0),U,2)="MSH" cmi/maw we use file/table build for MSH

 Q:($P(MESS(0),U,4)<2.2)&($P(SEG(0),U,2)="EVN")

 ;I INSTD="X12",",ISA,GS,ST,"[$P(SEG(0),U,2) Q ;maw orig line

 ;I INSTD="X12",",ISA,GS,"[$P(SEG(0),U,2) Q ;maw modified

 K FD,FDMT,FLEN

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

 ;Support for HL7 Set ID fields

 S A="^SET INSETID=0" D L(1)

 S WHILE=$P(SEG(1),U,3)!$P(SEG(1),U,4)

 S INUDI=$P(SEG(1),U,12) ;User=defined index.

 I WHILE,(INUDI="") D  Q:ERR  S A="WHILE "_WHILE(1) D L(1) I SCREEN]"" S A="SCREEN="_SCREEN D L(1)

 . I $P(SEG(1),U,3),'$P(SEG(1),U,4) D  Q

 .. N DIC S X=$P(SEG(1),U,8),DIC="^DD("_+FILE(FLVL)_",",DIC(0)="FMZ",DIC("S")="I $P(^(0),U,2)" D ^DIC I Y<0 D ERROR^INHSGZ2("Multiple field '"_X_"' not found in file #"_+FILE(FLVL)) Q

 .. S FLVL=FLVL+1,FILE(FLVL)=+$P(Y(0),U,2),WHILE(1)=$P(Y,U,2)

 . S FLVL=FLVL+1,FILE(FLVL)=+$P(SEG(1),U,5) I 'FILE(FLVL) D ERROR^INHSGZ2("No file specified in segment '"_$P(SEG(0),U)_"'")

 . S WHILE(1)=$P(^DIC(+FILE(FLVL),0),U)

 I $L(INUDI) S WHILE=1,A="WHILE """_INUDI_"""" D L(1) I SCREEN]"" S A="SCREEN="_SCREEN D L(1)

 I $D(^INTHL7M(MESS,1,SEG(2),5)) S X=0 F  S X=$O(^INTHL7M(MESS,1,SEG(2),5,X)) Q:'X  S A=$G(^(X,0)) I $L(A) S A=U_A D L(1)

 S INF="" K SUB F  S INF=$O(^INTHL7S(SEG,1,"AS",INF)) Q:'INF  S X=$O(^(INF,0)),FIELD=+^INTHL7S(SEG,1,X,0) D:$D(^INTHL7F(FIELD,0)) FIELD  Q:ERR

 ;NCPDP does not use segment ID. Setting ID  must be conditional

 S A="LINE " D

 .I $G(INSTD)'="NC" S A=A_""""_$P(SEG(0),U,2)_""""

 .S INSEGST=A

 F I=1:1 Q:'$D(FD(I))&'$O(FD(I))  S A=A_"^" D:$D(FD(I))

 . I $D(SUB(I)) D  Q

 .. I ($L(A)+$L(SUB(I)))>240 D L(0) S A=""

 .. S A=A_SUB(I) Q

 . I FD(I) S E="$E("_$P(SEG(0),U,2)_I_",1,"_FD(I)_")"

 . I 'FD(I) S E=$P(SEG(0),U,2)_I

 .;If field is fixed or min/max, FLEN(INF) will exist

 .;Also set to contain field ID for NCPDP variable fields

 . I $D(FLEN(I)) S E=E_"="_FLEN(I)

 . I ($L(A)+$L(E))>240 D L(0) S A=""

 . S A=A_E

 D L(1):(A]""&(INSEGST'=A))

 I $D(^INTHL7M(MESS,1,"ASP",SEG)) S CH=0 F  S CH=$O(^INTHL7M(MESS,1,"ASP",SEG,CH)) Q:'CH  D SEG($O(^(CH,0)))

 I WHILE S A="ENDWHILE" S FLVL=FLVL-1 D L(1)

FIELD ;Process a field

 N SVAR

 S FIELD(0)=^(0),FD(INF)="" I $O(^INTHL7F(FIELD,10,0)) G SUB

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

FD1 ;set a field

 N I W "." S LEN=$P(FIELD(0),U,3) S:LEN="" LEN=30

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

 I 'DTY!(DTY(0)="") D ERROR^INHSGZ2("Field '"_$P(FIELD(0),U)_"' does not have a valid data type.") Q

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

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

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

 .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

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

 ..;NCPDP only needs last two characters of FID

 ..S:$L(FID)>2 FID=$E(FID,$L(FID)-1,$L(FID))

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

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

 .;X12 uses delimiters for fixed (& min/max fields). HL7 & NCPDP do not.

 .S DLM=$S(INSTD="X12":1,1:0)

 .;Set NCPDP defaults

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

 ..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"

 .;Set array into FLEN(INF), a companion to FD(INF).

 .S FLEN(INF)=LENTYP_PADP_"("_PADC_")"_LEN

 .;defaut min length equal one if there is no data for this field - LD

 .I LENTYP="M",'MIN S MIN=1

 .S:MIN FLEN(INF)=FLEN(INF)_","_MIN_","_DLM

 ;; Modify the character conversion

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

 I GL="",$G(^INTHL7FT(DTY,3))]"" S GL="^INTHL7FT("_DTY_",3)"

 N GL1 S GL1=""

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

 ;set precision, convert flag, add time if not a sub field

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

 S A="SET "_SVAR_" = ",DL=$$LBTB^UTIL($G(^INTHL7F(FIELD,"C"))) S:+DL=DL DL="#"_DL

 I DL="" S A=A_"""""" D L(1) D KILL Q

 I $P(DTY(0),U,2)="ID" S A=A_"$E(INTERNAL("_DL_"),1,"_LEN_")" D L(1) D KILL Q

 ;If an outgoing transform exists, store it in script file as follows

 I (GL]"")!(GL1]"") S A=A_"INSGX\"_GL_"\"_GL1_"\"_LEN_"\"_DL D L(1) D KILL Q

 I $D(SUB(INF)) S A=A_"$E("_DL_",1,"_LEN_")" D L(1) D KILL Q

 S FD(INF)=LEN,A=A_DL D L(1)

 D KILL

KILL ;Kill if existed and was not a sub field

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

SUB ;This field has subfields

 N I,I1,F S SUB(INF)=""

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

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

 . S SUB(INF)=SUB(INF)_$S(SUB(INF)]"":"_SUBDELIM_",1:"")_SVAR

CNDT ;Handle CN (composite ID number and name) data type

;D

 ;. ;** NEW CODE ** to auto-handle CN data type

 ;. S P01=0,I(0)="",J(0)=+FILE(FLVL),DICOMPX="",DA="X(",DQI="Y(",X=DL D ^DICOMP I $L(DICOMPX),$L(DICOMPX,";")=1,+DICOMPX=+FILE(FLVL),$P(DICOMPX,U,2)=.01,$P(^DD(+DICOMPX,+$P(DICOMPX,"^",2),0),"^",2)'["P" S P01=1

 ;. S IEN=$S(P01:"NUMBER",1:"INTERNAL("_DL_")")

 ;. S ROOTFILE=$P($G(^DD(+DICOMPX,+$P(DICOMPX,U,2),0)),U,2)

 ;. S ROOTFILE=+$P(ROOTFILE,"P",2)

 ;. S ROOTFILE=$S(P01:+DICOMPX,1:ROOTFILE)

 ;. ;S A=A_"$E($$CN^INHUT1("_IEN_";"_ROOTFILE_"),1,"_LEN_")" D L(1) Q

 ;. ;S A=A_"$E("_$S(GL]"":"INSGX("""_GL_""","_IEN_"_"";"_ROOTFILE_""")",1:DL)_"),1,"_LEN_")" D L(1) Q

 ;Must call DICOMP twice

 ;   the $E will not be accepted in the first expression

 ;. S A=A_$S(GL]"":"INSGX("""_GL_""","_IEN_"_"";"_ROOTFILE_""")",1:DL) D L(1) Q

 ;.S A="SET "_SVAR_" = $E("_SVAR_",1,"_LEN_")" D L(1)

;D

 ;.;*** Old Code to handle CN data type ***

 ;. S P01=0,I(0)="",J(0)=+FILE(FLVL),DICOMPX="",DA="X(",DQI="Y(",X=DL D ^DICOMP I $L(DICOMPX),$L(DICOMPX,";")=1,+DICOMPX=+FILE(FLVL),$P(DICOMPX,U,2)=.01,$P(^DD(+DICOMPX,+$P(DICOMPX,"^",2),0),"^",2)'["P" S P01=1

 ;. S A=A_"$E("_$S(P01:"NUMBER",1:"INTERNAL("_DL_")")_"_SUBDELIM_("_$S(GL]"":"INSGX("""_GL_""","_DL_")",1:DL)_"),1,"_LEN_")" D L(1) Q

INHSGZ1   ; cmi/flag/maw - JSH,DGH 20 Dec 1999 09:24 Interface - script generator for OUTPUT scripts ; [ 05/10/2002 3:16 PM ]

 +1       ;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002

 +2       ;COPYRIGHT 1991-2000 SAIC

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

 +4       ;COPYRIGHT 1988, 1989, 1990 SAIC

 +5       ;

 +6       ;This routine enters with:

 +7       ;  FILE = file #

 +8       ;  MESS = entry # of message

 +9       ;  MESS(0) = zero node of message file entry

 +10      ;

 +11      ;This routine will set ERR to 1 if an error has occurred.

 +12      ;

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

 +1       ;%C = 1: place |CR| at the end   0: do not place |CR| at the end

 +2        SET LC=LC+1

           SET ^UTILITY("INS",$JOB,LC)=A_$PIECE("|CR|",U,%C)

           QUIT

 +3       ;

OUT       ;Create an outgoing script

 +1        NEW LC,A,INS,SEG,X,F,LEN,FIELD,DTY,SUB,I,DL,P01,FLVL,SCREEN,INMSH9

 +2       ;cmi/sitka/maw setup a local variable for message ien

           SET BHLMIEN=MESS

 +3        SET (FLVL,LC)=0

           SET FILE(0)=FILE

           SET MESS(7)=$GET(^INTHL7M(MESS,7))

 +4        SET INSTD=$GET(INSTD,"HL7")

 +5        SET A=";Script generated from '"_$PIECE(MESS(0),U)_"' "_INSTD_" message."

           DO L(1)

 +6        IF $DATA(^INTHL7M(MESS,6))

               Begin DoDot:1

 +7                SET A="MUMPS:"

                   DO L(1)

 +8                SET X=0

FOR

                       SET X=$ORDER(^INTHL7M(MESS,6,X))

                       IF 'X

                           QUIT

                       SET A=$GET(^(X,0))

                       DO L(1)

 +9                SET A=" "

                   DO L(1)

               End DoDot:1

 +10       SET A="DATA:"

           DO L(1)

 +11      ;Enhance note -- dgh -- if a call is created to specify delimiters

 +12      ;by standard, it should probably go here.

 +13      ;Default to standard set if nothing is specified above

 +14       Begin DoDot:1

 +15      ;Set field separator character ("^")

 +16           SET A="DELIM="""_$$FIELD^INHUT()_""""

               DO L(1)

 +17      ;NCPDP doesn't use subdelimiters, but null SUBDELIM needed downstream

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

                   SET A="SUBDELIM="""""

                   DO L(1)

                   QUIT

 +19      ;X12 Subdelimiter - LD

 +20      ;I $G(INSTD)="X12" S A="SUBDELIM="":""" D L(1) Q

 +21      ;cmi/maw added set of end of segment marker 7/20/2001

               IF $GET(INSTD)="X12"

                   SET A="SUBDELIM="":"""

                   SET INEOSM=$PIECE($GET(^INTHL7M(MESS,12)),U,17)

                   DO L(1)

 +22      ;Set component separator character ("\")

 +23           SET A="SUBDELIM="""_$$COMP^INHUT()_""""

               DO L(1)

           End DoDot:1

 +24      ;Message Header (MSH) segment. Must be conditional on standard

 +25       IF $GET(INSTD)="HL"

               DO MSH

 +26      ;I $G(INSTD)="X12" D ISA^INHSGZ23 maw original line

 +27      ;Event Type (EVN) segment. Must only occur for HL7 messages before 2.2

 +28      ;I INSTD="HL",$P(MESS(0),U,4)<2.2 S A="LINE ""EVN""^"""_$P(MESS(0),U,2)_"""^" D L(1) ;cmi/maw build EVN dynamically from file/tables orig

 +29      ;Process segments

 +30       SET INS=""

FOR

               SET INS=$ORDER(^INTHL7M(MESS,1,"AS",INS))

               IF 'INS

                   QUIT

               SET X=$ORDER(^(INS,0))

               SET SEG(1)=^INTHL7M(MESS,1,X,0)

               IF '$PIECE(SEG(1),U,11)

                   DO SEG(X)

               IF ERR

                   QUIT

 +31       SET A=""

           DO L(1)

 +32       SET A="END:"

           DO L(1)

 +33       QUIT

 +34      ;

MSH       ;Set up Message header (MSH) segment

 +1       ;maw added we use the file/table build for this in IHS orig

           QUIT

 +2       ;

 +3        SET A="LINE ""MSH""^""\|~&""^"_$PIECE(MESS(7),U,1)_U_$PIECE(MESS(7),U,2)_U

 +4       ;this is dave's suggested code

 +5       ;mod

           SET A="LINE ""MSH""^@INDELIMS^"_$PIECE(MESS(7),U,1)_U_$PIECE(MESS(7),U,2)_U

 +6       ;

 +7        SET A=A_$PIECE(MESS(7),U,3)_U_$PIECE(MESS(7),U,4)_"^INTX(NOW,""TS"")^^"

 +8       ;Message type \ event type

 +9        SET INMSH9=$PIECE(MESS(0),U,6)

           Begin DoDot:1

 +10      ;Check for special variable

 +11           IF $EXTRACT(INMSH9)="@"

                   QUIT

 +12           SET INMSH9=""""_$PIECE(MESS(0),U,6)

 +13      ;Check for event type

 +14           IF $LENGTH($PIECE(MESS(0),U,2))

                   SET INMSH9=INMSH9_"\"_$PIECE(MESS(0),U,2)

 +15           SET INMSH9=INMSH9_""""

           End DoDot:1

           SET A=A_INMSH9

 +16      ;        message ID   Accept Ack               Appl Ack

 +17       SET A=A_"^@MESSID^"""_$PIECE(MESS(0),U,3)_"""^"""_$PIECE(MESS(0),U,4)_""""

 +18       SET A=A_"^@INSEQ^^"""_$PIECE(MESS(0),U,10)_"""^"""_$PIECE(MESS(0),U,11)_""""

 +19       DO L(1)

 +20       QUIT

 +21      ;

SEG(SEG)  ;Processes a segment

 +1       ;SEG = internal entry number in SEGMENT multiple of MESSAGE file

 +2        SET SEG(1)=^INTHL7M(MESS,1,SEG,0)

           SET SCREEN=$GET(^(4))

           SET SEG(2)=SEG

           SET SEG=+SEG(1)

 +3        IF '$DATA(^INTHL7S(SEG,0))

               QUIT

 +4        NEW CH,WHILE,FDFMT,INUDI,FD,FDMT,FLEN

 +5        SET SEG(0)=^(0)

 +6       ;Q:$P(SEG(0),U,2)="MSH" cmi/maw we use file/table build for MSH

 +7        IF ($PIECE(MESS(0),U,4)<2.2)&($PIECE(SEG(0),U,2)="EVN")

               QUIT

 +8       ;I INSTD="X12",",ISA,GS,ST,"[$P(SEG(0),U,2) Q ;maw orig line

 +9       ;I INSTD="X12",",ISA,GS,"[$P(SEG(0),U,2) Q ;maw modified

 +10       KILL FD,FDMT,FLEN

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

           DO L(1)

 +12      ;Support for HL7 Set ID fields

 +13       SET A="^SET INSETID=0"

           DO L(1)

 +14       SET WHILE=$PIECE(SEG(1),U,3)!$PIECE(SEG(1),U,4)

 +15      ;User=defined index.

           SET INUDI=$PIECE(SEG(1),U,12)

 +16       IF WHILE

               IF (INUDI="")

                   Begin DoDot:1

 +17                   IF $PIECE(SEG(1),U,3)

                           IF '$PIECE(SEG(1),U,4)

                               Begin DoDot:2

 +18                               NEW DIC

                                   SET X=$PIECE(SEG(1),U,8)

                                   SET DIC="^DD("_+FILE(FLVL)_","

                                   SET DIC(0)="FMZ"

                                   SET DIC("S")="I $P(^(0),U,2)"

                                   DO ^DIC

                                   IF Y<0

                                       DO ERROR^INHSGZ2("Multiple field '"_X_"' not found in file #"_+FILE(FLVL))

                                       QUIT

 +19                               SET FLVL=FLVL+1

                                   SET FILE(FLVL)=+$PIECE(Y(0),U,2)

                                   SET WHILE(1)=$PIECE(Y,U,2)

                               End DoDot:2

                               QUIT

 +20                   SET FLVL=FLVL+1

                       SET FILE(FLVL)=+$PIECE(SEG(1),U,5)

                       IF 'FILE(FLVL)

                           DO ERROR^INHSGZ2("No file specified in segment '"_$PIECE(SEG(0),U)_"'")

 +21                   SET WHILE(1)=$PIECE(^DIC(+FILE(FLVL),0),U)

                   End DoDot:1

                   IF ERR

                       QUIT

                   SET A="WHILE "_WHILE(1)

                   DO L(1)

                   IF SCREEN]""

                       SET A="SCREEN="_SCREEN

                       DO L(1)

 +22       IF $LENGTH(INUDI)

               SET WHILE=1

               SET A="WHILE """_INUDI_""""

               DO L(1)

               IF SCREEN]""

                   SET A="SCREEN="_SCREEN

                   DO L(1)

 +23       IF $DATA(^INTHL7M(MESS,1,SEG(2),5))

               SET X=0

FOR

                   SET X=$ORDER(^INTHL7M(MESS,1,SEG(2),5,X))

                   IF 'X

                       QUIT

                   SET A=$GET(^(X,0))

                   IF $LENGTH(A)

                       SET A=U_A

                       DO L(1)

 +24       SET INF=""

           KILL SUB

FOR

               SET INF=$ORDER(^INTHL7S(SEG,1,"AS",INF))

               IF 'INF

                   QUIT

               SET X=$ORDER(^(INF,0))

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

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

                   DO FIELD

               IF ERR

                   QUIT

 +25      ;NCPDP does not use segment ID. Setting ID  must be conditional

 +26       SET A="LINE "

           Begin DoDot:1

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

                   SET A=A_""""_$PIECE(SEG(0),U,2)_""""

 +28           SET INSEGST=A

           End DoDot:1

 +29       FOR I=1:1

               IF '$DATA(FD(I))&'$ORDER(FD(I))

                   QUIT

               SET A=A_"^"

               IF $DATA(FD(I))

                   Begin DoDot:1

 +30                   IF $DATA(SUB(I))

                           Begin DoDot:2

 +31                           IF ($LENGTH(A)+$LENGTH(SUB(I)))>240

                                   DO L(0)

                                   SET A=""

 +32                           SET A=A_SUB(I)

                               QUIT

                           End DoDot:2

                           QUIT

 +33                   IF FD(I)

                           SET E="$E("_$PIECE(SEG(0),U,2)_I_",1,"_FD(I)_")"

 +34                   IF 'FD(I)

                           SET E=$PIECE(SEG(0),U,2)_I

 +35      ;If field is fixed or min/max, FLEN(INF) will exist

 +36      ;Also set to contain field ID for NCPDP variable fields

 +37                   IF $DATA(FLEN(I))

                           SET E=E_"="_FLEN(I)

 +38                   IF ($LENGTH(A)+$LENGTH(E))>240

                           DO L(0)

                           SET A=""

 +39                   SET A=A_E

                   End DoDot:1

 +40       IF (A]""&(INSEGST'=A))

               DO L(1)

 +41       IF $DATA(^INTHL7M(MESS,1,"ASP",SEG))

               SET CH=0

FOR

                   SET CH=$ORDER(^INTHL7M(MESS,1,"ASP",SEG,CH))

                   IF 'CH

                       QUIT

                   DO SEG($ORDER(^(CH,0)))

 +42       IF WHILE

               SET A="ENDWHILE"

               SET FLVL=FLVL-1

               DO L(1)

 +43       QUIT

 +44      ;

FIELD     ;Process a field

 +1        NEW SVAR

 +2        SET FIELD(0)=^(0)

           SET FD(INF)=""

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

               GOTO SUB

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

FD1       ;set a field

 +1        NEW I

           WRITE "."

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

           IF LEN=""

               SET LEN=30

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

           SET GL=""

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

 +3        IF 'DTY!(DTY(0)="")

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

               QUIT

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

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

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

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

           Begin DoDot:1

 +7            IF LENTYP=""

                   SET LENTYP="V"

 +8       ;Variable field length is the default

 +9            IF LENTYP="V"

                   Begin DoDot:2

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

                           QUIT

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

 +12                   IF '$LENGTH(FID)

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

                           QUIT

 +13      ;NCPDP only needs last two characters of FID

 +14                   IF $LENGTH(FID)>2

                           SET FID=$EXTRACT(FID,$LENGTH(FID)-1,$LENGTH(FID))

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

                   End DoDot:2

                   QUIT

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

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

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

 +17      ;X12 uses delimiters for fixed (& min/max fields). HL7 & NCPDP do not.

 +18           SET DLM=$SELECT(INSTD="X12":1,1:0)

 +19      ;Set NCPDP defaults

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

                   Begin DoDot:2

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

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

                   End DoDot:2

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

 +24           IF PADP=""

                   SET PADP="L"

 +25      ;Set array into FLEN(INF), a companion to FD(INF).

 +26           SET FLEN(INF)=LENTYP_PADP_"("_PADC_")"_LEN

 +27      ;defaut min length equal one if there is no data for this field - LD

 +28           IF LENTYP="M"

                   IF 'MIN

                       SET MIN=1

 +29           IF MIN

                   SET FLEN(INF)=FLEN(INF)_","_MIN_","_DLM

           End DoDot:1

 +30      ;; Modify the character conversion

 +31       IF $GET(^INTHL7F(FIELD,5))]""

               SET GL="^INTHL7F("_FIELD_",5)"

 +32       IF GL=""

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

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

 +33       NEW GL1

           SET GL1=""

 +34       IF $GET(^INTHL7FT(DTY,5))]""

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

                   SET GL1="^INTHL7FT("_DTY_",5)"

 +35      ;set precision, convert flag, add time if not a sub field

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

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

               DO L(1)

 +37       SET A="SET "_SVAR_" = "

           SET DL=$$LBTB^UTIL($GET(^INTHL7F(FIELD,"C")))

           IF +DL=DL

               SET DL="#"_DL

 +38       IF DL=""

               SET A=A_""""""

               DO L(1)

               DO KILL

               QUIT

 +39       IF $PIECE(DTY(0),U,2)="ID"

               SET A=A_"$E(INTERNAL("_DL_"),1,"_LEN_")"

               DO L(1)

               DO KILL

               QUIT

 +40      ;If an outgoing transform exists, store it in script file as follows

 +41       IF (GL]"")!(GL1]"")

               SET A=A_"INSGX\"_GL_"\"_GL1_"\"_LEN_"\"_DL

               DO L(1)

               DO KILL

               QUIT

 +42       IF $DATA(SUB(INF))

               SET A=A_"$E("_DL_",1,"_LEN_")"

               DO L(1)

               DO KILL

               QUIT

 +43       SET FD(INF)=LEN

           SET A=A_DL

           DO L(1)

 +44       DO KILL

 +45       QUIT

KILL      ;Kill if existed and was not a sub field

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

               SET A="^K INTHL7F2"

               DO L(1)

 +2        QUIT

 +3       ;

SUB       ;This field has subfields

 +1        NEW I,I1,F

           SET SUB(INF)=""

 +2        SET F=FIELD

           SET I=0

FOR

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

               IF 'I

                   QUIT

               SET FIELD=+^INTHL7F(F,10,+$ORDER(^(I,0)),0)

               IF FIELD

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

                       Begin DoDot:1

 +3                        SET FIELD(0)=^(0)

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

                           DO FD1

 +4                        SET SUB(INF)=SUB(INF)_$SELECT(SUB(INF)]"":"_SUBDELIM_",1:"")_SVAR

                       End DoDot:1

 +5        QUIT

CNDT      ;Handle CN (composite ID number and name) data type

 +1        QUIT

 +2       ;

 +3       ;D

 +4       ;. ;** NEW CODE ** to auto-handle CN data type

 +5       ;. S P01=0,I(0)="",J(0)=+FIL">LE(FL">LVL">L),DICOMPX="",DA="X(",DQI="Y(",X=DL">L D ^DICOMP I $L">L(DICOMPX),$L">L(DICOMPX,";")=1,+DICOMPX=+FIL">LE(FL">LVL">L),$P(DICOMPX,U,2)=.01,$P(^DD(+DICOMPX,+$P(DICOMPX,"^",2),0),"^",2)'["P" S P01=1

 +6       ;. S IEN=$S(P01:"NUMBER",1:"INTERNAL("_DL_")")

 +7       ;. S ROOTFILE=$P($G(^DD(+DICOMPX,+$P(DICOMPX,U,2),0)),U,2)

 +8       ;. S ROOTFILE=+$P(ROOTFILE,"P",2)

 +9       ;. S ROOTFILE=$S(P01:+DICOMPX,1:ROOTFILE)

 +10      ;. ;S A=A_"$E($$CN^INHUT1("_IEN_";"_ROOTFILE_"),1,"_LEN_")" D L(1) Q

 +11      ;. ;S A=A_"$E("_$S(GL]"":"INSGX("""_GL_""","_IEN_"_"";"_ROOTFILE_""")",1:DL)_"),1,"_LEN_")" D L(1) Q

 +12      ;Must call DICOMP twice

 +13      ;   the $E will not be accepted in the first expression

 +14      ;. S A=A_$S(GL]"":"INSGX("""_GL_""","_IEN_"_"";"_ROOTFILE_""")",1:DL) D L(1) Q

 +15      ;.S A="SET "_SVAR_" = $E("_SVAR_",1,"_LEN_")" D L(1)

 +16      ;

 +17      ;D

 +18      ;.;*** Old Code to handle CN data type ***

 +19      ;. S P01=0,I(0)="",J(0)=+FIL">LE(FL">LVL">L),DICOMPX="",DA="X(",DQI="Y(",X=DL">L D ^DICOMP I $L">L(DICOMPX),$L">L(DICOMPX,";")=1,+DICOMPX=+FIL">LE(FL">LVL">L),$P(DICOMPX,U,2)=.01,$P(^DD(+DICOMPX,+$P(DICOMPX,"^",2),0),"^",2)'["P" S P01=1

 +20      ;. S A=A_"$E("_$S(P01:"NUMBER",1:"INTERNAL("_DL_")")_"_SUBDELIM_("_$S(GL]"":"INSGX("""_GL_""","_DL_")",1:DL)_"),1,"_LEN_")" D L(1) Q

 +21       QUIT

 +22      ;

INHSGZ1.m