APCLSIH1 ;cmi/flag/maw - APCL ILI CDC HL7 Export 5/12/2010 9:26:17 AM
;;3.0;IHS PCC REPORTS;**29,30**;FEB 05, 1997;Build 27
;
;
;
; Create PID segment
PIDLAB(R) ;EP
N PID,PID3,PID8,PID7
S PID=$G(^APCLDATA($J,R,"PID"))
S PID3=$P(PID,U)
S PID8=$P(PID,U,2)
S PID7=$P(PID,U,3)
S HLQ=HL1("Q")
D SET(.ARY,"PID",0)
D SET(.ARY,1,1)
D SET(.ARY,PID3,3)
D SET(.ARY,PID8,8)
D SET(.ARY,PID7,7)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
ZIDLAB(R) ;EP -- create the ZID segment
N ZID,ZID1
S ZID=$G(^APCLDATA($J,R,"ZID"))
S ZID1=$P(ZID,U)
D SET(.ARY,"ZID",0)
D SET(.ARY,1,1)
D SET(.ARY,ZID1,2)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
PV1LAB(R) ;EP -- setup the PV1 LAB segment
N PV1,PV13,PV132,PV115,PV144,PV145
S PV1=$G(^APCLDATA($J,R,"PV1"))
S PV13=$P(PV1,U,1)
S PV132=$P(PV1,U,2)
S PV115=$P(PV1,U,3)
S PV144=$P(PV1,U,4)
S PV145=$P(PV1,U,5)
D SET(.ARY,"PV1",0)
D SET(.ARY,1,1)
D SET(.ARY,PV13,3,1)
D SET(.ARY,PV132,3,2)
D SET(.ARY,PV115,15)
D SET(.ARY,PV144,44)
D SET(.ARY,PV145,45)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
DG1LAB(R) ;EP -- set the repeating DG1
N BDA,DG1,DG13
S BDA=0 F S BDA=$O(^APCLDATA($J,R,"DG1",BDA)) Q:'BDA D
. S DG1=$G(^APCLDATA($J,R,"DG1",BDA))
. S DG13=$P(DG1,U)
. S APCLFCNT=APCLFCNT+1
. D SET(.ARY,"FT1",0)
. D SET(.ARY,APCLFCNT,1)
. D SET(.ARY,DG13,19)
. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
PR1LAB(R) ;EP -- set the repeating DG1
N BDA,PR1,PR13
S BDA=0 F S BDA=$O(^APCLDATA($J,R,"PR1",BDA)) Q:'BDA D
. S PR1=$G(^APCLDATA($J,R,"PR1",BDA))
. S PR13=$P(PR1,U)
. S APCLFCNT=APCLFCNT+1
. D SET(.ARY,"FT1",0)
. D SET(.ARY,+$G(APCLFCNT),1)
. D SET(.ARY,PR13,25)
. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
OBXLAB(R) ;EP -- setup the ILI OBX segment
N BDA,OBX,OBX1,OBX2,OBX31,OBX32,OBX5
S BDA=0 F S BDA=$O(^APCLDATA($J,R,"OBX",BDA)) Q:'BDA D
. S OBX=$G(^APCLDATA($J,R,"OBX",BDA))
. S OBX1=$P(OBX,U)
. S OBX2=$P(OBX,U,2)
. S OBX3=$P(OBX,U,3)
. I OBX3'="TMP" D
.. S OBX31=$P(OBX3,"~")
.. S OBX32=$P(OBX3,"~",2)
. S OBX5=$P(OBX,U,4)
. D SET(.ARY,"OBX",0)
. D SET(.ARY,OBX1,1)
. D SET(.ARY,OBX2,2)
. I '$G(OBX31) D SET(.ARY,OBX3,3)
. I $G(OBX31) D
.. I $G(OBX31)]"" D SET(.ARY,OBX31,3,1)
.. D SET(.ARY,OBX32,3,2)
. D SET(.ARY,OBX5,5)
. S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
Q
;
SET(ARY,V,F,C,S,R) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
;
APCLSIH1 ;cmi/flag/maw - APCL ILI CDC HL7 Export 5/12/2010 9:26:17 AM
+1 ;;3.0;IHS PCC REPORTS;**29,30**;FEB 05, 1997;Build 27
+2 ;
+3 ;
+4 ;
+5 ; Create PID segment
PIDLAB(R) ;EP
+1 NEW PID,PID3,PID8,PID7
+2 SET PID=$GET(^APCLDATA($JOB,R,"PID"))
+3 SET PID3=$PIECE(PID,U)
+4 SET PID8=$PIECE(PID,U,2)
+5 SET PID7=$PIECE(PID,U,3)
+6 SET HLQ=HL1("Q")
+7 DO SET(.ARY,"PID",0)
+8 DO SET(.ARY,1,1)
+9 DO SET(.ARY,PID3,3)
+10 DO SET(.ARY,PID8,8)
+11 DO SET(.ARY,PID7,7)
+12 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+13 QUIT
+14 ;
ZIDLAB(R) ;EP -- create the ZID segment
+1 NEW ZID,ZID1
+2 SET ZID=$GET(^APCLDATA($JOB,R,"ZID"))
+3 SET ZID1=$PIECE(ZID,U)
+4 DO SET(.ARY,"ZID",0)
+5 DO SET(.ARY,1,1)
+6 DO SET(.ARY,ZID1,2)
+7 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+8 QUIT
+9 ;
PV1LAB(R) ;EP -- setup the PV1 LAB segment
+1 NEW PV1,PV13,PV132,PV115,PV144,PV145
+2 SET PV1=$GET(^APCLDATA($JOB,R,"PV1"))
+3 SET PV13=$PIECE(PV1,U,1)
+4 SET PV132=$PIECE(PV1,U,2)
+5 SET PV115=$PIECE(PV1,U,3)
+6 SET PV144=$PIECE(PV1,U,4)
+7 SET PV145=$PIECE(PV1,U,5)
+8 DO SET(.ARY,"PV1",0)
+9 DO SET(.ARY,1,1)
+10 DO SET(.ARY,PV13,3,1)
+11 DO SET(.ARY,PV132,3,2)
+12 DO SET(.ARY,PV115,15)
+13 DO SET(.ARY,PV144,44)
+14 DO SET(.ARY,PV145,45)
+15 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+16 QUIT
+17 ;
DG1LAB(R) ;EP -- set the repeating DG1
+1 NEW BDA,DG1,DG13
+2 SET BDA=0
FOR
SET BDA=$ORDER(^APCLDATA($JOB,R,"DG1",BDA))
IF 'BDA
QUIT
Begin DoDot:1
+3 SET DG1=$GET(^APCLDATA($JOB,R,"DG1",BDA))
+4 SET DG13=$PIECE(DG1,U)
+5 SET APCLFCNT=APCLFCNT+1
+6 DO SET(.ARY,"FT1",0)
+7 DO SET(.ARY,APCLFCNT,1)
+8 DO SET(.ARY,DG13,19)
+9 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:1
+10 QUIT
+11 ;
PR1LAB(R) ;EP -- set the repeating DG1
+1 NEW BDA,PR1,PR13
+2 SET BDA=0
FOR
SET BDA=$ORDER(^APCLDATA($JOB,R,"PR1",BDA))
IF 'BDA
QUIT
Begin DoDot:1
+3 SET PR1=$GET(^APCLDATA($JOB,R,"PR1",BDA))
+4 SET PR13=$PIECE(PR1,U)
+5 SET APCLFCNT=APCLFCNT+1
+6 DO SET(.ARY,"FT1",0)
+7 DO SET(.ARY,+$GET(APCLFCNT),1)
+8 DO SET(.ARY,PR13,25)
+9 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:1
+10 QUIT
+11 ;
OBXLAB(R) ;EP -- setup the ILI OBX segment
+1 NEW BDA,OBX,OBX1,OBX2,OBX31,OBX32,OBX5
+2 SET BDA=0
FOR
SET BDA=$ORDER(^APCLDATA($JOB,R,"OBX",BDA))
IF 'BDA
QUIT
Begin DoDot:1
+3 SET OBX=$GET(^APCLDATA($JOB,R,"OBX",BDA))
+4 SET OBX1=$PIECE(OBX,U)
+5 SET OBX2=$PIECE(OBX,U,2)
+6 SET OBX3=$PIECE(OBX,U,3)
+7 IF OBX3'="TMP"
Begin DoDot:2
+8 SET OBX31=$PIECE(OBX3,"~")
+9 SET OBX32=$PIECE(OBX3,"~",2)
End DoDot:2
+10 SET OBX5=$PIECE(OBX,U,4)
+11 DO SET(.ARY,"OBX",0)
+12 DO SET(.ARY,OBX1,1)
+13 DO SET(.ARY,OBX2,2)
+14 IF '$GET(OBX31)
DO SET(.ARY,OBX3,3)
+15 IF $GET(OBX31)
Begin DoDot:2
+16 IF $GET(OBX31)]""
DO SET(.ARY,OBX31,3,1)
+17 DO SET(.ARY,OBX32,3,2)
End DoDot:2
+18 DO SET(.ARY,OBX5,5)
+19 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
End DoDot:1
+20 QUIT
+21 ;
SET(ARY,V,F,C,S,R) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
+3 ;
