- PSGPEN ;BIR/CML3 - FIND DEFAULT FOR PRE-EXCHANGE NEEDS ;15 May 2019 16:15:59
- ;;5.0;INPATIENT MEDICATIONS ;**30,37,50,58,115,110,127,129,323,317,357,386,327,390**;16 DEC 97;Build 7
- ;
- ; 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 PSJPADE
- S PSJPADE=$$PADE($G(PSJPWD),PSGP,PSGPENO_"U") ; PADE check - PSJ*5*317
- N PSJSITE,PSJPRN,PSJCLO,ND8 S PSJCLO=0,ND8=0 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)),ND8=$G(^PS(55,PSGP,5,PSGPENO,8))
- S:$P(ND8,"^",2) PSJCLO=1
- S PSGPENWS=0 I PSJPWD,'PSJCLO 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 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) 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 PSJPADE&'PSGPENWS W !!,"The dispense drug",$S(PSJPADE>1:"s",1:"")," for this order ",$S(PSJPADE>1:"are",1:"is a")," PADE item",$S(PSJPADE>1:"s",1:""),"." S PSGPEN=0
- I PSJPADE&PSGPENWS W !!,"The dispense drug",$S(PSJPADE>1:"s",1:"")," for this order ",$S(PSJPADE>1:"are",1:"is a")," WARD STOCK/PADE item",$S(PSJPADE>1:"s",1:""),"." S PSGPEN=0
- I PSGPENWS&'PSJPADE 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 '$G(PSJCLO),'PSGPENWS,PSJPWD,'PSJPADE 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,'$G(PSJCLO),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 of 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 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
- ;
- PADE(PSJPWD,PSGP,PSGORD) ; Pharmacy Automation Dispensing Equipment (PADE) check - PSJ*5*317
- ; INPUT: PSJPWD = Ward location
- ; PSGP = Patient DFN
- ; PSGORD = Order number
- ; OUTPUT: PADE = Can this order be dispensed via PADE?
- ;
- N PADE,DFN,PSJDDND,PSJWDFLG,PSJORCL
- ;I '$G(PSJPWD)!'$G(PSGP)!'$G(PSGORD) Q ""
- I '$G(PSGP)!'$G(PSGORD) Q ""
- S PADE="",DFN=$G(PSGP)
- ; Check DEFAULT 0 ON PADE PRE-EXCHANGE parameter
- D GETS^DIQ(59.6,+$G(PSJSYSW),8,"I","PSJWDFLG")
- S PSJORCL=$S($G(PSGORD)["P":$G(^PS(53.1,+$G(PSGORD),"DSS")),$G(PSGORD)["U":$G(^PS(55,+$G(PSGP),5,+$G(PSGORD),8)),$G(PSGORD)["V":$G(^PS(55,+$G(PSGP),"IV",+$G(PSGORD),"DSS")),1:"")
- I $G(PSJWDFLG("59.6",+$G(PSJSYSW)_",",8,"I"))!(+PSJORCL) D
- .N PSJPDLOC,PSJCLNK
- .; If clinic order, quit if clinic location is not linked to PADE
- .;S PSJORCL=$S($G(PSGORD)["P":$G(^PS(53.1,+$G(PSGORD),"DSS")),$G(PSGORD)["U":$G(^PS(55,+$G(PSGP),5,+$G(PSGORD),8)),$G(PSGORD)["V":$G(^PS(55,+$G(PSGP),"IV",+$G(PSGORD),"DSS")),1:"")
- .I PSJORCL,$P(PSJORCL,"^",2) S PSJCLNK=$$PADECL^PSJPAD50(+$G(PSJORCL)) Q:'PSJCLNK
- .I '$G(PSJCLNK) Q:'$$PADEWD^PSJPAD50(PSJPWD) ; Quit if patient location not linked to PADE
- .S PSJPDLOC=$S($G(PSGORD)["P":+$G(^PS(53.1,+PSGORD,"DSS"))_"C",$G(PSGORD)["U":+$G(^PS(55,+$G(DFN),5,+$G(PSGORD),8))_"C",1:"")
- .S:'PSJPDLOC PSJPDLOC=+$G(PSJPWD)
- .N PADEFLAG,DDCNT S PADEFLAG=1
- .I $G(PSGORD)["U" S Q=0 F DDCNT=0:1 S Q=$O(^PS(55,+$G(PSGP),5,+PSGORD,1,Q)) Q:'Q!'PADEFLAG S PSJDDND=$G(^(Q,0)) D
- ..S PADEFLAG=+$$DRGQTY^PSJPADSI(+PSJDDND,$S(PSJPDLOC["C":"CL",1:"WD"),+PSJPDLOC)
- .I $G(PSGORD)'["U" S Q=0 F DDCNT=0:1 S Q=$O(^PS(53.45,+$G(PSJSYSP),2,Q)) Q:'Q!'PADEFLAG S PSJDDND=$G(^(Q,0)) D
- ..S PADEFLAG=+$$DRGQTY^PSJPADSI(+PSJDDND,$S(PSJPDLOC["C":"CL",1:"WD"),+PSJPDLOC)
- .I DDCNT,PADEFLAG S PADE=DDCNT
- Q PADE
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPEN 8185 printed Feb 18, 2025@23:29:02 Page 2
- PSGPEN ;BIR/CML3 - FIND DEFAULT FOR PRE-EXCHANGE NEEDS ;15 May 2019 16:15:59
- +1 ;;5.0;INPATIENT MEDICATIONS ;**30,37,50,58,115,110,127,129,323,317,357,386,327,390**;16 DEC 97;Build 7
- +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 PSJPADE
- +3 ; PADE check - PSJ*5*317
- SET PSJPADE=$$PADE($GET(PSJPWD),PSGP,PSGPENO_"U")
- +4 NEW PSJSITE,PSJPRN,PSJCLO,ND8
- SET PSJCLO=0
- SET ND8=0
- SET PSJSITE=0
- SET PSJSITE=$ORDER(^PS(59.7,PSJSITE))
- IF $PIECE($GET(^(PSJSITE,26)),U,5)=1
- SET PSJPRN=1
- +5 DO NOW^%DTC
- SET PSGDT=%
- SET DT=$$DT^XLFDT
- SET PSGPEN=""
- SET ND=$GET(^PS(55,PSGP,5,PSGPENO,0))
- SET ND8=$GET(^PS(55,PSGP,5,PSGPENO,8))
- +6 if $PIECE(ND8,"^",2)
- SET PSJCLO=1
- +7 SET PSGPENWS=0
- IF PSJPWD
- IF 'PSJCLO
- 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
- +8 IF PSGPENWS
- 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=0
- if 'PSGPENWS
- QUIT
- SET $PIECE(PSGPENWS,"^",2)=1
- +9 IF PSJPADE&'PSGPENWS
- WRITE !!,"The dispense drug",$SELECT(PSJPADE>1:"s",1:"")," for this order ",$SELECT(PSJPADE>1:"are",1:"is a")," PADE item",$SELECT(PSJPADE>1:"s",1:""),"."
- SET PSGPEN=0
- +10 IF PSJPADE&PSGPENWS
- WRITE !!,"The dispense drug",$SELECT(PSJPADE>1:"s",1:"")," for this order ",$SELECT(PSJPADE>1:"are",1:"is a")," WARD STOCK/PADE item",$SELECT(PSJPADE>1:"s",1:""),"."
- SET PSGPEN=0
- +11 IF PSGPENWS&'PSJPADE
- 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
- +12 IF '$GET(PSJCLO)
- IF 'PSGPENWS
- IF PSJPWD
- IF 'PSJPADE
- 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
- +13 SET PSGPLF=$ORDER(^PS(53.5,"AB",WG,PSGDT))
- +14 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
- +15 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))
- +16 if 'PSGPLF
- DO GF
- IF PSGPLF
- SET PSGPLO=PSGPENO
- DO NCE
- DO ^PSGPL0
- if PSGPLC'<0
- SET PSGPEN=PSGPLC
- End DoDot:1
- +17 IF $GET(PSGPRIO)="DONE"
- SET PSGPEN=0
- +18 ;
- 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 '$GET(PSJCLO)
- 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 of 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 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
- +2 ;
- PADE(PSJPWD,PSGP,PSGORD) ; Pharmacy Automation Dispensing Equipment (PADE) check - PSJ*5*317
- +1 ; INPUT: PSJPWD = Ward location
- +2 ; PSGP = Patient DFN
- +3 ; PSGORD = Order number
- +4 ; OUTPUT: PADE = Can this order be dispensed via PADE?
- +5 ;
- +6 NEW PADE,DFN,PSJDDND,PSJWDFLG,PSJORCL
- +7 ;I '$G(PSJPWD)!'$G(PSGP)!'$G(PSGORD) Q ""
- +8 IF '$GET(PSGP)!'$GET(PSGORD)
- QUIT ""
- +9 SET PADE=""
- SET DFN=$GET(PSGP)
- +10 ; Check DEFAULT 0 ON PADE PRE-EXCHANGE parameter
- +11 DO GETS^DIQ(59.6,+$GET(PSJSYSW),8,"I","PSJWDFLG")
- +12 SET PSJORCL=$SELECT($GET(PSGORD)["P":$GET(^PS(53.1,+$GET(PSGORD),"DSS")),$GET(PSGORD)["U":$GET(^PS(55,+$GET(PSGP),5,+$GET(PSGORD),8)),$GET(PSGORD)["V":$GET(^PS(55,+$GET(PSGP),"IV",+$GET(PSGORD),"DSS")),1:"")
- +13 IF $GET(PSJWDFLG("59.6",+$GET(PSJSYSW)_",",8,"I"))!(+PSJORCL)
- Begin DoDot:1
- +14 NEW PSJPDLOC,PSJCLNK
- +15 ; If clinic order, quit if clinic location is not linked to PADE
- +16 ;S PSJORCL=$S($G(PSGORD)["P":$G(^PS(53.1,+$G(PSGORD),"DSS")),$G(PSGORD)["U":$G(^PS(55,+$G(PSGP),5,+$G(PSGORD),8)),$G(PSGORD)["V":$G(^PS(55,+$G(PSGP),"IV",+$G(PSGORD),"DSS")),1:"")
- +17 IF PSJORCL
- IF $PIECE(PSJORCL,"^",2)
- SET PSJCLNK=$$PADECL^PSJPAD50(+$GET(PSJORCL))
- if 'PSJCLNK
- QUIT
- +18 ; Quit if patient location not linked to PADE
- IF '$GET(PSJCLNK)
- if '$$PADEWD^PSJPAD50(PSJPWD)
- QUIT
- +19 SET PSJPDLOC=$SELECT($GET(PSGORD)["P":+$GET(^PS(53.1,+PSGORD,"DSS"))_"C",$GET(PSGORD)["U":+$GET(^PS(55,+$GET(DFN),5,+$GET(PSGORD),8))_"C",1:"")
- +20 if 'PSJPDLOC
- SET PSJPDLOC=+$GET(PSJPWD)
- +21 NEW PADEFLAG,DDCNT
- SET PADEFLAG=1
- +22 IF $GET(PSGORD)["U"
- SET Q=0
- FOR DDCNT=0:1
- SET Q=$ORDER(^PS(55,+$GET(PSGP),5,+PSGORD,1,Q))
- if 'Q!'PADEFLAG
- QUIT
- SET PSJDDND=$GET(^(Q,0))
- Begin DoDot:2
- +23 SET PADEFLAG=+$$DRGQTY^PSJPADSI(+PSJDDND,$SELECT(PSJPDLOC["C":"CL",1:"WD"),+PSJPDLOC)
- End DoDot:2
- +24 IF $GET(PSGORD)'["U"
- SET Q=0
- FOR DDCNT=0:1
- SET Q=$ORDER(^PS(53.45,+$GET(PSJSYSP),2,Q))
- if 'Q!'PADEFLAG
- QUIT
- SET PSJDDND=$GET(^(Q,0))
- Begin DoDot:2
- +25 SET PADEFLAG=+$$DRGQTY^PSJPADSI(+PSJDDND,$SELECT(PSJPDLOC["C":"CL",1:"WD"),+PSJPDLOC)
- End DoDot:2
- +26 IF DDCNT
- IF PADEFLAG
- SET PADE=DDCNT
- End DoDot:1
- +27 QUIT PADE
- +28 ;