PSJBCMA3.m

PSJBCMA3 ;BIR/JLC-ADD BCMA STATUS UPDATE TO PS(55 ;21 FEB 01

 ;;5.0; INPATIENT MEDICATIONS ;**58,91,190**;16 DEC 97;Build 12

 ;

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

 ;

EN(DFN,ON,BCID,STATUS,DATE)         ;

 I '$D(DFN)!'$D(ON)!'$D(BCID)!'$D(STATUS)!'$D(DATE) Q

 I '$D(^PS(55,DFN,"IV",ON)) Q

 N PSJBLN,UON

 D SEARCH(ON)

 I $D(PSJBLN) S UON=ON G UPDATE

 S (PON,OPON)=ON F  S PON=$P(^PS(55,DFN,"IV",PON,2),"^",5) S:PON["P" PON=$$PNDV(PON) S PON=+PON Q:'PON  Q:PON=OPON  D SEARCH(PON) Q:$D(PSJBLN)  S OPON=PON

 I $D(PSJBLN) S UON=PON G UPDATE

 Q

SEARCH(ON) S X1=0 F  S X1=$O(^PS(55,DFN,"IV",ON,"BCMA",X1)) Q:X1=""!(X1'?1.N)  I $D(^PS(55,DFN,"IVBCMA",X1)),$P(^(X1,0),"^")=BCID S PSJBLN=X1 Q

 Q

UPDATE K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IVBCMA"",",DA=PSJBLN,DA(1)=DFN,DR="1////"_DATE_";2////"_STATUS

 I STATUS="" S DR="1///@;2///@"

 D ^DIE

 K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IV"",",DA=UON,DA(1)=DFN,DR="144////"_STATUS_";145////"_BCID

 I STATUS="" S DR="144///@;145///@"

 D ^DIE

 Q

 ;

PNDV(PNDON) ;

 Q:PNDON'["P" ""

 N PRV S PRV=""

 F  S PRV=$P($G(^PS(53.1,+PNDON,0)),"^",25) Q:PRV=""!(PRV["V")  S PNDON=PRV

 Q $S(PRV["V":PRV,1:"")

 ;

OTPRN(SCH1) ; Determine if this order is a one-time PRN  PSJ*5*190

 N SCH2 S TYP=""

 ;actual schedule of "x PRN" exists in schedule file. Don't remove PRN from it.

 I $D(^PS(51.1,"AC","PSJ",SCH1)) D  Q $G(TYP)

 .S SCH2=$O(^PS(51.1,"AC","PSJ",SCH1,"")) Q:'$D(^PS(53.1,SCH2))

 .S TYP=$P($G(^PS(51.1,SCH2,0)),"^",5)

 S SCH1=$P(SCH1," PRN",1)

 I '$D(^PS(51.1,"AC","PSJ",SCH1)) Q ""

 S SCH2=$O(^PS(51.1,"AC","PSJ",SCH1,""))

 I '$D(^PS(51.1,SCH2)) Q ""

 Q $P($G(^PS(51.1,SCH2,0)),"^",5)

PSJBCMA3  ;BIR/JLC-ADD BCMA STATUS UPDATE TO PS(55 ;21 FEB 01

 +1       ;;5.0; INPATIENT MEDICATIONS ;**58,91,190**;16 DEC 97;Build 12

 +2       ;

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

 +4       ;

EN(DFN,ON,BCID,STATUS,DATE) ;

 +1        IF '$DATA(DFN)!'$DATA(ON)!'$DATA(BCID)!'$DATA(STATUS)!'$DATA(DATE)

               QUIT 

 +2        IF '$DATA(^PS(55,DFN,"IV",ON))

               QUIT 

 +3        NEW PSJBLN,UON

 +4        DO SEARCH(ON)

 +5        IF $DATA(PSJBLN)

               SET UON=ON

               GOTO UPDATE

 +6        SET (PON,OPON)=ON

           FOR 

               SET PON=$PIECE(^PS(55,DFN,"IV",PON,2),"^",5)

               IF PON["P"

                   SET PON=$$PNDV(PON)

               SET PON=+PON

               IF 'PON

                   QUIT 

               IF PON=OPON

                   QUIT 

               DO SEARCH(PON)

               IF $DATA(PSJBLN)

                   QUIT 

               SET OPON=PON

 +7        IF $DATA(PSJBLN)

               SET UON=PON

               GOTO UPDATE

 +8        QUIT 

SEARCH(ON)  SET X1=0

           FOR 

               SET X1=$ORDER(^PS(55,DFN,"IV",ON,"BCMA",X1))

               IF X1=""!(X1'?1.N)

                   QUIT 

               IF $DATA(^PS(55,DFN,"IVBCMA",X1))

                   IF $PIECE(^(X1,0),"^")=BCID

                       SET PSJBLN=X1

                       QUIT 

 +1        QUIT 

UPDATE     KILL DA,DR,DIE

           SET DIE="^PS(55,"_DFN_",""IVBCMA"","

           SET DA=PSJBLN

           SET DA(1)=DFN

           SET DR="1////"_DATE_";2////"_STATUS

 +1        IF STATUS=""

               SET DR="1///@;2///@"

 +2        DO ^DIE

 +3        KILL DA,DR,DIE

           SET DIE="^PS(55,"_DFN_",""IV"","

           SET DA=UON

           SET DA(1)=DFN

           SET DR="144////"_STATUS_";145////"_BCID

 +4        IF STATUS=""

               SET DR="144///@;145///@"

 +5        DO ^DIE

 +6        QUIT 

 +7       ;

PNDV(PNDON) ;

 +1        IF PNDON'["P"

               QUIT ""

 +2        NEW PRV

           SET PRV=""

 +3        FOR 

               SET PRV=$PIECE($GET(^PS(53.1,+PNDON,0)),"^",25)

               IF PRV=""!(PRV["V")

                   QUIT 

               SET PNDON=PRV

 +4        QUIT $SELECT(PRV["V":PRV,1:"")

 +5       ;

OTPRN(SCH1) ; Determine if this order is a one-time PRN  PSJ*5*190

 +1        NEW SCH2

           SET TYP=""

 +2       ;actual schedule of "x PRN" exists in schedule file. Don't remove PRN from it.

 +3        IF $DATA(^PS(51.1,"AC","PSJ",SCH1))

               Begin DoDot:1

 +4                SET SCH2=$ORDER(^PS(51.1,"AC","PSJ",SCH1,""))

                   IF '$DATA(^PS(53.1,SCH2))

                       QUIT 

 +5                SET TYP=$PIECE($GET(^PS(51.1,SCH2,0)),"^",5)

               End DoDot:1

               QUIT $GET(TYP)

 +6        SET SCH1=$PIECE(SCH1," PRN",1)

 +7        IF '$DATA(^PS(51.1,"AC","PSJ",SCH1))

               QUIT ""

 +8        SET SCH2=$ORDER(^PS(51.1,"AC","PSJ",SCH1,""))

 +9        IF '$DATA(^PS(51.1,SCH2))

               QUIT ""

 +10       QUIT $PIECE($GET(^PS(51.1,SCH2,0)),"^",5)