PSGPLDP0 ;BIR/CML3-ENTER UNITS DISPENSED (PART 2) ;23 OCT 97 / 9:34 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
;
S PSGPLTND=^PS(53.5,PSGPLG,0),WSF=$P(PSGPLTND,"^",7)
I $P(PSGPLTND,"^",2),'$P(PSGPLTND,"^",9) S PSGOD=$$ENDTC^PSGMI($P(PSGPLTND,"^",11)) W $C(7),$C(7),!!?33,"*** WARNING ***",!,"THIS PICK LIST STARTED TO RUN ",PSGOD,", BUT HAS NOT RUN TO COMPLETION."
;
PRN ;
F W !!,"Do you want to see PRN meds only" S %=2 D YN^DICN Q:% D PRNM^PSGPLDPH
I %<0 S PRN="^" Q
S PSGLCNT=0,PRN=%-1,(PC,TM)="" W @IOF
;
TM ;
S OK="" F S TM=$O(^PS(53.5,"AC",PSGPLG,TM)) Q:TM="" S WDN="" F S WDN=$O(^PS(53.5,"AC",PSGPLG,TM,WDN)) Q:WDN="" D:PRN&'WSF W1 S RB="" F S (PR,RB)=$O(^PS(53.5,"AC",PSGPLG,TM,WDN,RB)) Q:RB="" S PN="" D PN G OUT:OK["^^^",TM:OK["^^"
;
OUT ;
W:'PRN&'PC !!?2,"(No PRN meds founds.)" F W !!,"ARE YOU FINISHED WITH THIS PICK LIST" S %=1 D YN^DICN Q:% D FMSG^PSGPLDPH
Q:%<0 G:%'=1 PRN I $P(PSGPLTND,"^",3) D NOW^%DTC I $P(PSGPLTND,"^",3)>% Q
;
FILE ;
F W !!,"MAY I FILE THE DATA IN THIS PICK LIST AWAY" S %=2 D YN^DICN Q:% D FIMSG^PSGPLDPH
I %=1 S DIE="^PS(53.5,",DA=PSGPLG,DR=".05////1" D ^DIE K DIE
Q
;
PN ;
S OK="" F D Q:PN="" S PSGP=$P(PN,"^",2),WF=0 D:WSF&PRN W1 D:PRN W2 D ST Q:OK["^^" G:OK="^" PN
.I ($E(OK,1,1)'="^")&($P(OK,"^",2)'?1.AP) S PN=$O(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN)),OK="" Q
.S DIC="^PS(53.5,"_PSGPLG_",1,",DIC(0)="EQZ",X=$P(OK,"^",2),OK="" D ^DIC K DIC I Y<0 S PN="" Q
.S Y=$S(WSF:"zns",1:$P(Y(0),"^",3))
.S RB=$P($G(^PS(53.5,PSGPLG,1,+Y(0),0)),U,4) I RB]"",$P(^PS(53.5,PSGPLG,0),U,6),RB'="zz" S RB=$S($P(RB,"-",2)?1N:0,1:"")_$P(RB,"-",2)_"-"_$P(RB,"-")
.S RB=$S($P(^PS(53.5,PSGPLG,0),"^",8)=1:"zz",RB="":"zz",1:RB)
.I '$D(^PS(53.5,"AC",PSGPLG,$P(Y(0),"^",2),Y,RB,$E($P($G(^DPT(+Y(0),0)),U),1,12)_U_+Y(0))) S PN="" K Y Q
.S PN=$E($P($G(^DPT(+Y(0),0)),U),1,12)_U_+Y(0),TM=$P(Y(0),"^",2),WDN=Y K Y
;
NP Q
;
ST ;
S ST="A" F S ST=$O(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN,ST)) Q:"Z"[ST D DRG Q:OK["^"
Q
;
DRG ;
S DRG=""
F S DRG=$O(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN,ST,DRG)) Q:DRG="" S PSGORD=$P(DRG,"^",2),PSJJORD=+$G(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0)),SCH=$P($G(^PS(55,PSGP,5,PSJJORD,2)),"^") I SCH["PRN"!(ST="P")!PRN D GD Q:OK["^"
Q
;
GD ;
S DDRG="" F Q:OK["^" S DDRG=$O(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN,ST,DRG,DDRG)) Q:DDRG="" S DN=+$P(DDRG,"^",2),DN=$G(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,DN,0)),PDD=$P(DN,"^",3),PDN=$P(DN,"^",2) I DN'["DI" D
.I DN="" W !,$$ENPDN^PSGMI(+$G(^PS(55,PSGP,5,PSJJORD,.2))),?42,"NEEDED: OI",?55,"DISPENSED:" D SCREEN Q
.S DR=$P($G(^PS(55,PSGP,5,PSJJORD,1,+DN,0)),"^"),DR=$$ENDDN^PSGMI(DR)
.S LMT=PDN*2+1000 I 'PRN S:'PC PC=1 I 'WF S WF=1,OK="??" D W1
.I PDN="WS" W !,DR,?42,"NEEDED: ",PDN,?55,"DISPENSED: ",PDN D SCREEN Q
.S PSGLCNT=0
.F W !,DR,?42,"NEEDED: ",PDN,?55,"DISPENSED: ",$S(PDD="":"",1:PDD_"// ") R OK:DTIME W:'$T $C(7) S:'$T OK="^^^" Q:$S(OK=+OK:OK'>LMT,OK?1.3"^":1,($E(OK,1,1)="^")&($P(OK,"^",2)?1.AP):1,1:OK="") D:OK?1."?" GDMSG I OK'?1."?" W $C(7)," ??"
.Q:($E(OK,1,1)="^")&($P(OK,"^",2)?1.AP)
.I OK="" S OK=$S(PDD]"":PDD,PDN="NV":"",1:PDN) W " ",OK
.I OK=+OK,OK'=PDD S $P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,$P(DDRG,"^",2),0),"^",3)=OK
Q
;
GDMSG ;
W !!," Enter the number of units actually dispensed for this medication. If the",!,"units dispensed is the same as the units needed (or units dispensed, if shown),",!,"just press the RETURN key."
W " Enter an '^' to jump ahead to the next patient,",!,"'^^' to jump ahead to the next team, or '^^^' to exit this pick list.",! Q:OK'?2."?"
;
W1 ;
S PW=$S('WSF:WDN,1:$P(^PS(53.5,PSGPLG,1,PSGP,0),"^",3)),PSGLCNT=PSGLCNT+.5
W !!,"TEAM: ",$S(TM'["zz":TM,1:"* N/F *"),?40,"WARD: ",$S(WDN'["zz":PW,1:"* N/F *") Q:OK'?2."?"
;
W2 ;
S PSSN=$S($D(^DPT(PSGP,0)):$E($P(^(0),"^",9),6,9),1:"* N/F *"),PPN=$S('$D(^(0)):PN,$P(^(0),"^")]"":$P(^(0),"^"),1:PN),PR=$P(^PS(53.5,PSGPLG,1,PSGP,0),"^",4)
W !!,?5,$S($P(PSGPLTND,"^",8):"ROOM-BED: ",$P(PSGPLTND,"^",6):"BED-ROOM: ",1:"ROOM-BED: "),$S(PR'["zz":PR,1:"* N/F *"),?30,PPN," (",PSSN,")",!
I '$D(^PS(53.5,PSGPLG,1,PSGP,1)) W !,?20,"(NO ORDERS)",! D SCREEN
Q
;
SCREEN ; display break
S PSGLCNT=PSGLCNT+1 Q:PSGLCNT<4 S PSGLCNT=0 W !
K DIR S DIR("A")="Press RETURN to continue",DIR("?")="Enter ^ to go to next patient, ^XXX to go to patient XXX, ^^ to go to next ward, ^^^ to go to next team.",DIR(0)="FOU^^K:(X'="""")!(X'[""^"") X" D ^DIR K DIR S OK=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLDP0 4467 printed Oct 16, 2024@18:03:34 Page 2
PSGPLDP0 ;BIR/CML3-ENTER UNITS DISPENSED (PART 2) ;23 OCT 97 / 9:34 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 ;
+3 SET PSGPLTND=^PS(53.5,PSGPLG,0)
SET WSF=$PIECE(PSGPLTND,"^",7)
+4 IF $PIECE(PSGPLTND,"^",2)
IF '$PIECE(PSGPLTND,"^",9)
SET PSGOD=$$ENDTC^PSGMI($PIECE(PSGPLTND,"^",11))
WRITE $CHAR(7),$CHAR(7),!!?33,"*** WARNING ***",!,"THIS PICK LIST STARTED TO RUN ",PSGOD,", BUT HAS NOT RUN TO COMPLETION."
+5 ;
PRN ;
+1 FOR
WRITE !!,"Do you want to see PRN meds only"
SET %=2
DO YN^DICN
if %
QUIT
DO PRNM^PSGPLDPH
+2 IF %<0
SET PRN="^"
QUIT
+3 SET PSGLCNT=0
SET PRN=%-1
SET (PC,TM)=""
WRITE @IOF
+4 ;
TM ;
+1 SET OK=""
FOR
SET TM=$ORDER(^PS(53.5,"AC",PSGPLG,TM))
if TM=""
QUIT
SET WDN=""
FOR
SET WDN=$ORDER(^PS(53.5,"AC",PSGPLG,TM,WDN))
if WDN=""
QUIT
if PRN&'WSF
DO W1
SET RB=""
FOR
SET (PR,RB)=$ORDER(^PS(53.5,"AC",PSGPLG,TM,WDN,RB))
if RB=""
QUIT
SET PN=""
DO PN
if OK["^^^"
GOTO OUT
if OK["^^"
GOTO TM
+2 ;
OUT ;
+1 if 'PRN&'PC
WRITE !!?2,"(No PRN meds founds.)"
FOR
WRITE !!,"ARE YOU FINISHED WITH THIS PICK LIST"
SET %=1
DO YN^DICN
if %
QUIT
DO FMSG^PSGPLDPH
+2 if %<0
QUIT
if %'=1
GOTO PRN
IF $PIECE(PSGPLTND,"^",3)
DO NOW^%DTC
IF $PIECE(PSGPLTND,"^",3)>%
QUIT
+3 ;
FILE ;
+1 FOR
WRITE !!,"MAY I FILE THE DATA IN THIS PICK LIST AWAY"
SET %=2
DO YN^DICN
if %
QUIT
DO FIMSG^PSGPLDPH
+2 IF %=1
SET DIE="^PS(53.5,"
SET DA=PSGPLG
SET DR=".05////1"
DO ^DIE
KILL DIE
+3 QUIT
+4 ;
PN ;
+1 SET OK=""
FOR
Begin DoDot:1
+2 IF ($EXTRACT(OK,1,1)'="^")&($PIECE(OK,"^",2)'?1.AP)
SET PN=$ORDER(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN))
SET OK=""
QUIT
+3 SET DIC="^PS(53.5,"_PSGPLG_",1,"
SET DIC(0)="EQZ"
SET X=$PIECE(OK,"^",2)
SET OK=""
DO ^DIC
KILL DIC
IF Y<0
SET PN=""
QUIT
+4 SET Y=$SELECT(WSF:"zns",1:$PIECE(Y(0),"^",3))
+5 SET RB=$PIECE($GET(^PS(53.5,PSGPLG,1,+Y(0),0)),U,4)
IF RB]""
IF $PIECE(^PS(53.5,PSGPLG,0),U,6)
IF RB'="zz"
SET RB=$SELECT($PIECE(RB,"-",2)?1N:0,1:"")_$PIECE(RB,"-",2)_"-"_$PIECE(RB,"-")
+6 SET RB=$SELECT($PIECE(^PS(53.5,PSGPLG,0),"^",8)=1:"zz",RB="":"zz",1:RB)
+7 IF '$DATA(^PS(53.5,"AC",PSGPLG,$PIECE(Y(0),"^",2),Y,RB,$EXTRACT($PIECE($GET(^DPT(+Y(0),0)),U),1,12)_U_+Y(0)))
SET PN=""
KILL Y
QUIT
+8 SET PN=$EXTRACT($PIECE($GET(^DPT(+Y(0),0)),U),1,12)_U_+Y(0)
SET TM=$PIECE(Y(0),"^",2)
SET WDN=Y
KILL Y
End DoDot:1
if PN=""
QUIT
SET PSGP=$PIECE(PN,"^",2)
SET WF=0
if WSF&PRN
DO W1
if PRN
DO W2
DO ST
if OK["^^"
QUIT
if OK="^"
GOTO PN
+9 ;
NP QUIT
+1 ;
ST ;
+1 SET ST="A"
FOR
SET ST=$ORDER(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN,ST))
if "Z"[ST
QUIT
DO DRG
if OK["^"
QUIT
+2 QUIT
+3 ;
DRG ;
+1 SET DRG=""
+2 FOR
SET DRG=$ORDER(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN,ST,DRG))
if DRG=""
QUIT
SET PSGORD=$PIECE(DRG,"^",2)
SET PSJJORD=+$GET(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0))
SET SCH=$PIECE($GET(^PS(55,PSGP,5,PSJJORD,2)),"^")
IF SCH["PRN"!(ST="P")!PRN
DO GD
if OK["^"
QUIT
+3 QUIT
+4 ;
GD ;
+1 SET DDRG=""
FOR
if OK["^"
QUIT
SET DDRG=$ORDER(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN,ST,DRG,DDRG))
if DDRG=""
QUIT
SET DN=+$PIECE(DDRG,"^",2)
SET DN=$GET(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,DN,0))
SET PDD=$PIECE(DN,"^",3)
SET PDN=$PIECE(DN,"^",2)
IF DN'["DI"
Begin DoDot:1
+2 IF DN=""
WRITE !,$$ENPDN^PSGMI(+$GET(^PS(55,PSGP,5,PSJJORD,.2))),?42,"NEEDED: OI",?55,"DISPENSED:"
DO SCREEN
QUIT
+3 SET DR=$PIECE($GET(^PS(55,PSGP,5,PSJJORD,1,+DN,0)),"^")
SET DR=$$ENDDN^PSGMI(DR)
+4 SET LMT=PDN*2+1000
IF 'PRN
if 'PC
SET PC=1
IF 'WF
SET WF=1
SET OK="??"
DO W1
+5 IF PDN="WS"
WRITE !,DR,?42,"NEEDED: ",PDN,?55,"DISPENSED: ",PDN
DO SCREEN
QUIT
+6 SET PSGLCNT=0
+7 FOR
WRITE !,DR,?42,"NEEDED: ",PDN,?55,"DISPENSED: ",$SELECT(PDD="":"",1:PDD_"// ")
READ OK:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET OK="^^^"
if $SELECT(OK=+OK
QUIT
if OK?1."?"
DO GDMSG
IF OK'?1."?"
WRITE $CHAR(7)," ??"
+8 if ($EXTRACT(OK,1,1)="^")&($PIECE(OK,"^",2)?1.AP)
QUIT
+9 IF OK=""
SET OK=$SELECT(PDD]"":PDD,PDN="NV":"",1:PDN)
WRITE " ",OK
+10 IF OK=+OK
IF OK'=PDD
SET $PIECE(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,$PIECE(DDRG,"^",2),0),"^",3)=OK
End DoDot:1
+11 QUIT
+12 ;
GDMSG ;
+1 WRITE !!," Enter the number of units actually dispensed for this medication. If the",!,"units dispensed is the same as the units needed (or units dispensed, if shown),",!,"just press the RETURN key."
+2 WRITE " Enter an '^' to jump ahead to the next patient,",!,"'^^' to jump ahead to the next team, or '^^^' to exit this pick list.",!
if OK'?2."?"
QUIT
+3 ;
W1 ;
+1 SET PW=$SELECT('WSF:WDN,1:$PIECE(^PS(53.5,PSGPLG,1,PSGP,0),"^",3))
SET PSGLCNT=PSGLCNT+.5
+2 WRITE !!,"TEAM: ",$SELECT(TM'["zz":TM,1:"* N/F *"),?40,"WARD: ",$SELECT(WDN'["zz":PW,1:"* N/F *")
if OK'?2."?"
QUIT
+3 ;
W2 ;
+1 SET PSSN=$SELECT($DATA(^DPT(PSGP,0)):$EXTRACT($PIECE(^(0),"^",9),6,9),1:"* N/F *")
SET PPN=$SELECT('$DATA(^(0)):PN,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:PN)
SET PR=$PIECE(^PS(53.5,PSGPLG,1,PSGP,0),"^",4)
+2 WRITE !!,?5,$SELECT($PIECE(PSGPLTND,"^",8):"ROOM-BED: ",$PIECE(PSGPLTND,"^",6):"BED-ROOM: ",1:"ROOM-BED: "),$SELECT(PR'["zz":PR,1:"* N/F *"),?30,PPN," (",PSSN,")",!
+3 IF '$DATA(^PS(53.5,PSGPLG,1,PSGP,1))
WRITE !,?20,"(NO ORDERS)",!
DO SCREEN
+4 QUIT
+5 ;
SCREEN ; display break
+1 SET PSGLCNT=PSGLCNT+1
if PSGLCNT<4
QUIT
SET PSGLCNT=0
WRITE !
+2 KILL DIR
SET DIR("A")="Press RETURN to continue"
SET DIR("?")="Enter ^ to go to next patient, ^XXX to go to patient XXX, ^^ to go to next ward, ^^^ to go to next team."
SET DIR(0)="FOU^^K:(X'="""")!(X'[""^"") X"
DO ^DIR
KILL DIR
SET OK=X
+3 QUIT
