PSDORD1 ;BIR/LTL-CS Order Entry Listing and Cancel pending; 19 Dec 94
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
D PRT S PSDC="D" F PSD=1:1:$G(PSD(2)) S PSDD=$G(PSDD)_PSD_","
G:$G(PSDOUT) SKIP2
AC S DIR(0)="SA^A:Approve;D:Delete"
S DIR("A")="Approve or Delete (A/D): "
S DIR("?")="After selecting an action, you may select a range of orders."
S DIR("B")="Approve" D ^DIR K DIR N PSDC S PSDC=Y
G:$D(DIRUT) SKIP2
I $G(PSD(2))=1 S PSDD="1," G SKIP
S DIR(0)="L^1:"_$G(PSD(2)) W ! D ^DIR K DIR I $D(DIRUT) S PSDC="D" G SKIP2
S PSDD=Y
SKIP I PSDC="D" S DIR(0)="Y",DIR("B")="No",DIR("A")="Are you sure you want to cancel request(s) #"_$E(PSDD,1,($L(PSDD)-1)) W ! D ^DIR K DIR G:$D(DIRUT) SKIP2 G:'Y AC G SKIP2
N X,X1 D SIG^XUSESIG I X1="" S PSDC="D" G SKIP
SKIP2 S PSDD(1)=1 F S PSDD(2)=$P(PSDD,",",PSDD(1)) Q:'PSDD(2) S PSDD(1)=PSDD(1)+1 D
ORD .;update ord
.S PSDR=+$O(PSDB(PSDD(2),0)),PSDA=+$O(PSDB(PSDD(2),PSDR,0))
.S PSDQTY=$P($G(^PSD(58.8,+NAOU,1,+PSDR,3,+PSDA,0)),U,6)
.I PSDC="A" D NOW^%DTC S PSDT=+$E(%,1,12),DIE="^PSD(58.8,+NAOU,1,+PSDR,3,",DA(2)=NAOU,DA(1)=PSDR,DA=PSDA,DR="1////"_PSDT_";10////1" D ^DIE K DIE,DA,DR D PHARM^PSDORD2 K PSDA(PSDR,PSDA) Q
.D DEL^PSDORD2 K PSDA(PSDR,PSDA) S PSDOUT=0
END K DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,PSD,PSDOUT,PSDB,PSDD,X,Y
Q
PRT ;displays list
W @IOF,"Accessing pending requests for ",$P($G(^VA(200,DUZ,.1)),U,4),"...",!
K ^UTILITY($J,"W")
N X,DIWL,DIWR,DIWF S PSD=0,DIWL=1,DIWR=80,DIWF="W"
F S PSD=$O(^PSD(58.8,+PSDS,5,PSD)) Q:'PSD S X=$G(^PSD(58.8,+PSDS,5,PSD,0)) D ^DIWP
D ^DIWW
W !,"The following request(s) may be approved or deleted:",!
W !,"# DATE ORDERED",?20,"DRUG",?72,"QUANTITY",!! S PSD=0
F S PSD=$O(PSDA(PSD)) Q:'PSD!($G(PSDOUT)) S PSD(1)=0 F S PSD(1)=$O(PSDA(PSD,PSD(1))) Q:'PSD(1) S PSD(2)=$G(PSD(2))+1,PSDB(PSD(2),PSD,PSD(1))="" D Q:$G(PSDOUT)
.S Y=$E($P(PSDA(PSD,PSD(1)),U,2),1,7) X ^DD("DD") W !,PSD(2),?3,Y,?16
.W $P($G(^PSDRUG(PSD,0)),U),?72,$J($P(PSDA(PSD,PSD(1)),U,6),4)
.I $Y+2>IOSL S DIR(0)="E" D ^DIR K DIR S:Y<1 PSDOUT=1 W @IOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDORD1 2066 printed Dec 13, 2024@01:47:29 Page 2
PSDORD1 ;BIR/LTL-CS Order Entry Listing and Cancel pending; 19 Dec 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
+2 DO PRT
SET PSDC="D"
FOR PSD=1:1:$GET(PSD(2))
SET PSDD=$GET(PSDD)_PSD_","
+3 if $GET(PSDOUT)
GOTO SKIP2
AC SET DIR(0)="SA^A:Approve;D:Delete"
+1 SET DIR("A")="Approve or Delete (A/D): "
+2 SET DIR("?")="After selecting an action, you may select a range of orders."
+3 SET DIR("B")="Approve"
DO ^DIR
KILL DIR
NEW PSDC
SET PSDC=Y
+4 if $DATA(DIRUT)
GOTO SKIP2
+5 IF $GET(PSD(2))=1
SET PSDD="1,"
GOTO SKIP
+6 SET DIR(0)="L^1:"_$GET(PSD(2))
WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSDC="D"
GOTO SKIP2
+7 SET PSDD=Y
SKIP IF PSDC="D"
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Are you sure you want to cancel request(s) #"_$EXTRACT(PSDD,1,($LENGTH(PSDD)-1))
WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO SKIP2
if 'Y
GOTO AC
GOTO SKIP2
+1 NEW X,X1
DO SIG^XUSESIG
IF X1=""
SET PSDC="D"
GOTO SKIP
SKIP2 SET PSDD(1)=1
FOR
SET PSDD(2)=$PIECE(PSDD,",",PSDD(1))
if 'PSDD(2)
QUIT
SET PSDD(1)=PSDD(1)+1
Begin DoDot:1
ORD ;update ord
+1 SET PSDR=+$ORDER(PSDB(PSDD(2),0))
SET PSDA=+$ORDER(PSDB(PSDD(2),PSDR,0))
+2 SET PSDQTY=$PIECE($GET(^PSD(58.8,+NAOU,1,+PSDR,3,+PSDA,0)),U,6)
+3 IF PSDC="A"
DO NOW^%DTC
SET PSDT=+$EXTRACT(%,1,12)
SET DIE="^PSD(58.8,+NAOU,1,+PSDR,3,"
SET DA(2)=NAOU
SET DA(1)=PSDR
SET DA=PSDA
SET DR="1////"_PSDT_";10////1"
DO ^DIE
KILL DIE,DA,DR
DO PHARM^PSDORD2
KILL PSDA(PSDR,PSDA)
QUIT
+4 DO DEL^PSDORD2
KILL PSDA(PSDR,PSDA)
SET PSDOUT=0
End DoDot:1
END KILL DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,PSD,PSDOUT,PSDB,PSDD,X,Y
+1 QUIT
PRT ;displays list
+1 WRITE @IOF,"Accessing pending requests for ",$PIECE($GET(^VA(200,DUZ,.1)),U,4),"...",!
+2 KILL ^UTILITY($JOB,"W")
+3 NEW X,DIWL,DIWR,DIWF
SET PSD=0
SET DIWL=1
SET DIWR=80
SET DIWF="W"
+4 FOR
SET PSD=$ORDER(^PSD(58.8,+PSDS,5,PSD))
if 'PSD
QUIT
SET X=$GET(^PSD(58.8,+PSDS,5,PSD,0))
DO ^DIWP
+5 DO ^DIWW
+6 WRITE !,"The following request(s) may be approved or deleted:",!
+7 WRITE !,"# DATE ORDERED",?20,"DRUG",?72,"QUANTITY",!!
SET PSD=0
+8 FOR
SET PSD=$ORDER(PSDA(PSD))
if 'PSD!($GET(PSDOUT))
QUIT
SET PSD(1)=0
FOR
SET PSD(1)=$ORDER(PSDA(PSD,PSD(1)))
if 'PSD(1)
QUIT
SET PSD(2)=$GET(PSD(2))+1
SET PSDB(PSD(2),PSD,PSD(1))=""
Begin DoDot:1
+9 SET Y=$EXTRACT($PIECE(PSDA(PSD,PSD(1)),U,2),1,7)
XECUTE ^DD("DD")
WRITE !,PSD(2),?3,Y,?16
+10 WRITE $PIECE($GET(^PSDRUG(PSD,0)),U),?72,$JUSTIFY($PIECE(PSDA(PSD,PSD(1)),U,6),4)
+11 IF $Y+2>IOSL
SET DIR(0)="E"
DO ^DIR
KILL DIR
if Y<1
SET PSDOUT=1
WRITE @IOF
End DoDot:1
if $GET(PSDOUT)
QUIT
+12 QUIT
