PSGPLR0 ;BIR/CML3-PRINTS PICK LIST REPORT (CONT.) ;16 Jul 98 / 12:46 PM
;;5.0; INPATIENT MEDICATIONS ;**15,34,58**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA 2191
;
B0 ;
F S (PW,WDN)=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN)) Q:WDN="" D:FFF=1 FCL F S (PRM,RM)=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM)) Q:RM="" F S PN=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN)) Q:PN="" D B1
Q
;
B1 ;
I $G(PSGPLSTR)'="" S TM=$P(PSGPLSTR,"^",1),WDN=$P(PSGPLSTR,"^",2),RM=$P(PSGPLSTR,"^",3),PN=$P(PSGPLSTR,"^",4,5) K PSGPLSTR
S PPN=$G(^PS(53.5,PSGPLG,1,+$P(PN,U,2),0)),PPN=$P(PPN,U,3,4)
S PSGP=$P(PN,"^",2) S:WSF PW=$P(PPN,"^") S PRM=$P(PPN,"^",2),PRM=$S($P(TND,U,6):$P(PRM,"-",2)_"-"_$P(PRM,"-"),1:PRM) D P1
S PST=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,"")) I PST="NO ORDERS" W !!?27,"No orders found for this patient." Q
I PST="A" D EXH S DRG="" F S DRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,"A",DRG)) Q:DRG="" D GTORDER,PLN3
I PST="A",$O(^PS(53.5,PSGPLG,TM,WDN,RM,PN,"A"))]"" W ! W:OCNT !?6,OLINE W !?30,"**** ACTIVE ORDERS ****" W:'OCNT !?6,OLINE
S PST="A" F S PST=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST)) Q:"Z"[PST S DRG="" F S DRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG)) Q:DRG="" D GTDOSES,P2
I PST="Z" D EXH S DRG="" F S DRG=$O(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,"Z",DRG)) Q:DRG="" D GTORDER,PLN3
Q
;
GTORDER ; Get order number of order in 55.
S PSJJORD=+$G(^PS(53.5,PSGPLG,1,PSGP,1,+$P(DRG,U,2),0))
;
GTDOSES ; Set # dispense drugs and times to be admined.
S PSJORDN=$P($G(^PS(53.5,PSGPLG,1,PSGP,1,+$P(DRG,U,2),0)),U,4)_U_$P($G(^(1,0)),U,4)
Q
;
P1 ;
S ND=$G(^DPT(PSGP,0)),PPN=$S($P(ND,"^")]"":$P(ND,"^"),1:PSGP),PSSN=$E($P(ND,"^",9),6,9),PW=$S(PW="zz":"* N/F *",1:PW),WL="",$P(WL,"=",37-($L(PW)/2))="" D:FFF=2 FCL I $Y+6>IOSL D HEADER
PLN1 W !!,WL," WARD: ",PW," ",WL,!?1,$S(PRM'["zz":PRM,1:"* N/F *"),?11," ",$S(PPN'=PSGP:PPN,1:"NOT FOUND ("_PSGP_")"),$S(PSSN:" ("_PSSN_")",1:""),":" S OCNT=0 Q
;
P2 ;
S PSJJORD=+$G(^PS(53.5,PSGPLG,1,PSGP,1,+$P(DRG,U,2),0))
D:$Y+9+$P(PSJORDN,"^",2)>IOSL HEADER,PLN1 S OCNT=OCNT+1 W ! W:OCNT>1 !?6,OLINE
S ND0=$G(^PS(55,PSGP,5,PSJJORD,0)),ND1=$G(^(.2)),ND2=$G(^(2)),ND6=$P($G(^(6)),"^"),RTE=$P(ND0,"^",3),SM=$S('$P(ND0,"^",5):0,$P(ND0,"^",6):2,1:1),PDRG=$$ENPDN^PSGMI($P(ND1,"^")),DO=$P(ND1,"^",2),Y="" I ND6]"" S Y=$$ENSET^PSGSICHK(ND6)
S SD=$P(ND2,"^",2),(FD,STPDT)=$P(ND2,"^",4),AT=$P(ND2,"^",5),FQC=$P(ND2,"^",6),SCH=$P(ND2,"^") S:SCH="" SCH="SCHEDULE NF" S RTE=$$ENMRN^PSGMI(RTE) F X="SD","FD" S @X=$$ENDTC^PSGMI(@X) I PST'="R",FQC="D",AT="" S AT=$E($P(SD,".",2)_"0000",1,4)
D DD^PSGPLR
Q
;
PLN3 ;
D:$Y+9+$P(PSJORDN,"^",2)>IOSL HEADER,PLN1,EXH S OCNT=OCNT+1 W ! W:OCNT>1 !?6,OLINE
S RTE=$P($G(^PS(55,PSGP,5,PSJJORD,0)),"^",3,9),SCH=$G(^(2)),DR=$G(^(.2)),DIS=$P(RTE,"^",7),RTE=$P(RTE,"^"),DO=$P(DR,"^",2),SD=$P(SCH,"^",2),(FD,STPDT)=$P(SCH,"^",4),SCH=$P(SCH,"^"),DIS=$S(DIS'["D":"EXPIRED",1:"DISCONTINUED")
S DR=$$ENPDN^PSGMI($P(DR,"^")),RTE=$$ENMRN^PSGMI(RTE)
F X="SD","FD" S @X=$$ENDTC^PSGMI(@X)
D EXDD^PSGPLR
Q
;
FCL ;
I PGN,CML,$P(PSGPLWGP,"^",6) D PAGECK^PSGPLR W !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: "_FACL
;
S PGN=PGN+1 W:$Y @IOF
W ?1,"(",PSGPLG,")",?$S($D(PSGPLUPF):27,1:32),"PICK LIST REPORT" W:$D(PSGPLUPF) " (UPDATE)" W ?64,PPLD,!,"Ward group: ",WGPN,?73-$L(PGN),"Page: ",PGN,!?18,"For ",PSD," through ",PFD W:NPLF !,"Team: ",$S(TM'["zz":TM,1:"** N/F **")
W !!,$S($P(TND,"^",6)&'$P(TND,"^",8):"Bed-Room",1:"Room-Bed"),?15,"Patient",?67,"Units",?74,"Units",!?9,"Medication",?48,"ST",?62,"U/D",?66,"Needed",?74,"Disp'd",!,LINE Q
;
EXH ;
W !?6,OLINE
;I VAINDT'="" D INP^VADPT I $G(VAIN(4)) N WARD S WARD=$P($G(VAIN(4)),"^",2) I WARD'=PW W !,?18,"*** DC'D OR EXPIRED FROM "_WARD_" "_$G(VAIN(5))_" ***" Q
W !,?18,"*** DC'D OR EXPIRED WITHIN LAST 24 HOURS ***"
Q
;
HEADSP ;Screen stops
K PSJDLW,DIR S DIR(0)="E" D ^DIR I $D(DTOUT)!$D(DUOUT) S PSJDLW=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLR0 3953 printed Oct 16, 2024@18:03:41 Page 2
PSGPLR0 ;BIR/CML3-PRINTS PICK LIST REPORT (CONT.) ;16 Jul 98 / 12:46 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**15,34,58**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ;
B0 ;
+1 FOR
SET (PW,WDN)=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN))
if WDN=""
QUIT
if FFF=1
DO FCL
FOR
SET (PRM,RM)=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM))
if RM=""
QUIT
FOR
SET PN=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN))
if PN=""
QUIT
DO B1
+2 QUIT
+3 ;
B1 ;
+1 IF $GET(PSGPLSTR)'=""
SET TM=$PIECE(PSGPLSTR,"^",1)
SET WDN=$PIECE(PSGPLSTR,"^",2)
SET RM=$PIECE(PSGPLSTR,"^",3)
SET PN=$PIECE(PSGPLSTR,"^",4,5)
KILL PSGPLSTR
+2 SET PPN=$GET(^PS(53.5,PSGPLG,1,+$PIECE(PN,U,2),0))
SET PPN=$PIECE(PPN,U,3,4)
+3 SET PSGP=$PIECE(PN,"^",2)
if WSF
SET PW=$PIECE(PPN,"^")
SET PRM=$PIECE(PPN,"^",2)
SET PRM=$SELECT($PIECE(TND,U,6):$PIECE(PRM,"-",2)_"-"_$PIECE(PRM,"-"),1:PRM)
DO P1
+4 SET PST=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,""))
IF PST="NO ORDERS"
WRITE !!?27,"No orders found for this patient."
QUIT
+5 IF PST="A"
DO EXH
SET DRG=""
FOR
SET DRG=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,"A",DRG))
if DRG=""
QUIT
DO GTORDER
DO PLN3
+6 IF PST="A"
IF $ORDER(^PS(53.5,PSGPLG,TM,WDN,RM,PN,"A"))]""
WRITE !
if OCNT
WRITE !?6,OLINE
WRITE !?30,"**** ACTIVE ORDERS ****"
if 'OCNT
WRITE !?6,OLINE
+7 SET PST="A"
FOR
SET PST=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST))
if "Z"[PST
QUIT
SET DRG=""
FOR
SET DRG=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,PST,DRG))
if DRG=""
QUIT
DO GTDOSES
DO P2
+8 IF PST="Z"
DO EXH
SET DRG=""
FOR
SET DRG=$ORDER(^PS(53.5,PSGPLXR,PSGPLG,TM,WDN,RM,PN,"Z",DRG))
if DRG=""
QUIT
DO GTORDER
DO PLN3
+9 QUIT
+10 ;
GTORDER ; Get order number of order in 55.
+1 SET PSJJORD=+$GET(^PS(53.5,PSGPLG,1,PSGP,1,+$PIECE(DRG,U,2),0))
+2 ;
GTDOSES ; Set # dispense drugs and times to be admined.
+1 SET PSJORDN=$PIECE($GET(^PS(53.5,PSGPLG,1,PSGP,1,+$PIECE(DRG,U,2),0)),U,4)_U_$PIECE($GET(^(1,0)),U,4)
+2 QUIT
+3 ;
P1 ;
+1 SET ND=$GET(^DPT(PSGP,0))
SET PPN=$SELECT($PIECE(ND,"^")]"":$PIECE(ND,"^"),1:PSGP)
SET PSSN=$EXTRACT($PIECE(ND,"^",9),6,9)
SET PW=$SELECT(PW="zz":"* N/F *",1:PW)
SET WL=""
SET $PIECE(WL,"=",37-($LENGTH(PW)/2))=""
if FFF=2
DO FCL
IF $Y+6>IOSL
DO HEADER
PLN1 WRITE !!,WL," WARD: ",PW," ",WL,!?1,$SELECT(PRM'["zz":PRM,1:"* N/F *"),?11," ",$SELECT(PPN'=PSGP:PPN,1:"NOT FOUND ("_PSGP_")"),$SELECT(PSSN:" ("_PSSN_")",1:""),":"
SET OCNT=0
QUIT
+1 ;
P2 ;
+1 SET PSJJORD=+$GET(^PS(53.5,PSGPLG,1,PSGP,1,+$PIECE(DRG,U,2),0))
+2 if $Y+9+$PIECE(PSJORDN,"^",2)>IOSL
DO HEADER
DO PLN1
SET OCNT=OCNT+1
WRITE !
if OCNT>1
WRITE !?6,OLINE
+3 SET ND0=$GET(^PS(55,PSGP,5,PSJJORD,0))
SET ND1=$GET(^(.2))
SET ND2=$GET(^(2))
SET ND6=$PIECE($GET(^(6)),"^")
SET RTE=$PIECE(ND0,"^",3)
SET SM=$SELECT('$PIECE(ND0,"^",5):0,$PIECE(ND0,"^",6):2,1:1)
SET PDRG=$$ENPDN^PSGMI($PIECE(ND1,"^"))
SET DO=$PIECE(ND1,"^",2)
SET Y=""
IF ND6]""
SET Y=$$ENSET^PSGSICHK(ND6)
+4 SET SD=$PIECE(ND2,"^",2)
SET (FD,STPDT)=$PIECE(ND2,"^",4)
SET AT=$PIECE(ND2,"^",5)
SET FQC=$PIECE(ND2,"^",6)
SET SCH=$PIECE(ND2,"^")
if SCH=""
SET SCH="SCHEDULE NF"
SET RTE=$$ENMRN^PSGMI(RTE)
FOR X="SD","FD"
SET @X=$$ENDTC^PSGMI(@X)
IF PST'="R"
IF FQC="D"
IF AT=""
SET AT=$EXTRACT($PIECE(SD,".",2)_"0000",1,4)
+5 DO DD^PSGPLR
+6 QUIT
+7 ;
PLN3 ;
+1 if $Y+9+$PIECE(PSJORDN,"^",2)>IOSL
DO HEADER
DO PLN1
DO EXH
SET OCNT=OCNT+1
WRITE !
if OCNT>1
WRITE !?6,OLINE
+2 SET RTE=$PIECE($GET(^PS(55,PSGP,5,PSJJORD,0)),"^",3,9)
SET SCH=$GET(^(2))
SET DR=$GET(^(.2))
SET DIS=$PIECE(RTE,"^",7)
SET RTE=$PIECE(RTE,"^")
SET DO=$PIECE(DR,"^",2)
SET SD=$PIECE(SCH,"^",2)
SET (FD,STPDT)=$PIECE(SCH,"^",4)
SET SCH=$PIECE(SCH,"^")
SET DIS=$SELECT(DIS'["D":"EXPIRED",1:"DISCONTINUED")
+3 SET DR=$$ENPDN^PSGMI($PIECE(DR,"^"))
SET RTE=$$ENMRN^PSGMI(RTE)
+4 FOR X="SD","FD"
SET @X=$$ENDTC^PSGMI(@X)
+5 DO EXDD^PSGPLR
+6 QUIT
+7 ;
FCL ;
+1 IF PGN
IF CML
IF $PIECE(PSGPLWGP,"^",6)
DO PAGECK^PSGPLR
WRITE !!?25,"FILLED BY: ",FACL,!!?25,"CHECKED BY: "_FACL
+2 ;
+1 SET PGN=PGN+1
if $Y
WRITE @IOF
+2 WRITE ?1,"(",PSGPLG,")",?$SELECT($DATA(PSGPLUPF):27,1:32),"PICK LIST REPORT"
if $DATA(PSGPLUPF)
WRITE " (UPDATE)"
WRITE ?64,PPLD,!,"Ward group: ",WGPN,?73-$LENGTH(PGN),"Page: ",PGN,!?18,"For ",PSD," through ",PFD
if NPLF
WRITE !,"Team: ",$SELECT(TM'["zz":TM,1:"** N/F **")
+3 WRITE !!,$SELECT($PIECE(TND,"^",6)&'$PIECE(TND,"^",8):"Bed-Room",1:"Room-Bed"),?15,"Patient",?67,"Units",?74,"Units",!?9,"Medication",?48,"ST",?62,"U/D",?66,"Needed",?74,"Disp'd",!,LINE
QUIT
+4 ;
EXH ;
+1 WRITE !?6,OLINE
+2 ;I VAINDT'="" D INP^VADPT I $G(VAIN(4)) N WARD S WARD=$P($G(VAIN(4)),"^",2) I WARD'=PW W !,?18,"*** DC'D OR EXPIRED FROM "_WARD_" "_$G(VAIN(5))_" ***" Q
+3 WRITE !,?18,"*** DC'D OR EXPIRED WITHIN LAST 24 HOURS ***"
+4 QUIT
+5 ;
HEADSP ;Screen stops
+1 KILL PSJDLW,DIR
SET DIR(0)="E"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSJDLW=1
+2 QUIT
