PSGPEN ;BIR/CML3-FIND DEFAULT FOR PRE-EXCHANGE NEEDS ;03 Feb 99 / 9:13 AM
;;5.0; INPATIENT MEDICATIONS ;**30,37,50,58,115,110,127,129**;16 DEC 97
;
; References to ^PSD(58.8 supported by DBIA #2283.
; References to ^PSI(58.1 supported by DBIA #2284.
; Reference to ^PS(55 is supported by DBIA #2191.
; Reference to ^PSDRUG is supported by DBIA #2192.
; Reference to ^PS(59.7 is supported by DBIA #2181.
;
EN(PSGPENO) ;
S PSGPENO=+PSGPENO
N PSJSITE,PSJPRN S PSJSITE=0,PSJSITE=$O(^PS(59.7,PSJSITE)) I $P($G(^(PSJSITE,26)),U,5)=1 S PSJPRN=1
D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT,PSGPEN="" S ND=$G(^PS(55,PSGP,5,PSGPENO,0))
S PSGPENWS=0 I PSJPWD F Q=0:0 S Q=$O(^PS(55,PSGP,5,PSGPENO,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,'$P(ND,"^",3),($D(^PSI(58.1,"D",+ND,PSJPWD))!$D(^PSD(58.8,"D",+ND,PSJPWD))) S PSGPENWS=1 Q
I PSGPENWS F S Q=$O(^PS(55,PSGP,5,PSGPENO,1,Q)) Q:'Q S ND=$G(^(Q,0)) I ND,'$P(ND,"^",3) S:'$D(^PSI(58.1,"D",+ND,PSJPWD))&'$D(^PSD(58.8,"D",+ND,PSJPWD)) PSGPENWS=0 Q:'PSGPENWS S $P(PSGPENWS,"^",2)=1
I PSGPENWS W !!,"The dispense drug",$E("s",$P(PSGPENWS,"^",2))," for this order ",$S($P(PSGPENWS,"^",2):"are",1:"is a")," WARD STOCK item",$E("s",$P(PSGPENWS,"^",2)),"." S PSGPEN=0
I 'PSGPENWS,PSJPWD S WG=+$O(^PS(57.5,"AB",PSJPWD,0)),PSGPLS=$P($G(^PS(55,PSGP,5,PSGPENO,2)),"^",2) I PSGPLS D
.S PSGPLF=$O(^PS(53.5,"AB",WG,PSGDT))
.N RNDT,PSJRNOS S RNDT=$$LASTREN^PSJLMPRI(PSGP,$S($G(PSJORD)["P":PSJORD,1:"")),PSJRNOS=$P(RNDT,"^",4) I PSJRNOS,'$G(PSJREN) S PSGPLS=PSJRNOS
.I $G(PSJREN),$G(PSJORD)["U" S PSJRNOS=$P(^PS(55,PSGP,5,+PSJORD,2),"^",4) S PSGPLS=$S(PSJRNOS>PSGDT:PSJRNOS,1:$$DATE2^PSJUTL2(PSGDT))
.D:'PSGPLF GF I PSGPLF S PSGPLO=PSGPENO D NCE,^PSGPL0 S:PSGPLC'<0 PSGPEN=PSGPLC
I $G(PSGPRIO)="DONE" S PSGPEN=0
;
UPDD ;
N DIR S DIR(0)="NOA^0:9999:0",DIR("A")="Pre-Exchange DOSES: ",DIR("?")="^D DH^PSGPEN" S:PSGPEN]"" DIR("B")=PSGPEN W ! D ^DIR G:'Y DONE S PSGY=+Y W !!,"...updating dispense drug(s)..."
F FQ=0:0 S FQ=$O(^PS(55,PSGP,5,PSGPENO,1,FQ)) Q:'FQ S ND=$G(^(FQ,0)),$P(^(0),"^",9)="" I ND,'$P(ND,"^",3) D DD
;
DONE ;
I $P(PSJSYSW0,"^",29)="",$$DEFON^PSGPER1 S $P(PSJSYSW0,"^",29)=0
K PSGID,PSGMAR,PSGOD,PSGPLC,PSGPLF,PSGPLO,PSGPLS,PSGPLUD,WG S:$G(PSJREN) DUOUT=0 Q
;
NCE ;
W !!,"The next cart exchange is ",$$ENDTC^PSGMI(PSGPLF),! Q
;
GF ;
S QQ=0 F Q=0:0 S Q=$O(^PS(53.5,"AB",WG,Q)) Q:'Q S QQ=Q
I QQ S QQ=$O(^PS(53.5,"AB",WG,QQ,0)) I QQ,$D(^PS(53.5,QQ,0)) S QQ=$P(^(0),"^",4) I QQ>PSGDT S PSGPLF=QQ
Q
;
DD ;
N DA S DRG=$S($P(ND,"^")="":"NOT FOUND",'$D(^PSDRUG(+ND,0)):"NOT FOUND ("_$P(ND,"^")_")",$P(^(0),"^")]"":$P(^(0),"^"),1:$P(ND,"^")_";PSDRUG("),UD=$S('$P(ND,"^",2):1,1:$P(ND,"^",2))
W !,"...",DRG,?45,"U/D: ",UD,"..."
S PSGDA=PSGY I 'PSGPENWS,ND,PSJPWD,($D(^PSI(58.1,"D",+ND,PSJPWD))!$D(^PSD(58.8,"D",+ND,PSJPWD))) D PSGPENWS Q:'PSGDA
K DA,DR S PSGDA=$S(UD#1:(PSGDA*((UD\1)+1)),1:PSGDA*UD)
S DIE="^PS(55,"_PSGP_",5,"_PSGPENO_",1,",DA(2)=PSGP,DA(1)=PSGPENO,DA=FQ,DR=".09////"_PSGDA D ^DIE
S PSGPXN=$G(PSGPXN)
D:'PSGPXN
.D NOW^%DTC L +^PS(53.4,0):0 S ND=$G(^PS(53.4,0)) S:ND="" ND="PRE-EXCHANGE NEEDS^53.4P" F PSGPXN=$P(ND,"^",3)+1:1 I '$D(^PS(53.4,PSGPXN)) L +^PS(53.4,PSGPXN):0 I S ^PS(53.4,0)=$P(ND,"^",1,2)_"^"_PSGPXN_"^"_($P(ND,"^",4)+1) L -^PS(53.4,0) Q
.S ^PS(53.4,PSGPXN,0)=DUZ_"^"_%,^PS(53.4,"B",DUZ,PSGPXN)="",^PS(53.4,"AUD",DUZ,%,PSGPXN)="" L -^PS(53.4,PSGPXN) Q
I $D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,FQ,0)) S $P(^(0),"^",2)=$P(^(0),"^",2)+PSGDA Q
; naked reference below refers to line above
S ^(0)=FQ_"^"_PSGDA I $D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,0)) S $P(^(0),"^",3,4)=FQ_"^"_($P(^(0),"^",4)+1) Q
; naked reference below refers to line above
S ^(0)="^53.401101A^"_FQ_"^1" Q:$D(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,0)) S ^(0)=PSGPENO
I $D(^PS(53.4,PSGPXN,1,PSGP,1,0)) S $P(^(0),"^",3,4)=PSGPENO_"^"_($P(^(0),"^",4)+1) Q
; naked reference below is from line above
S ^(0)="^53.4011A^"_PSGPENO_"^1" Q:$D(^PS(53.4,PSGPXN,1,PSGP,0)) S ^(0)=PSGP
I $D(^PS(53.4,PSGPXN,1,0)) S $P(^(0),"^",3,4)=PSGP_"^"_($P(^(0),"^",4)+1) Q
; naked reference below is from line above
S ^(0)="^53.401PA^"_PSGP_"^1" Q
;
DH ;
W !!?2,"Enter a number from 0 to 9999, 0 decimal digits."
W !!?2,"Enter the number DOSES needed for this order until the next cart exchange.",!,"This will be the number of times the order will be administered to the patient",!,"from the start of the order until the next cart exchange."
W !!?2,"PLEASE NOTE that this is DOSES, and NOT UNITS. The doses entered will be",!,"converted to units for each dispense drug of this order, as each dispense drug",!,"may have a different units per dose." Q
;
PSGPENWS ;
W !,"This dispense drug is a WARD STOCK item."
W !,"Would you like to:",!?3,"1 - Enter 0 (no) doses needed for this dispense drug.",!?3,"2 - Enter ",PSGDA," doses needed for this dispense drug.",!?3,"3 - Enter another amount as the doses needed for this dispense drug."
K DIR S DIR(0)="SA^1:0 (no) doses;2:"_PSGDA_" doses;3:another amount",DIR("A")="Select ACTION: ",DIR("?")="^D WH^PSGPEN" W ! D ^DIR I Y=1!'Y S PSGDA=0 Q
Q:Y=2 K DIR S DIR(0)="NA^0:9999:0",DIR("A")="Pre-Exchange DOSES for this dispense drug: ",DIR("?")="^D WDH^PSGPEN" W ! D ^DIR S PSGDA=+Y Q
;
WH ;
S Q="This dispense drug ("_DRG_") is a ward stock item. Select:"
W !! F Q1=1:1:$L(Q," ") S Q2=$P(Q," ",Q1) W:$X+$L(Q2)>78 ! W Q2," "
W !?3,"1 to enter 0 (no) pre-exchange doses for this dispense drug.",!?3,"2 to enter ",PSGDA," doses for this dispense drug.",!?3,"3 to enter another amount for this dispense drug." Q
;
WDH ;
W !!?2,"Enter a number from 0 to 9999, 0 decimal digits. If you enter an '^' to exit",!,"NO pre-exchange doses will be entered for this dispense drug." Q
PSGPEN ;BIR/CML3-FIND DEFAULT FOR PRE-EXCHANGE NEEDS ;03 Feb 99 / 9:13 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**30,37,50,58,115,110,127,129**;16 DEC 97
+2 ;
+3 ; References to ^PSD(58.8 supported by DBIA #2283.
+4 ; References to ^PSI(58.1 supported by DBIA #2284.
+5 ; Reference to ^PS(55 is supported by DBIA #2191.
+6 ; Reference to ^PSDRUG is supported by DBIA #2192.
+7 ; Reference to ^PS(59.7 is supported by DBIA #2181.
+8 ;
EN(PSGPENO) ;
+1 SET PSGPENO=+PSGPENO
+2 NEW PSJSITE,PSJPRN
SET PSJSITE=0
SET PSJSITE=$ORDER(^PS(59.7,PSJSITE))
IF $PIECE($GET(^(PSJSITE,26)),U,5)=1
SET PSJPRN=1
+3 DO NOW^%DTC
SET PSGDT=%
SET DT=$$DT^XLFDT
SET PSGPEN=""
SET ND=$GET(^PS(55,PSGP,5,PSGPENO,0))
+4 SET PSGPENWS=0
IF PSJPWD
FOR Q=0:0
SET Q=$ORDER(^PS(55,PSGP,5,PSGPENO,1,Q))
IF 'Q
QUIT
SET ND=$GET(^(Q,0))
IF ND
IF '$PIECE(ND,"^",3)
IF ($DATA(^PSI(58.1,"D",+ND,PSJPWD))!$DATA(^PSD(58.8,"D",+ND,PSJPWD)))
SET PSGPENWS=1
QUIT
+5 IF PSGPENWS
FOR
SET Q=$ORDER(^PS(55,PSGP,5,PSGPENO,1,Q))
IF 'Q
QUIT
SET ND=$GET(^(Q,0))
IF ND
IF '$PIECE(ND,"^",3)
IF '$DATA(^PSI(58.1,"D",+ND,PSJPWD))&'$DATA(^PSD(58.8,"D",+ND,PSJPWD))
SET PSGPENWS=0
IF 'PSGPENWS
QUIT
SET $PIECE(PSGPENWS,"^",2)=1
+6 IF PSGPENWS
WRITE !!,"The dispense drug",$EXTRACT("s",$PIECE(PSGPENWS,"^",2))," for this order ",$SELECT($PIECE(PSGPENWS,"^",2):"are",1:"is a")," WARD STOCK item",$EXTRACT("s",$PIECE(PSGPENWS,"^",2)),"."
SET PSGPEN=0
+7 IF 'PSGPENWS
IF PSJPWD
SET WG=+$ORDER(^PS(57.5,"AB",PSJPWD,0))
SET PSGPLS=$PIECE($GET(^PS(55,PSGP,5,PSGPENO,2)),"^",2)
IF PSGPLS
Begin DoDot:1
+8 SET PSGPLF=$ORDER(^PS(53.5,"AB",WG,PSGDT))
+9 NEW RNDT,PSJRNOS
SET RNDT=$$LASTREN^PSJLMPRI(PSGP,$SELECT($GET(PSJORD)["P":PSJORD,1:""))
SET PSJRNOS=$PIECE(RNDT,"^",4)
IF PSJRNOS
IF '$GET(PSJREN)
SET PSGPLS=PSJRNOS
+10 IF $GET(PSJREN)
IF $GET(PSJORD)["U"
SET PSJRNOS=$PIECE(^PS(55,PSGP,5,+PSJORD,2),"^",4)
SET PSGPLS=$SELECT(PSJRNOS>PSGDT:PSJRNOS,1:$$DATE2^PSJUTL2(PSGDT))
+11 IF 'PSGPLF
DO GF
IF PSGPLF
SET PSGPLO=PSGPENO
DO NCE
DO ^PSGPL0
IF PSGPLC'<0
SET PSGPEN=PSGPLC
End DoDot:1
+12 IF $GET(PSGPRIO)="DONE"
SET PSGPEN=0
+13 ;
UPDD ;
+1 NEW DIR
SET DIR(0)="NOA^0:9999:0"
SET DIR("A")="Pre-Exchange DOSES: "
SET DIR("?")="^D DH^PSGPEN"
IF PSGPEN]""
SET DIR("B")=PSGPEN
WRITE !
DO ^DIR
IF 'Y
GOTO DONE
SET PSGY=+Y
WRITE !!,"...updating dispense drug(s)..."
+2 FOR FQ=0:0
SET FQ=$ORDER(^PS(55,PSGP,5,PSGPENO,1,FQ))
IF 'FQ
QUIT
SET ND=$GET(^(FQ,0))
SET $PIECE(^(0),"^",9)=""
IF ND
IF '$PIECE(ND,"^",3)
DO DD
+3 ;
DONE ;
+1 IF $PIECE(PSJSYSW0,"^",29)=""
IF $$DEFON^PSGPER1
SET $PIECE(PSJSYSW0,"^",29)=0
+2 KILL PSGID,PSGMAR,PSGOD,PSGPLC,PSGPLF,PSGPLO,PSGPLS,PSGPLUD,WG
IF $GET(PSJREN)
SET DUOUT=0
QUIT
+3 ;
NCE ;
+1 WRITE !!,"The next cart exchange is ",$$ENDTC^PSGMI(PSGPLF),!
QUIT
+2 ;
GF ;
+1 SET QQ=0
FOR Q=0:0
SET Q=$ORDER(^PS(53.5,"AB",WG,Q))
IF 'Q
QUIT
SET QQ=Q
+2 IF QQ
SET QQ=$ORDER(^PS(53.5,"AB",WG,QQ,0))
IF QQ
IF $DATA(^PS(53.5,QQ,0))
SET QQ=$PIECE(^(0),"^",4)
IF QQ>PSGDT
SET PSGPLF=QQ
+3 QUIT
+4 ;
DD ;
+1 NEW DA
SET DRG=$SELECT($PIECE(ND,"^")="":"NOT FOUND",'$DATA(^PSDRUG(+ND,0)):"NOT FOUND ("_$PIECE(ND,"^")_")",$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:$PIECE(ND,"^")_";PSDRUG(")
SET UD=$SELECT('$PIECE(ND,"^",2):1,1:$PIECE(ND,"^",2))
+2 WRITE !,"...",DRG,?45,"U/D: ",UD,"..."
+3 SET PSGDA=PSGY
IF 'PSGPENWS
IF ND
IF PSJPWD
IF ($DATA(^PSI(58.1,"D",+ND,PSJPWD))!$DATA(^PSD(58.8,"D",+ND,PSJPWD)))
DO PSGPENWS
IF 'PSGDA
QUIT
+4 KILL DA,DR
SET PSGDA=$SELECT(UD#1:(PSGDA*((UD\1)+1)),1:PSGDA*UD)
+5 SET DIE="^PS(55,"_PSGP_",5,"_PSGPENO_",1,"
SET DA(2)=PSGP
SET DA(1)=PSGPENO
SET DA=FQ
SET DR=".09////"_PSGDA
DO ^DIE
+6 SET PSGPXN=$GET(PSGPXN)
+7 IF 'PSGPXN
Begin DoDot:1
+8 DO NOW^%DTC
LOCK +^PS(53.4,0):0
SET ND=$GET(^PS(53.4,0))
IF ND=""
SET ND="PRE-EXCHANGE NEEDS^53.4P"
FOR PSGPXN=$PIECE(ND,"^",3)+1:1
IF '$DATA(^PS(53.4,PSGPXN))
LOCK +^PS(53.4,PSGPXN):0
IF $TEST
SET ^PS(53.4,0)=$PIECE(ND,"^",1,2)_"^"_PSGPXN_"^"_($PIECE(ND,"^",4)+1)
LOCK -^PS(53.4,0)
QUIT
+9 SET ^PS(53.4,PSGPXN,0)=DUZ_"^"_%
SET ^PS(53.4,"B",DUZ,PSGPXN)=""
SET ^PS(53.4,"AUD",DUZ,%,PSGPXN)=""
LOCK -^PS(53.4,PSGPXN)
QUIT
End DoDot:1
+10 IF $DATA(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,FQ,0))
SET $PIECE(^(0),"^",2)=$PIECE(^(0),"^",2)+PSGDA
QUIT
+11 ; naked reference below refers to line above
+12 SET ^(0)=FQ_"^"_PSGDA
IF $DATA(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,1,0))
SET $PIECE(^(0),"^",3,4)=FQ_"^"_($PIECE(^(0),"^",4)+1)
QUIT
+13 ; naked reference below refers to line above
+14 SET ^(0)="^53.401101A^"_FQ_"^1"
IF $DATA(^PS(53.4,PSGPXN,1,PSGP,1,PSGPENO,0))
QUIT
SET ^(0)=PSGPENO
+15 IF $DATA(^PS(53.4,PSGPXN,1,PSGP,1,0))
SET $PIECE(^(0),"^",3,4)=PSGPENO_"^"_($PIECE(^(0),"^",4)+1)
QUIT
+16 ; naked reference below is from line above
+17 SET ^(0)="^53.4011A^"_PSGPENO_"^1"
IF $DATA(^PS(53.4,PSGPXN,1,PSGP,0))
QUIT
SET ^(0)=PSGP
+18 IF $DATA(^PS(53.4,PSGPXN,1,0))
SET $PIECE(^(0),"^",3,4)=PSGP_"^"_($PIECE(^(0),"^",4)+1)
QUIT
+19 ; naked reference below is from line above
+20 SET ^(0)="^53.401PA^"_PSGP_"^1"
QUIT
+21 ;
DH ;
+1 WRITE !!?2,"Enter a number from 0 to 9999, 0 decimal digits."
+2 WRITE !!?2,"Enter the number DOSES needed for this order until the next cart exchange.",!,"This will be the number of times the order will be administered to the patient",!,"from the start of the order until the next cart exchange."
+3 WRITE !!?2,"PLEASE NOTE that this is DOSES, and NOT UNITS. The doses entered will be",!,"converted to units for each dispense drug of this order, as each dispense drug",!,"may have a different units per dose."
QUIT
+4 ;
PSGPENWS ;
+1 WRITE !,"This dispense drug is a WARD STOCK item."
+2 WRITE !,"Would you like to:",!?3,"1 - Enter 0 (no) doses needed for this dispense drug.",!?3,"2 - Enter ",PSGDA," doses needed for this dispense drug.",!?3,"3 - Enter another amount as the doses needed for this dispense drug."
+3 KILL DIR
SET DIR(0)="SA^1:0 (no) doses;2:"_PSGDA_" doses;3:another amount"
SET DIR("A")="Select ACTION: "
SET DIR("?")="^D WH^PSGPEN"
WRITE !
DO ^DIR
IF Y=1!'Y
SET PSGDA=0
QUIT
+4 IF Y=2
QUIT
KILL DIR
SET DIR(0)="NA^0:9999:0"
SET DIR("A")="Pre-Exchange DOSES for this dispense drug: "
SET DIR("?")="^D WDH^PSGPEN"
WRITE !
DO ^DIR
SET PSGDA=+Y
QUIT
+5 ;
WH ;
+1 SET Q="This dispense drug ("_DRG_") is a ward stock item. Select:"
+2 WRITE !!
FOR Q1=1:1:$LENGTH(Q," ")
SET Q2=$PIECE(Q," ",Q1)
IF $X+$LENGTH(Q2)>78
WRITE !
WRITE Q2," "
+3 WRITE !?3,"1 to enter 0 (no) pre-exchange doses for this dispense drug.",!?3,"2 to enter ",PSGDA," doses for this dispense drug.",!?3,"3 to enter another amount for this dispense drug."
QUIT
+4 ;
WDH ;
+1 WRITE !!?2,"Enter a number from 0 to 9999, 0 decimal digits. If you enter an '^' to exit",!,"NO pre-exchange doses will be entered for this dispense drug."
QUIT
