INHMGD2 ;CAR; 27 Jun 97 15:34;HL7 MESSAGING - PROCESS SEGMENT
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;COPYRIGHT 1991-2000 SAIC
;
; MODULE NAME:
; HL7 Messaging - Process Segment
;
; PURPOSE:
; Module INHMGD2 is used to order through the fields
; pointed to by ^INTHL7M(INDA,1,SEG,0)
;
SEG(INSEG,FLVL,FILE,INP,INERN) ;Process segment
; Input:
; INSEG= Seg is the index to the ^INTHL7M(INDA,1,SEG,0) node, and
; is used to retrieve INMSG(1).
; FLVL = Current level in FILE.
; FILE = Stacks file# references.
; INP = The output array used to create a data file for export to
; a tab delimited text file.
; INERN= An incrementing counter to prevent multiple error msgs
; Output:
; INERN,INP and FILE
;
;get next segment descriptor.
S INSEG(1)=$G(^INTHL7M(INMSG,1,INSEG,0)),INSEG=+INSEG(1),INSEG(2)=INSEG
Q:'$D(^INTHL7S(INSEG,0))
;
;quit if common or MSH segment?
S INSEG(0)=^INTHL7S(INSEG,0)
I 'INCSG,"MSH,PID,"[($P(INSEG(0),U,2)_",") Q
;
;check for MULTIPLE, OTHER.
N DIC,INWHILE,INCH,X,INX,Y,INUDI,INDHDR
S INWHILE=$P(INSEG(1),U,3)!$P(INSEG(1),U,4)
S INUDI=$P(INSEG(1),U,12) ;user defined index
I INWHILE,(INUDI="") D
.I $P(INSEG(1),U,3),'$P(INSEG(1),U,4) D Q ;MULTIPLE
..K DIC S (X,INX)=$P(INSEG(1),U,8)
..S DIC="^DD("_+FILE(FLVL)_",",DIC(0)="FMZ"
..S DIC("S")="I $P(^(0),U,2)" D ^DIC
..I Y<0 D Q
...S INWHILE=0 Q:INPARS ;bogus segs ok in Parse Only msg.
...S INERN=INERN+.001
...S ^UTILITY("INHMGD",$J,"E",INMSG,INSEG,INERN)=+FILE(FLVL)_U_"Multiple "_INX_" does not exist"
..S FLVL=FLVL+1,FILE(FLVL)=+$P(Y(0),U,2),INWHILE(1)=$P(Y,U,2)
.S FLVL=FLVL+1,FILE(FLVL)=+$P(INSEG(1),U,5)
.I 'FILE(FLVL) D S FLVL=FLVL-1,INWHILE=0 Q
..S INX="No OTHER file specified",INERN=INERN+.001
..S ^UTILITY("INHMGD",$J,"E",INMSG,INERN)=+FILE(FLVL)_U_INX
.S INWHILE(1)=$P(^DIC(+FILE(FLVL),0),U)
;
N INF,INY,INREPEAT,INFLD
S INY=INSEG(0)
S INSG("NM")=$E($P(INY,U),1,45) ;Segment Name
S INSG("NM",1)=$E($P(INY,U,2),1,6) ;Segment ID
;
S INY=INSEG(1) ;from ^INTHL7M(INMSG,1,INX,0)
S INSG("NM",2)=$P(INY,U,2) ;Sequence Number
S INSG("NM",9)=$$YN^INHMGD1($P(INY,U,9),1) ;Required?
;Parent Segment?
S X=$P(INY,U,11)
S INSG("PS")=$E($S(X="":X,$D(^INTHL7S(X,0))#2:$P(^(0),U),1:" "_X),1,45)
S INREPEAT=$P(INY,U,3)
S INSG("NM",3)=$$YN^INHMGD1(INREPEAT,1) ;Repeatable?
;OTHER Flag & File Name
S INSG("NM",4)=$$YN^INHMGD1($P(INY,U,4),1)
S X=$P(INY,U,5)
S INSG("FL")=$E($S(X="":X,$D(^DIC(X,0))#2:$P(^(0),U),1:" "_X),1,45)
S INSG("MF")=$E($P(INY,U,8),1,30) ;Multiple Field Name
I +INSG("MF")=INSG("MF") D
.K DIC S X=INSG("MF"),DIC="^DD("_+FILE(FLVL)_",",DIC(0)="FMZ"
.S DIC("S")="I $P(^(0),U,2)" D ^DIC Q:Y<0
.S INSG("MF")=$E(Y(0,0),1,30)
S INSG("UD")=$P(INY,U,12)
;
;cleanup INP leaving flag & Message Name
I INP D
.S INP=$P(INP,TAB)_TAB_$P(INSEG(0),U,2) ;$P2 seg ID
.S INP=INP_TAB_$P(INSEG(0),U) ; $P3 seg name
.S INP=INP_TAB_INSG("NM",2) ; $P4 seg seq#
.S INP=INP_TAB_$S(INSG("NM",3)["Y":"Y",1:"") ;$P5 repeatable
.S INP=INP_TAB_INSG("MF") ; $P6 Multiple Field Name
.S INP=INP_TAB_$S(INSG("NM",9)["Y":"Y",1:"") ;$P7 Seg Reqd (Y/"")
.S INP=INP_TAB_INSG("PS") ; $P8 Parent Seg#
;
;Lookup Params
S INSG("LP")=$$LKPRM^INHMGD1($P(INY,U,7))
;Make Links
S X=$P(INY,U,10),INSG("ML")=$$YN^INHMGD1(X,1)
;Template
S X=$P(INY,U,6),INSG("TP")=$E($P(INY,U,6),1,30)
;name of routine to run after lookup.
S X=$G(^INTHL7M(INMSG,1,INSEG,3)),INSG("RT")=$E(X,1,100)
;
S INDHDR=0 ;Did we just write the header
I IO=IO(0)!'INPAGE!($Y>(IOSL-13)) S INDHDR=1 D HEADER^INHMGD1 Q:INEXIT
;Output seg header
S DATA="""=====Segment Name"_$$DASH^INHMGD1(32+INOFF,"=")
S DATA=DATA_"ID=====Seq No==Req==Rep==OF=="""
I IO'=IO(0)!($Y<(IOSL-13)),'INDHDR S DATA="!,"_DATA
D WRITE^INHMGD1
;
S DATA="INSG(""NM""),?(49+INOFF+ING),INSG(""NM"",1)" ;seg Name and ID
S DATA=DATA_",?(56+INOFF+ING),$J(INSG(""NM"",2),0,1)" ;seg seq. number
S DATA=DATA_",?(64+INOFF+ING),INSG(""NM"",9)" ;seg is required?
S DATA=DATA_",?(69+INOFF+ING),INSG(""NM"",3)" ;seg is repeatable?
S DATA=DATA_",?(74+INOFF+ING),INSG(""NM"",4)" ;OTHER FILE?
D WRITE^INHMGD1
;
I $G(INSG("PS"))]"" D
.S DATA="?ING+8,""Parent Segment:"",?ING+24,INSG(""PS"")"
.D WRITE^INHMGD1
I $G(INSG("FL"))]"" D
.S DATA="?ING+18,""File:"",?ING+24,INSG(""FL"")"
.D WRITE^INHMGD1
I $G(INSG("MF"))]"" D
.S DATA="?ING+8,""Multiple Field:"",?ING+24,INSG(""MF"")"
.D WRITE^INHMGD1
I $G(INSG("UD"))]"" D
.S DATA="?ING+4,""User-Defined Index:"",?ING+24,INSG(""UD"")"
.D WRITE^INHMGD1
I $G(INSG("LP"))]"" D
.S DATA="?ING+6,""Lookup Parameter:"",?ING+24,INSG(""LP"")"
.D WRITE^INHMGD1
I $G(INSG("ML"))]"" D
.S DATA="?ING+12,""Make Links:"",?ING+24,INSG(""ML"")"
.D WRITE^INHMGD1
I $G(INSG("TP"))]"" D
.S DATA="?ING+14,""Template:"",?ING+24,INSG(""TP"")"
.D WRITE^INHMGD1
I $G(INSG("RT"))]"" D
.S DATA="?ING+15,""Routine:"",?ING+24,INSG(""RT"")"
.D WRITE^INHMGD1
S DATA="$C(32)" D WRITE^INHMGD1
S INHF2=-1
;
S INF=""
; order through the "AS" INF node (this is the sequence number)
F S INF=$O(^INTHL7S(INSEG,1,"AS",INF)) Q:'INF!$G(DUOUT) D
.S INX=0
.; now get the index number (INX) that the sequence number points to
.F S INX=$O(^INTHL7S(INSEG,1,"AS",INF,INX)) Q:'INX!INEXIT D
..S X=INX,INFLD(1)=^INTHL7S(INSEG,1,X,0)
..D:$D(^INTHL7F(+INFLD(1),0)) FIELD^INHMGD3(X,INF,FLVL,.FILE,.INP)
;
;pick up parent segments
I $D(^INTHL7M(INMSG,1,"ASP",INSEG)) D
.S INCH=0
.F S INCH=$O(^INTHL7M(INMSG,1,"ASP",INSEG,INCH)) Q:'INCH D
..S INX=0 F S INX=$O(^INTHL7M(INMSG,1,"ASP",INSEG,INCH,INX)) Q:'INX D SEG(INX,.FLVL,.FILE,.INP,.INERN)
;
;adjust file level
I INWHILE S FLVL=FLVL-1
Q
INHMGD2 ;CAR; 27 Jun 97 15:34;HL7 MESSAGING - PROCESS SEGMENT
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;COPYRIGHT 1991-2000 SAIC
+3 ;
+4 ; MODULE NAME:
+5 ; HL7 Messaging - Process Segment
+6 ;
+7 ; PURPOSE:
+8 ; Module INHMGD2 is used to order through the fields
+9 ; pointed to by ^INTHL7M(INDA,1,SEG,0)
+10 ;
SEG(INSEG,FLVL,FILE,INP,INERN) ;Process segment
+1 ; Input:
+2 ; INSEG= Seg is the index to the ^INTHL7M(INDA,1,SEG,0) node, and
+3 ; is used to retrieve INMSG(1).
+4 ; FLVL = Current level in FILE.
+5 ; FILE = Stacks file# references.
+6 ; INP = The output array used to create a data file for export to
+7 ; a tab delimited text file.
+8 ; INERN= An incrementing counter to prevent multiple error msgs
+9 ; Output:
+10 ; INERN,INP and FILE
+11 ;
+12 ;get next segment descriptor.
+13 SET INSEG(1)=$GET(^INTHL7M(INMSG,1,INSEG,0))
SET INSEG=+INSEG(1)
SET INSEG(2)=INSEG
+14 IF '$DATA(^INTHL7S(INSEG,0))
QUIT
+15 ;
+16 ;quit if common or MSH segment?
+17 SET INSEG(0)=^INTHL7S(INSEG,0)
+18 IF 'INCSG
IF "MSH,PID,"[($PIECE(INSEG(0),U,2)_",")
QUIT
+19 ;
+20 ;check for MULTIPLE, OTHER.
+21 NEW DIC,INWHILE,INCH,X,INX,Y,INUDI,INDHDR
+22 SET INWHILE=$PIECE(INSEG(1),U,3)!$PIECE(INSEG(1),U,4)
+23 ;user defined index
SET INUDI=$PIECE(INSEG(1),U,12)
+24 IF INWHILE
IF (INUDI="")
Begin DoDot:1
+25 ;MULTIPLE
IF $PIECE(INSEG(1),U,3)
IF '$PIECE(INSEG(1),U,4)
Begin DoDot:2
+26 KILL DIC
SET (X,INX)=$PIECE(INSEG(1),U,8)
+27 SET DIC="^DD("_+FILE(FLVL)_","
SET DIC(0)="FMZ"
+28 SET DIC("S")="I $P(^(0),U,2)"
DO ^DIC
+29 IF Y<0
Begin DoDot:3
+30 ;bogus segs ok in Parse Only msg.
SET INWHILE=0
IF INPARS
QUIT
+31 SET INERN=INERN+.001
+32 SET ^UTILITY("INHMGD",$JOB,"E",INMSG,INSEG,INERN)=+FILE(FLVL)_U_"Multiple "_INX_" does not exist"
End DoDot:3
QUIT
+33 SET FLVL=FLVL+1
SET FILE(FLVL)=+$PIECE(Y(0),U,2)
SET INWHILE(1)=$PIECE(Y,U,2)
End DoDot:2
QUIT
+34 SET FLVL=FLVL+1
SET FILE(FLVL)=+$PIECE(INSEG(1),U,5)
+35 IF 'FILE(FLVL)
Begin DoDot:2
+36 SET INX="No OTHER file specified"
SET INERN=INERN+.001
+37 SET ^UTILITY("INHMGD",$JOB,"E",INMSG,INERN)=+FILE(FLVL)_U_INX
End DoDot:2
SET FLVL=FLVL-1
SET INWHILE=0
QUIT
+38 SET INWHILE(1)=$PIECE(^DIC(+FILE(FLVL),0),U)
End DoDot:1
+39 ;
+40 NEW INF,INY,INREPEAT,INFLD
+41 SET INY=INSEG(0)
+42 ;Segment Name
SET INSG("NM")=$EXTRACT($PIECE(INY,U),1,45)
+43 ;Segment ID
SET INSG("NM",1)=$EXTRACT($PIECE(INY,U,2),1,6)
+44 ;
+45 ;from ^INTHL7M(INMSG,1,INX,0)
SET INY=INSEG(1)
+46 ;Sequence Number
SET INSG("NM",2)=$PIECE(INY,U,2)
+47 ;Required?
SET INSG("NM",9)=$$YN^INHMGD1($PIECE(INY,U,9),1)
+48 ;Parent Segment?
+49 SET X=$PIECE(INY,U,11)
+50 SET INSG("PS")=$EXTRACT($SELECT(X="":X,$DATA(^INTHL7S(X,0))#2:$PIECE(^(0),U),1:" "_X),1,45)
+51 SET INREPEAT=$PIECE(INY,U,3)
+52 ;Repeatable?
SET INSG("NM",3)=$$YN^INHMGD1(INREPEAT,1)
+53 ;OTHER Flag & File Name
+54 SET INSG("NM",4)=$$YN^INHMGD1($PIECE(INY,U,4),1)
+55 SET X=$PIECE(INY,U,5)
+56 SET INSG("FL")=$EXTRACT($SELECT(X="":X,$DATA(^DIC(X,0))#2:$PIECE(^(0),U),1:" "_X),1,45)
+57 ;Multiple Field Name
SET INSG("MF")=$EXTRACT($PIECE(INY,U,8),1,30)
+58 IF +INSG("MF")=INSG("MF")
Begin DoDot:1
+59 KILL DIC
SET X=INSG("MF")
SET DIC="^DD("_+FILE(FLVL)_","
SET DIC(0)="FMZ"
+60 SET DIC("S")="I $P(^(0),U,2)"
DO ^DIC
IF Y<0
QUIT
+61 SET INSG("MF")=$EXTRACT(Y(0,0),1,30)
End DoDot:1
+62 SET INSG("UD")=$PIECE(INY,U,12)
+63 ;
+64 ;cleanup INP leaving flag & Message Name
+65 IF INP
Begin DoDot:1
+66 ;$P2 seg ID
SET INP=$PIECE(INP,TAB)_TAB_$PIECE(INSEG(0),U,2)
+67 ; $P3 seg name
SET INP=INP_TAB_$PIECE(INSEG(0),U)
+68 ; $P4 seg seq#
SET INP=INP_TAB_INSG("NM",2)
+69 ;$P5 repeatable
SET INP=INP_TAB_$SELECT(INSG("NM",3)["Y":"Y",1:"")
+70 ; $P6 Multiple Field Name
SET INP=INP_TAB_INSG("MF")
+71 ;$P7 Seg Reqd (Y/"")
SET INP=INP_TAB_$SELECT(INSG("NM",9)["Y":"Y",1:"")
+72 ; $P8 Parent Seg#
SET INP=INP_TAB_INSG("PS")
End DoDot:1
+73 ;
+74 ;Lookup Params
+75 SET INSG("LP")=$$LKPRM^INHMGD1($PIECE(INY,U,7))
+76 ;Make Links
+77 SET X=$PIECE(INY,U,10)
SET INSG("ML")=$$YN^INHMGD1(X,1)
+78 ;Template
+79 SET X=$PIECE(INY,U,6)
SET INSG("TP")=$EXTRACT($PIECE(INY,U,6),1,30)
+80 ;name of routine to run after lookup.
+81 SET X=$GET(^INTHL7M(INMSG,1,INSEG,3))
SET INSG("RT")=$EXTRACT(X,1,100)
+82 ;
+83 ;Did we just write the header
SET INDHDR=0
+84 IF IO=IO(0)!'INPAGE!($Y>(IOSL-13))
SET INDHDR=1
DO HEADER^INHMGD1
IF INEXIT
QUIT
+85 ;Output seg header
+86 SET DATA="""=====Segment Name"_$$DASH^INHMGD1(32+INOFF,"=")
+87 SET DATA=DATA_"ID=====Seq No==Req==Rep==OF=="""
+88 IF IO'=IO(0)!($Y<(IOSL-13))
IF 'INDHDR
SET DATA="!,"_DATA
+89 DO WRITE^INHMGD1
+90 ;
+91 ;seg Name and ID
SET DATA="INSG(""NM""),?(49+INOFF+ING),INSG(""NM"",1)"
+92 ;seg seq. number
SET DATA=DATA_",?(56+INOFF+ING),$J(INSG(""NM"",2),0,1)"
+93 ;seg is required?
SET DATA=DATA_",?(64+INOFF+ING),INSG(""NM"",9)"
+94 ;seg is repeatable?
SET DATA=DATA_",?(69+INOFF+ING),INSG(""NM"",3)"
+95 ;OTHER FILE?
SET DATA=DATA_",?(74+INOFF+ING),INSG(""NM"",4)"
+96 DO WRITE^INHMGD1
+97 ;
+98 IF $GET(INSG("PS"))]""
Begin DoDot:1
+99 SET DATA="?ING+8,""Parent Segment:"",?ING+24,INSG(""PS"")"
+100 DO WRITE^INHMGD1
End DoDot:1
+101 IF $GET(INSG("FL"))]""
Begin DoDot:1
+102 SET DATA="?ING+18,""File:"",?ING+24,INSG(""FL"")"
+103 DO WRITE^INHMGD1
End DoDot:1
+104 IF $GET(INSG("MF"))]""
Begin DoDot:1
+105 SET DATA="?ING+8,""Multiple Field:"",?ING+24,INSG(""MF"")"
+106 DO WRITE^INHMGD1
End DoDot:1
+107 IF $GET(INSG("UD"))]""
Begin DoDot:1
+108 SET DATA="?ING+4,""User-Defined Index:"",?ING+24,INSG(""UD"")"
+109 DO WRITE^INHMGD1
End DoDot:1
+110 IF $GET(INSG("LP"))]""
Begin DoDot:1
+111 SET DATA="?ING+6,""Lookup Parameter:"",?ING+24,INSG(""LP"")"
+112 DO WRITE^INHMGD1
End DoDot:1
+113 IF $GET(INSG("ML"))]""
Begin DoDot:1
+114 SET DATA="?ING+12,""Make Links:"",?ING+24,INSG(""ML"")"
+115 DO WRITE^INHMGD1
End DoDot:1
+116 IF $GET(INSG("TP"))]""
Begin DoDot:1
+117 SET DATA="?ING+14,""Template:"",?ING+24,INSG(""TP"")"
+118 DO WRITE^INHMGD1
End DoDot:1
+119 IF $GET(INSG("RT"))]""
Begin DoDot:1
+120 SET DATA="?ING+15,""Routine:"",?ING+24,INSG(""RT"")"
+121 DO WRITE^INHMGD1
End DoDot:1
+122 SET DATA="$C(32)"
DO WRITE^INHMGD1
+123 SET INHF2=-1
+124 ;
+125 SET INF=""
+126 ; order through the "AS" INF node (this is the sequence number)
+127 FOR
SET INF=$ORDER(^INTHL7S(INSEG,1,"AS",INF))
IF 'INF!$GET(DUOUT)
QUIT
Begin DoDot:1
+128 SET INX=0
+129 ; now get the index number (INX) that the sequence number points to
+130 FOR
SET INX=$ORDER(^INTHL7S(INSEG,1,"AS",INF,INX))
IF 'INX!INEXIT
QUIT
Begin DoDot:2
+131 SET X=INX
SET INFLD(1)=^INTHL7S(INSEG,1,X,0)
+132 IF $DATA(^INTHL7F(+INFLD(1),0))
DO FIELD^INHMGD3(X,INF,FLVL,.FILE,.INP)
End DoDot:2
End DoDot:1
+133 ;
+134 ;pick up parent segments
+135 IF $DATA(^INTHL7M(INMSG,1,"ASP",INSEG))
Begin DoDot:1
+136 SET INCH=0
+137 FOR
SET INCH=$ORDER(^INTHL7M(INMSG,1,"ASP",INSEG,INCH))
IF 'INCH
QUIT
Begin DoDot:2
+138 SET INX=0
FOR
SET INX=$ORDER(^INTHL7M(INMSG,1,"ASP",INSEG,INCH,INX))
IF 'INX
QUIT
DO SEG(INX,.FLVL,.FILE,.INP,.INERN)
End DoDot:2
End DoDot:1
+139 ;
+140 ;adjust file level
+141 IF INWHILE
SET FLVL=FLVL-1
+142 QUIT
