- 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 ;