PSJBCBU.m

PSJBCBU ;BIR/LDT-RETURN INFORMATION FOR AN ORDER IN HL7 FORMAT FOR BCMA CONTINGENCY PLAN;16 Mar 99 / 10:59 AM

 ;;5.0; INPATIENT MEDICATIONS ;**102**;16 DEC 97

 ;

 ; Reference to ^PS(55 is supported by DBIA 2191.

 ; Reference to ^%DTC is supported by DBIA 10000.

 ; Usage of this routine by BCMA BACKUP Software is supported by DBIA 3876.

 ;

EN(DFN,ON,PSJNAME)         ; return detail data for Inpatient Meds.

 ;Input

 ;               DFN - Patient's IEN

 ;               ON - Order number for patient including "U" for Unit Dose, "V" for IV, and "P" for pending orders

 ;               PSJNAME - Array name to return information in

 N PSJBCBU S PSJBCBU=1

 I $G(ON)["U",$D(^PS(55,+$G(DFN),5,+ON,0)) D EN1^PSJHL2(DFN,"XX",ON)

 I $G(ON)["V",$D(^PS(55,+$G(DFN),"IV",+ON,0)) D EN1^PSJHL2(DFN,"XX",ON)

 I $G(ON)["P",$D(^PS(53.1,+ON,0)),$P($G(^PS(53.1,+ON,0)),"^",15)=DFN D EN1^PSJHL2(DFN,"XX",ON)

 I '$D(PSJNAME) S PSJNAME(0)=-1

 K ^TMP("PSJHLS",$J,"PS")

 Q

 ;

EN2(DFN,BDT)         ; return condensed list of inpat meds

 K ^TMP("PSJBU",$J)

 NEW FON,ON,WBDT,Y,%

 D:+$G(DFN) ORDER

 I '$D(^TMP("PSJBU",$J,1,0)) S ^(0)=-1

 K PSJINX

 Q

ORDER ;Loop thru the orders.

 I '+$G(BDT) D NOW^%DTC S BDT=%

 I BDT'["." S BDT=BDT_".0001"

 S PSJINX=0

 ;* U/D orders

 S WBDT=BDT

 F  S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT  D

 . F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON  S FON=ON_"U" D TMP

 ;* IV orders

 S WBDT=BDT

 F  S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT  D

 . F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON  S FON=ON_"V" D TMP

 ;* Pending orders

 F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON  D

 . S FON=ON_"P" D TMP

 Q

 ;

TMP ;* Setup ^TMP that have common fields between IV and U/D

 S PSJINX=PSJINX+1

 S ^TMP("PSJBU",$J,PSJINX,0)=DFN_U_+ON_U_FON

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSJBCBU   1830     printed  Mar 13, 2025@21:11:05                                                                                                                                                                                                     Page 2

PSJBCBU   ;BIR/LDT-RETURN INFORMATION FOR AN ORDER IN HL7 FORMAT FOR BCMA CONTINGENCY PLAN;16 Mar 99 / 10:59 AM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**102**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PS(55 is supported by DBIA 2191.

 +4       ; Reference to ^%DTC is supported by DBIA 10000.

 +5       ; Usage of this routine by BCMA BACKUP Software is supported by DBIA 3876.

 +6       ;

EN(DFN,ON,PSJNAME) ; return detail data for Inpatient Meds.

 +1       ;Input

 +2       ;               DFN - Patient's IEN

 +3       ;               ON - Order number for patient including "U" for Unit Dose, "V" for IV, and "P" for pending orders

 +4       ;               PSJNAME - Array name to return information in

 +5        NEW PSJBCBU

           SET PSJBCBU=1

 +6        IF $GET(ON)["U"

               IF $DATA(^PS(55,+$GET(DFN),5,+ON,0))

                   DO EN1^PSJHL2(DFN,"XX",ON)

 +7        IF $GET(ON)["V"

               IF $DATA(^PS(55,+$GET(DFN),"IV",+ON,0))

                   DO EN1^PSJHL2(DFN,"XX",ON)

 +8        IF $GET(ON)["P"

               IF $DATA(^PS(53.1,+ON,0))

                   IF $PIECE($GET(^PS(53.1,+ON,0)),"^",15)=DFN

                       DO EN1^PSJHL2(DFN,"XX",ON)

 +9        IF '$DATA(PSJNAME)

               SET PSJNAME(0)=-1

 +10       KILL ^TMP("PSJHLS",$JOB,"PS")

 +11       QUIT 

 +12      ;

EN2(DFN,BDT) ; return condensed list of inpat meds

 +1        KILL ^TMP("PSJBU",$JOB)

 +2        NEW FON,ON,WBDT,Y,%

 +3        if +$GET(DFN)

               DO ORDER

 +4        IF '$DATA(^TMP("PSJBU",$JOB,1,0))

               SET ^(0)=-1

 +5        KILL PSJINX

 +6        QUIT 

ORDER     ;Loop thru the orders.

 +1        IF '+$GET(BDT)

               DO NOW^%DTC

               SET BDT=%

 +2        IF BDT'["."

               SET BDT=BDT_".0001"

 +3        SET PSJINX=0

 +4       ;* U/D orders

 +5        SET WBDT=BDT

 +6        FOR 

               SET WBDT=$ORDER(^PS(55,DFN,5,"AUS",WBDT))

               if 'WBDT

                   QUIT 

               Begin DoDot:1

 +7                FOR ON=0:0

                       SET ON=$ORDER(^PS(55,DFN,5,"AUS",WBDT,ON))

                       if 'ON

                           QUIT 

                       SET FON=ON_"U"

                       DO TMP

               End DoDot:1

 +8       ;* IV orders

 +9        SET WBDT=BDT

 +10       FOR 

               SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))

               if 'WBDT

                   QUIT 

               Begin DoDot:1

 +11               FOR ON=0:0

                       SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))

                       if 'ON

                           QUIT 

                       SET FON=ON_"V"

                       DO TMP

               End DoDot:1

 +12      ;* Pending orders

 +13       FOR PST="P","N"

               FOR ON=0:0

                   SET ON=$ORDER(^PS(53.1,"AS",PST,DFN,ON))

                   if 'ON

                       QUIT 

                   Begin DoDot:1

 +14                   SET FON=ON_"P"

                       DO TMP

                   End DoDot:1

 +15       QUIT 

 +16      ;

TMP       ;* Setup ^TMP that have common fields between IV and U/D

 +1        SET PSJINX=PSJINX+1

 +2        SET ^TMP("PSJBU",$JOB,PSJINX,0)=DFN_U_+ON_U_FON

 +3        QUIT