PSDORV1 ;BIR/JPW-IV Pharm CS Order Entry (cont'd) ; 2 Aug 94
;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
ASK ;displays order for review
D DISPLAY
W !! K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this OK",DIR("?",1)="Answer 'YES' to send this request to pharmacy for processing,"
S DIR("?",2)="or 'NO' to edit or delete this request,",DIR("?")="or '^' to quit and DELETE this CS order request." D ^DIR K DIR
I $D(DIRUT) S PSDOUT=1 D DEL Q
I 'Y D EDIT Q:PSDOUT G ASK
I Y D PHARM W !! W:$D(ORD) "Your order request #"_CNT1_" of "_CNT W ?32,"Sent to Pharmacy...",!! R:$D(ORD) "Press <RET> to continue",X:DTIME,!!
Q
DISPLAY ;displays order request to screen
K LN S $P(LN,"-",80)=""
W @IOF,!,?23,"Controlled Substance Order Request" I $D(ORD) W " # "_CNT1_" of "_CNT
W !!,"Pharmacy Dispensing #: ",!,"Requested by",?16,": ",$P($G(^VA(200,PSDUZ,0)),"^"),?52,"Request Date: ",REQD,!,LN,!
W !,"Drug",?16,": ",PSDRN,?56,"Quantity: ",?66,PSDQTY,!,"Dispensed by",?16,": N/A",?50,"Dispensed Date: N/A"
W !,"Disp. Location",?16,": " W:+PSDS $P($G(^PSD(58.8,+PSDS,0)),"^") W !,"Exp. Date",?16,": ",!,"Manufacturer",?16,": ",!,"Lot #",?16,": "
W !,"Ord. Location",?16,": ",NAOUN,!,"Order Status",?16,": ",$P($G(^PSD(58.82,1,0)),"^"),!,"Comments:"
I $D(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0)) K ^UTILITY($J,"W") F TEXT=0:0 S TEXT=$O(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,TEXT)) Q:'TEXT D
.S X=$G(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,TEXT,0)),DIWL=5,DIWR=75,DIWF="W" D ^DIWP
I D ^DIWW
Q
EDIT ;edit or delete order request
W !!,"Edit or Delete this Order Request: EDIT// " R X:DTIME I '$T S PSDOUT=1 D DEL Q
Q:X["^" S X=$E(X) S:X="" X="E" I "EeDd"'[X W !!,"Press <RET> to edit this order request, or enter 'D' to delete the request.",! G EDIT
I "Dd"[X D DEL Q
K DA,DIE,DR S DA=PSDA,DA(1)=PSDR,DA(2)=NAOU,DIE="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,",DR="3;13" D ^DIE K DIE,DR
Q
DEL ;deletes order request
S PSDOUT=1 W !!,?25,"Request being deleted...",! K DIK S DA=PSDA,DA(1)=PSDR,DA(2)=NAOU,DIK="^PSD(58.8,"_NAOU_",1,"_PSDR_",3," D ^DIK K DIK
Q
PHARM ;create worksheet entry in file 58.85
W ?5,!!,"Processing your request now..." F L +^PSD(58.85,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
ADD S PSDREC=$P(^PSD(58.85,0),"^",3)+1 I $D(^PSD(58.85,PSDREC)) S $P(^PSD(58.85,0),"^",3)=PSDREC G ADD
K DA,DIC,DIE,DR,DLAYGO S (DIC,DIE,DLAYGO)=58.85,DIC(0)="L",X=PSDREC D ^DIC K DIC,DLAYGO
L -^PSD(58.85,0)
S PSDRD=$S($P($G(^PSD(58.8,NAOU,1,PSDR,3,PSDA,0)),"^",2):$P(^(0),"^",2),1:DT)
S DA=PSDREC,DR="1////"_PSDS_";2////"_NAOU_";3////"_PSDR_";4////"_PSDA_";5////"_PSDQTY_";6////1;12////"_PSDUZ_";19////"_PSDRD D ^DIE K DIE
I $D(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0)) S ^PSD(58.85,PSDREC,1,0)=^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0) D
.F WORD=0:0 S WORD=$O(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD)) Q:'WORD S ^PSD(58.85,PSDREC,1,WORD,0)=^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD,0)
K DA,DIC,DIE,DLAYGO,DR,PSDREC,WORD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDORV1 2948 printed Dec 13, 2024@01:47:50 Page 2
PSDORV1 ;BIR/JPW-IV Pharm CS Order Entry (cont'd) ; 2 Aug 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
ASK ;displays order for review
+1 DO DISPLAY
+2 WRITE !!
KILL DA,DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Is this OK"
SET DIR("?",1)="Answer 'YES' to send this request to pharmacy for processing,"
+3 SET DIR("?",2)="or 'NO' to edit or delete this request,"
SET DIR("?")="or '^' to quit and DELETE this CS order request."
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET PSDOUT=1
DO DEL
QUIT
+5 IF 'Y
DO EDIT
if PSDOUT
QUIT
GOTO ASK
+6 IF Y
DO PHARM
WRITE !!
if $DATA(ORD)
WRITE "Your order request #"_CNT1_" of "_CNT
WRITE ?32,"Sent to Pharmacy...",!!
if $DATA(ORD)
READ "Press <RET> to continue",X:DTIME,!!
+7 QUIT
DISPLAY ;displays order request to screen
+1 KILL LN
SET $PIECE(LN,"-",80)=""
+2 WRITE @IOF,!,?23,"Controlled Substance Order Request"
IF $DATA(ORD)
WRITE " # "_CNT1_" of "_CNT
+3 WRITE !!,"Pharmacy Dispensing #: ",!,"Requested by",?16,": ",$PIECE($GET(^VA(200,PSDUZ,0)),"^"),?52,"Request Date: ",REQD,!,LN,!
+4 WRITE !,"Drug",?16,": ",PSDRN,?56,"Quantity: ",?66,PSDQTY,!,"Dispensed by",?16,": N/A",?50,"Dispensed Date: N/A"
+5 WRITE !,"Disp. Location",?16,": "
if +PSDS
WRITE $PIECE($GET(^PSD(58.8,+PSDS,0)),"^")
WRITE !,"Exp. Date",?16,": ",!,"Manufacturer",?16,": ",!,"Lot #",?16,": "
+6 WRITE !,"Ord. Location",?16,": ",NAOUN,!,"Order Status",?16,": ",$PIECE($GET(^PSD(58.82,1,0)),"^"),!,"Comments:"
+7 IF $DATA(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0))
KILL ^UTILITY($JOB,"W")
FOR TEXT=0:0
SET TEXT=$ORDER(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,TEXT))
if 'TEXT
QUIT
Begin DoDot:1
+8 SET X=$GET(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,TEXT,0))
SET DIWL=5
SET DIWR=75
SET DIWF="W"
DO ^DIWP
End DoDot:1
+9 IF $TEST
DO ^DIWW
+10 QUIT
EDIT ;edit or delete order request
+1 WRITE !!,"Edit or Delete this Order Request: EDIT// "
READ X:DTIME
IF '$TEST
SET PSDOUT=1
DO DEL
QUIT
+2 if X["^"
QUIT
SET X=$EXTRACT(X)
if X=""
SET X="E"
IF "EeDd"'[X
WRITE !!,"Press <RET> to edit this order request, or enter 'D' to delete the request.",!
GOTO EDIT
+3 IF "Dd"[X
DO DEL
QUIT
+4 KILL DA,DIE,DR
SET DA=PSDA
SET DA(1)=PSDR
SET DA(2)=NAOU
SET DIE="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,"
SET DR="3;13"
DO ^DIE
KILL DIE,DR
+5 QUIT
DEL ;deletes order request
+1 SET PSDOUT=1
WRITE !!,?25,"Request being deleted...",!
KILL DIK
SET DA=PSDA
SET DA(1)=PSDR
SET DA(2)=NAOU
SET DIK="^PSD(58.8,"_NAOU_",1,"_PSDR_",3,"
DO ^DIK
KILL DIK
+2 QUIT
PHARM ;create worksheet entry in file 58.85
+1 WRITE ?5,!!,"Processing your request now..."
FOR
LOCK +^PSD(58.85,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
ADD SET PSDREC=$PIECE(^PSD(58.85,0),"^",3)+1
IF $DATA(^PSD(58.85,PSDREC))
SET $PIECE(^PSD(58.85,0),"^",3)=PSDREC
GOTO ADD
+1 KILL DA,DIC,DIE,DR,DLAYGO
SET (DIC,DIE,DLAYGO)=58.85
SET DIC(0)="L"
SET X=PSDREC
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.85,0)
+3 SET PSDRD=$SELECT($PIECE($GET(^PSD(58.8,NAOU,1,PSDR,3,PSDA,0)),"^",2):$PIECE(^(0),"^",2),1:DT)
+4 SET DA=PSDREC
SET DR="1////"_PSDS_";2////"_NAOU_";3////"_PSDR_";4////"_PSDA_";5////"_PSDQTY_";6////1;12////"_PSDUZ_";19////"_PSDRD
DO ^DIE
KILL DIE
+5 IF $DATA(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0))
SET ^PSD(58.85,PSDREC,1,0)=^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,0)
Begin DoDot:1
+6 FOR WORD=0:0
SET WORD=$ORDER(^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD))
if 'WORD
QUIT
SET ^PSD(58.85,PSDREC,1,WORD,0)=^PSD(58.8,NAOU,1,PSDR,3,PSDA,1,WORD,0)
End DoDot:1
+7 KILL DA,DIC,DIE,DLAYGO,DR,PSDREC,WORD
+8 QUIT
