- PSDEXGS ;BIR/BJW-Enter Existing Green Sheets at Startup ; 10 Feb 98
- ;;3.0; CONTROLLED SUBSTANCES ;**8,33,71**;13 Feb 97;Build 29
- ;**Y2K compliance**,added a "P" to date input string in ^DD(58.81,19)
- ;Reference to ^PSD(58.8 are covered by DBIA #2711
- ;Reference to ^PSD(58.81 are covered by DBIA #2808
- ;Reference to ^PSDRUG( are covered by DBIA #221
- I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
- I '$D(^XUSEC("PSJ RPHARM",DUZ))&('$D(^XUSEC("PSD TECH ADV",DUZ))) D Q
- .W !!,"Contact your Pharmacy Coordinator for access to enter existing Green Sheets",!,"into the Controlled Substances package.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
- S PSDUZ=DUZ
- W !!,?5,"The Order Status of all Green Sheets entered as existing before",!,?5,"the Controlled Substances package initialization will be",!,?10," *** DELIVERED - ACTIVELY ON NAOU ***",!!
- ASKD ;ask disp site
- S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)
- G:$P(PSDSITE,U,5) CHKD
- W ! K DIC,DA S DIC=58.8,DIC(0)="QEAZ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"
- S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=PSDSN
- D ^DIC K DIC G:Y<0 END
- S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN
- CHKD I '$D(^PSD(58.8,+PSDS,0)) W !!,"The ",PSDSN," vault is missing data.",!! G END
- NAOU ;select NAOU
- K DA,DIC S DIC=58.8,DIC(0)="QEA",DIC("A")="Select NAOU: "
- S DIC("S")="I $P(^(0),""^"",4)=+PSDS,$P(^(0),""^"",2)=""N"""
- D ^DIC K DIC G:Y<0 END S NAOU=+Y,NAOUN=$P(Y,"^",2)
- I '$D(^PSD(58.8,NAOU,0)) W !!,"This NAOU is missing data.",!! G END
- DRUG ;ask drug
- I '$O(^PSD(58.8,NAOU,1,0)) W !!,"There are no stocked drugs for this NAOU.",!! G END
- W !!,?15,"=> NAOU: ",NAOUN,!
- K DA,DIC S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,NAOU,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
- S DIC("S")="I $S('$P(^(0),""^"",14):1,+$P(^(0),""^"",14)>DT:1,1:0)"
- S DA(1)=+NAOU,DIC(0)="QEAM",DIC="^PSD(58.8,"_+NAOU_",1," D ^DIC K DIC G:Y<0 END S PSDRG=+Y,PSDRGN=$S($P($G(^PSDRUG(PSDRG,0)),"^")]"":$P(^(0),"^"),1:"DRUG NAME MISSING")
- I '$D(^PSD(58.8,NAOU,1,PSDRG,0)) W !!,PSDRGN," is missing",!,"data in ",NAOUN G END
- I '$D(^PSD(58.8,+PSDS,1,PSDRG,0)) W !!,PSDRGN," is not stocked",!,"in ",PSDSN,!! G END
- S NBKU=$P(^PSD(58.8,+PSDS,1,PSDRG,0),"^",8),NPKG=+$P(^(0),"^",9)
- I 'NPKG!(NBKU']"") W $C(7),!!,PSDRGN," is missing breakdown unit or",!,"package size in ",PSDSN,".",! G END
- GS W !!,"Enter Green Sheet #: " R X:DTIME I '$T!(X="")!(X["^") W !!,"** No action taken. **" G END
- I X'?1.9N D MSG1 G GS
- I 'X D MSG1 G GS
- I +$O(^PSD(58.81,"D",X,0)) W !!,"This number has already been used.",!! G GS
- S PSDPN=X K X
- QTY W !!,"Enter Quantity ("_NBKU_"/"_NPKG_"): " R X:DTIME I '$T!(X="")!(X["^") D MSG G END
- I X'?1.6N D MSG2 G QTY
- I 'X D MSG2 G QTY
- S QTY=X K X
- PHARM K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,18O" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D MSG G END
- S PHARM=$P(Y,"^")
- RDATE K DA,DIR,DTOUT,DUOUT S DIR("A")="DISPENSED DATE: ",DIR(0)="58.81,19OA" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D MSG G END
- S RDATE=$P(Y,"^")
- NURSE K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,20O" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D MSG G END
- S NURS=$P(Y,"^")
- MFG K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,12O" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D MSG G END
- S MFG=Y
- LOT K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,13O" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D MSG G END
- S LOT=Y
- EXP K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,14O" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D MSG G END
- S EXP=Y
- ;DAVE B (PSD*3*33) add PRINTED 2638 field
- PNT10 K DA,DIR,DTOUT,DUOUT S DIR(0)="58.81,103" D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) D MSG G END
- S PNT10=Y
- OK W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK"
- S DIR("?",1)="Answer 'YES' to post this Green Sheet information,",DIR("?")="answer 'NO' to erase this information and try again."
- D ^DIR K DIR G:$D(DIRUT) END
- I 'Y G QTY
- D ^PSDEXGS1 G DRUG
- END K %,%DT,%H,%I,DA,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,LOT,MFG
- K NAOU,NAOUN,NBKU,NPKG,NURS,PHARM,PSDA,PSDPN,PSDRG,PSDRGN,PSDRN,PSDS,PSDSN,PSDT,PSDUZ,RDATE,QTY,X,Y
- Q
- MSG W !!,"No action taken. The Green Sheet # ",PSDPN," has not been added to your CS files.",!
- Q
- MSG1 W !!,"You must enter a whole number between 1 and 999999999",!
- Q
- MSG2 W !!,"You must enter a whole number between 1 and 999999",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDEXGS 4439 printed Feb 18, 2025@23:12:21 Page 2
- PSDEXGS ;BIR/BJW-Enter Existing Green Sheets at Startup ; 10 Feb 98
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**8,33,71**;13 Feb 97;Build 29
- +2 ;**Y2K compliance**,added a "P" to date input string in ^DD(58.81,19)
- +3 ;Reference to ^PSD(58.8 are covered by DBIA #2711
- +4 ;Reference to ^PSD(58.81 are covered by DBIA #2808
- +5 ;Reference to ^PSDRUG( are covered by DBIA #221
- +6 IF '$DATA(PSDSITE)
- DO ^PSDSET
- if '$DATA(PSDSITE)
- QUIT
- +7 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))&('$DATA(^XUSEC("PSD TECH ADV",DUZ)))
- Begin DoDot:1
- +8 WRITE !!,"Contact your Pharmacy Coordinator for access to enter existing Green Sheets",!,"into the Controlled Substances package.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
- End DoDot:1
- QUIT
- +9 SET PSDUZ=DUZ
- +10 WRITE !!,?5,"The Order Status of all Green Sheets entered as existing before",!,?5,"the Controlled Substances package initialization will be",!,?10," *** DELIVERED - ACTIVELY ON NAOU ***",!!
- ASKD ;ask disp site
- +1 SET PSDS=$PIECE(PSDSITE,U,3)
- SET PSDSN=$PIECE(PSDSITE,U,4)
- +2 if $PIECE(PSDSITE,U,5)
- GOTO CHKD
- +3 WRITE !
- KILL DIC,DA
- SET DIC=58.8
- SET DIC(0)="QEAZ"
- SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"
- +4 SET DIC("A")="Select Primary Dispensing Site: "
- SET DIC("B")=PSDSN
- +5 DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- +6 SET PSDS=+Y
- SET PSDSN=$PIECE(Y,"^",2)
- SET $PIECE(PSDSITE,U,3)=+Y
- SET $PIECE(PSDSITE,U,4)=PSDSN
- CHKD IF '$DATA(^PSD(58.8,+PSDS,0))
- WRITE !!,"The ",PSDSN," vault is missing data.",!!
- GOTO END
- NAOU ;select NAOU
- +1 KILL DA,DIC
- SET DIC=58.8
- SET DIC(0)="QEA"
- SET DIC("A")="Select NAOU: "
- +2 SET DIC("S")="I $P(^(0),""^"",4)=+PSDS,$P(^(0),""^"",2)=""N"""
- +3 DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- SET NAOU=+Y
- SET NAOUN=$PIECE(Y,"^",2)
- +4 IF '$DATA(^PSD(58.8,NAOU,0))
- WRITE !!,"This NAOU is missing data.",!!
- GOTO END
- DRUG ;ask drug
- +1 IF '$ORDER(^PSD(58.8,NAOU,1,0))
- WRITE !!,"There are no stocked drugs for this NAOU.",!!
- GOTO END
- +2 WRITE !!,?15,"=> NAOU: ",NAOUN,!
- +3 KILL DA,DIC
- SET DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,NAOU,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
- +4 SET DIC("S")="I $S('$P(^(0),""^"",14):1,+$P(^(0),""^"",14)>DT:1,1:0)"
- +5 SET DA(1)=+NAOU
- SET DIC(0)="QEAM"
- SET DIC="^PSD(58.8,"_+NAOU_",1,"
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- SET PSDRG=+Y
- SET PSDRGN=$SELECT($PIECE($GET(^PSDRUG(PSDRG,0)),"^")]"":$PIECE(^(0),"^"),1:"DRUG NAME MISSING")
- +6 IF '$DATA(^PSD(58.8,NAOU,1,PSDRG,0))
- WRITE !!,PSDRGN," is missing",!,"data in ",NAOUN
- GOTO END
- +7 IF '$DATA(^PSD(58.8,+PSDS,1,PSDRG,0))
- WRITE !!,PSDRGN," is not stocked",!,"in ",PSDSN,!!
- GOTO END
- +8 SET NBKU=$PIECE(^PSD(58.8,+PSDS,1,PSDRG,0),"^",8)
- SET NPKG=+$PIECE(^(0),"^",9)
- +9 IF 'NPKG!(NBKU']"")
- WRITE $CHAR(7),!!,PSDRGN," is missing breakdown unit or",!,"package size in ",PSDSN,".",!
- GOTO END
- GS WRITE !!,"Enter Green Sheet #: "
- READ X:DTIME
- IF '$TEST!(X="")!(X["^")
- WRITE !!,"** No action taken. **"
- GOTO END
- +1 IF X'?1.9N
- DO MSG1
- GOTO GS
- +2 IF 'X
- DO MSG1
- GOTO GS
- +3 IF +$ORDER(^PSD(58.81,"D",X,0))
- WRITE !!,"This number has already been used.",!!
- GOTO GS
- +4 SET PSDPN=X
- KILL X
- QTY WRITE !!,"Enter Quantity ("_NBKU_"/"_NPKG_"): "
- READ X:DTIME
- IF '$TEST!(X="")!(X["^")
- DO MSG
- GOTO END
- +1 IF X'?1.6N
- DO MSG2
- GOTO QTY
- +2 IF 'X
- DO MSG2
- GOTO QTY
- +3 SET QTY=X
- KILL X
- PHARM KILL DA,DIR,DTOUT,DUOUT
- SET DIR(0)="58.81,18O"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO MSG
- GOTO END
- +1 SET PHARM=$PIECE(Y,"^")
- RDATE KILL DA,DIR,DTOUT,DUOUT
- SET DIR("A")="DISPENSED DATE: "
- SET DIR(0)="58.81,19OA"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO MSG
- GOTO END
- +1 SET RDATE=$PIECE(Y,"^")
- NURSE KILL DA,DIR,DTOUT,DUOUT
- SET DIR(0)="58.81,20O"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO MSG
- GOTO END
- +1 SET NURS=$PIECE(Y,"^")
- MFG KILL DA,DIR,DTOUT,DUOUT
- SET DIR(0)="58.81,12O"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO MSG
- GOTO END
- +1 SET MFG=Y
- LOT KILL DA,DIR,DTOUT,DUOUT
- SET DIR(0)="58.81,13O"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO MSG
- GOTO END
- +1 SET LOT=Y
- EXP KILL DA,DIR,DTOUT,DUOUT
- SET DIR(0)="58.81,14O"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO MSG
- GOTO END
- +1 SET EXP=Y
- +2 ;DAVE B (PSD*3*33) add PRINTED 2638 field
- PNT10 KILL DA,DIR,DTOUT,DUOUT
- SET DIR(0)="58.81,103"
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- DO MSG
- GOTO END
- +1 SET PNT10=Y
- OK WRITE !
- KILL DA,DIR,DIRUT
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Is this OK"
- +1 SET DIR("?",1)="Answer 'YES' to post this Green Sheet information,"
- SET DIR("?")="answer 'NO' to erase this information and try again."
- +2 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- +3 IF 'Y
- GOTO QTY
- +4 DO ^PSDEXGS1
- GOTO DRUG
- END KILL %,%DT,%H,%I,DA,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,LOT,MFG
- +1 KILL NAOU,NAOUN,NBKU,NPKG,NURS,PHARM,PSDA,PSDPN,PSDRG,PSDRGN,PSDRN,PSDS,PSDSN,PSDT,PSDUZ,RDATE,QTY,X,Y
- +2 QUIT
- MSG WRITE !!,"No action taken. The Green Sheet # ",PSDPN," has not been added to your CS files.",!
- +1 QUIT
- MSG1 WRITE !!,"You must enter a whole number between 1 and 999999999",!
- +1 QUIT
- MSG2 WRITE !!,"You must enter a whole number between 1 and 999999",!
- +1 QUIT