VAFCSB ;BIR/CMC-CONT ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;8/21/06
;;5.3;Registration;**707,756,1015**;Aug 13, 1993;Build 21
;
;Reference to $$XAMDT^RAO7UTL1 is supported by IA #4875
;Reference to RESUTLS^LRPXAPI is supported by IA #4245
;
PV2() ;build pv2 segment
N PV2,LSTA,APPT,VASD,VAIP,VARP,VAROOT
S PV2=""
;get next outpatient appointment
K ^UTILITY("VASD",$J) S VASD("F")=DT D SDA^VADPT
S APPT=$P($G(^UTILITY("VASD",$J,1,"I")),"^")
I APPT'="" S $P(PV2,HL("FS"),9)=$$HLDATE^HLFNC(APPT)
;GET LAST ADMISSION DATE
K VAIP S VAIP("D")="LAST",VAIP("M")=0 D IN5^VADPT
I VAIP(2)="1^ADMISSION" S $P(PV2,HL("FS"),15)=$$HLDATE^HLFNC($P(VAIP(3),"^"))
;get last registration
S VAROOT="VARP"
D REG^VADPT
I $D(VARP(1,"I")),$G(VARP(1,"I"))>0 S $P(PV2,HL("FS"),46)=$$HLDATE^HLFNC($P(VARP(1,"I"),"^"),"DT"),$P(PV2,HL("FS"),24)="CR"
;**756 ^ ONLY RETURN DATE FOR LAST REGISTRATION AS HL7 STANDARD CAN ONLY HAVE DATE
I PV2'="" S PV2="PV2"_HL("FS")_PV2
Q PV2
PHARA() ;build obx to show active prescriptions
N RET S RET=""
I '$$PATCH^XPDUTL("PSS*1.0*101") Q RET
N PHARM,DGLIST
S PHARM="" D PROF^PSO52API(DFN,"DGLIST")
I +$G(^TMP($J,"DGLIST",DFN,0))>0 S PHARM="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"ACTIVE PRESCRIPTIONS"_HL("FS")_HL("FS")_"Y"
;**756 CE added as the data type
Q PHARM
LABE() ;BUILD OBX FOR LAST LAB TEST DATE
N OBX S OBX=""
I '$$PATCH^XPDUTL("LR*5.2*295") Q OBX
N LAB,LAB2,EN
S LAB="" K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"C")
S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB=$P($G(^TMP("DGLAB",$J,EN)),"^")
K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"A")
S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2
K ^TMP("DGLAB",$J) D RESULTS^LRPXAPI("DGLAB",DFN,"M")
S EN=$O(^TMP("DGLAB",$J,"")) I EN'="" S LAB2=$P($G(^TMP("DGLAB",$J,EN)),"^") I LAB2>LAB S LAB=LAB2
I LAB'="" D
.S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type
.S $P(OBX,HL("FS"),3)="LAST LAB TEST DATE/TIME"
.S $P(OBX,HL("FS"),11)="F"
.S $P(OBX,HL("FS"),14)=$$HLDATE^HLFNC(LAB)
.S OBX="OBX"_HL("FS")_OBX
Q OBX
RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
N RET S RET=""
I '$$PATCH^XPDUTL("RA*5.0*76") Q RET
N RAD,RADE
S RAD="",RADE=$$XAMDT^RAO7UTL1(DFN) I +RADE<1 Q RAD
I +RADE>0 D
.S $P(OBX,HL("FS"),2)="TS" ;**756 added the data type
.S $P(RAD,HL("FS"),3)="LAST RADIOLOGY EXAM DATE/TIME"
.S $P(RAD,HL("FS"),11)="F"
.S $P(RAD,HL("FS"),14)=$$HLDATE^HLFNC(RADE)
.S RAD="OBX"_HL("FS")_RAD
Q RAD
PD1() ;BUILD PD1 segment
;PREFERRED FACILITY -- NOT GOING TO BE PASSED PER IMDQ 9/7/06
N TEAM,PD1
S PD1=""
;S TEAM=$$PREF^DGENPTA(DFN)
;I TEAM'="" S PD1="PD1"_HL("FS")_HL("FS")_HL("FS")_$$STA^XUAF4(TEAM)
Q PD1
PV1() ;BUILD PV1 SEGMENT
;CURRENTLY ADMITTED?
N PV1,VAINDT
S PV1=""
S VAINDT=DT
D INP^VADPT
I $G(VAIN(1))'="" S $P(PV1,HL("FS"),44)=$$HLDATE^HLFNC($P(VAIN(7),"^")),PV1="PV1"_HL("FS")_PV1
K VAIN
Q PV1
VAFCSB ;BIR/CMC-CONT ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;8/21/06
+1 ;;5.3;Registration;**707,756,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;Reference to $$XAMDT^RAO7UTL1 is supported by IA #4875
+4 ;Reference to RESUTLS^LRPXAPI is supported by IA #4245
+5 ;
PV2() ;build pv2 segment
+1 NEW PV2,LSTA,APPT,VASD,VAIP,VARP,VAROOT
+2 SET PV2=""
+3 ;get next outpatient appointment
+4 KILL ^UTILITY("VASD",$JOB)
SET VASD("F")=DT
DO SDA^VADPT
+5 SET APPT=$PIECE($GET(^UTILITY("VASD",$JOB,1,"I")),"^")
+6 IF APPT'=""
SET $PIECE(PV2,HL("FS"),9)=$$HLDATE^HLFNC(APPT)
+7 ;GET LAST ADMISSION DATE
+8 KILL VAIP
SET VAIP("D")="LAST"
SET VAIP("M")=0
DO IN5^VADPT
+9 IF VAIP(2)="1^ADMISSION"
SET $PIECE(PV2,HL("FS"),15)=$$HLDATE^HLFNC($PIECE(VAIP(3),"^"))
+10 ;get last registration
+11 SET VAROOT="VARP"
+12 DO REG^VADPT
+13 IF $DATA(VARP(1,"I"))
IF $GET(VARP(1,"I"))>0
SET $PIECE(PV2,HL("FS"),46)=$$HLDATE^HLFNC($PIECE(VARP(1,"I"),"^"),"DT")
SET $PIECE(PV2,HL("FS"),24)="CR"
+14 ;**756 ^ ONLY RETURN DATE FOR LAST REGISTRATION AS HL7 STANDARD CAN ONLY HAVE DATE
+15 IF PV2'=""
SET PV2="PV2"_HL("FS")_PV2
+16 QUIT PV2
PHARA() ;build obx to show active prescriptions
+1 NEW RET
SET RET=""
+2 IF '$$PATCH^XPDUTL("PSS*1.0*101")
QUIT RET
+3 NEW PHARM,DGLIST
+4 SET PHARM=""
DO PROF^PSO52API(DFN,"DGLIST")
+5 IF +$GET(^TMP($JOB,"DGLIST",DFN,0))>0
SET PHARM="OBX"_HL("FS")_HL("FS")_"CE"_HL("FS")_"ACTIVE PRESCRIPTIONS"_HL("FS")_HL("FS")_"Y"
+6 ;**756 CE added as the data type
+7 QUIT PHARM
LABE() ;BUILD OBX FOR LAST LAB TEST DATE
+1 NEW OBX
SET OBX=""
+2 IF '$$PATCH^XPDUTL("LR*5.2*295")
QUIT OBX
+3 NEW LAB,LAB2,EN
+4 SET LAB=""
KILL ^TMP("DGLAB",$JOB)
DO RESULTS^LRPXAPI("DGLAB",DFN,"C")
+5 SET EN=$ORDER(^TMP("DGLAB",$JOB,""))
IF EN'=""
SET LAB=$PIECE($GET(^TMP("DGLAB",$JOB,EN)),"^")
+6 KILL ^TMP("DGLAB",$JOB)
DO RESULTS^LRPXAPI("DGLAB",DFN,"A")
+7 SET EN=$ORDER(^TMP("DGLAB",$JOB,""))
IF EN'=""
SET LAB2=$PIECE($GET(^TMP("DGLAB",$JOB,EN)),"^")
IF LAB2>LAB
SET LAB=LAB2
+8 KILL ^TMP("DGLAB",$JOB)
DO RESULTS^LRPXAPI("DGLAB",DFN,"M")
+9 SET EN=$ORDER(^TMP("DGLAB",$JOB,""))
IF EN'=""
SET LAB2=$PIECE($GET(^TMP("DGLAB",$JOB,EN)),"^")
IF LAB2>LAB
SET LAB=LAB2
+10 IF LAB'=""
Begin DoDot:1
+11 ;**756 added the data type
SET $PIECE(OBX,HL("FS"),2)="TS"
+12 SET $PIECE(OBX,HL("FS"),3)="LAST LAB TEST DATE/TIME"
+13 SET $PIECE(OBX,HL("FS"),11)="F"
+14 SET $PIECE(OBX,HL("FS"),14)=$$HLDATE^HLFNC(LAB)
+15 SET OBX="OBX"_HL("FS")_OBX
End DoDot:1
+16 QUIT OBX
RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
+1 NEW RET
SET RET=""
+2 IF '$$PATCH^XPDUTL("RA*5.0*76")
QUIT RET
+3 NEW RAD,RADE
+4 SET RAD=""
SET RADE=$$XAMDT^RAO7UTL1(DFN)
IF +RADE<1
QUIT RAD
+5 IF +RADE>0
Begin DoDot:1
+6 ;**756 added the data type
SET $PIECE(OBX,HL("FS"),2)="TS"
+7 SET $PIECE(RAD,HL("FS"),3)="LAST RADIOLOGY EXAM DATE/TIME"
+8 SET $PIECE(RAD,HL("FS"),11)="F"
+9 SET $PIECE(RAD,HL("FS"),14)=$$HLDATE^HLFNC(RADE)
+10 SET RAD="OBX"_HL("FS")_RAD
End DoDot:1
+11 QUIT RAD
PD1() ;BUILD PD1 segment
+1 ;PREFERRED FACILITY -- NOT GOING TO BE PASSED PER IMDQ 9/7/06
+2 NEW TEAM,PD1
+3 SET PD1=""
+4 ;S TEAM=$$PREF^DGENPTA(DFN)
+5 ;I TEAM'="" S PD1="PD1"_HL("FS")_HL("FS")_HL("FS")_$$STA^XUAF4(TEAM)
+6 QUIT PD1
PV1() ;BUILD PV1 SEGMENT
+1 ;CURRENTLY ADMITTED?
+2 NEW PV1,VAINDT
+3 SET PV1=""
+4 SET VAINDT=DT
+5 DO INP^VADPT
+6 IF $GET(VAIN(1))'=""
SET $PIECE(PV1,HL("FS"),44)=$$HLDATE^HLFNC($PIECE(VAIN(7),"^"))
SET PV1="PV1"_HL("FS")_PV1
+7 KILL VAIN
+8 QUIT PV1
