- PSGPLR0 ;BIR/CML3-PRINTS PICK LIST REPORT (CONT.) ;25-Jan-2004 12:17;PLS
- ;;5.0; INPATIENT MEDICATIONS ;**15,34,58**;16 DEC 97
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191
- ; Modified - IHS/CIA/PLS - 12/05/03 - Line P1+2
- 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
- S PSSN=$$HRC^APSPFUNC(+PSGP) ; IHS/CIA/PLS - 12/5/03 - Modified to display HRN vs SSN
- 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
- PSGPLR0 ;BIR/CML3-PRINTS PICK LIST REPORT (CONT.) ;25-Jan-2004 12:17;PLS
- +1 ;;5.0; INPATIENT MEDICATIONS ;**15,34,58**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191
- +4 ; Modified - IHS/CIA/PLS - 12/05/03 - Line P1+2
- 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
- +2 ; IHS/CIA/PLS - 12/5/03 - Modified to display HRN vs SSN
- SET PSSN=$$HRC^APSPFUNC(+PSGP)
- 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
