PSAVER2 ;BIR/JMB-Verify Invoices - CONT'D ;10/7/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,60,64**; 10/24/97;Build 4
;This routine contains the prompts for the fields that the verifier
;is allowed to edit.
;
;References to ^DIC(51.5, are covered by IA #1931
;References to ^PSDRUG( are covered by IA #2095
;References to ^PSDRUG("C" are covered by IA #2095
;
ASKDRUG W !,"If the item will never be in the DRUG, press the Return key then",!,"answer YES to the ""Is this a supply item?"" prompt. To bypass this",!,"line item, enter ""^"" then press the Return key.",!
S PSAGAIN=0,PSABEFOR=PSADRG,DIC(0)="AEMQZ",DIC="^PSDRUG(" D ^DIC K DIC
I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
S PSADJFLD="D",PSAREA="",PSASUPP=0
I +Y=-1 D Q:PSASUPP!(PSAOUT)
.S PSAVER=1 D SUPPLY^PSANDF Q:PSAOUT I 'PSASUPP S PSAGAIN=1 Q
.S PSA50IEN=0,PSADJ=PSAREA,PSAREA="" K ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)
.D RECORD
G:$G(PSAGAIN) ASKDRUG
S (PSA50IEN,PSADJ,PSADRG)=+Y D RECORD,HDR^PSAVER1,VERDISP^PSAUTL4
I PSANDC'="",$O(^PSDRUG("C",PSANDC,PSA50IEN,0)) D
.S PSASUB=+$O(^PSDRUG("C",PSANDC,PSA50IEN,0)),$P(^PSD(58.811,PSAIEN,1,PSAIEN1,2),"^",3)=PSASUB
.I '+$P($G(^PSDRUG(PSA50IEN,1,PSASUB,0)),"^",7) D DUOU Q
.I +$P($G(^PSDRUG(PSA50IEN,1,PSASUB,0)),"^",7),+$P($G(^PSDRUG(PSA50IEN,1,PSASUB,0)),"^",7)'=+$P($G(^PSDRUG(PSABEFOR,1,PSASUB,0)),"^",7) D DUOU
;
I PSANDC'="",'$O(^PSDRUG("C",PSANDC,PSA50IEN,0)),PSA50IEN'=PSABEFOR D DUOU
;
I PSANDC="",PSAUPC="" D
.W !,"The vendor did not send a NDC or UPC for the drug. Enter the",!,"NDC if it is available. Enter the UPC if you do not know the NDC.",!
.S DIR(0)="SA^N:NDC;U:UPC",DIR("A")="Will you enter the NDC or UPC? ",DIR("B")="N",DIR("??")="^D NDCUPC^PSANDF1" D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
.I Y="N" D GETNDC^PSANDF Q:PSAOUT S PSANDC=Y D:PSANDC'="" ADDDATA
.I Y="U" D GETUPC^PSANDF Q:PSAOUT S PSANDC="S"_Y,PSAUPC=Y D:PSANDC'="" ADDDATA
Q
;
ADDDATA ;Adds the missing NDC and/or UPC
K DA S DA(2)=PSAIEN,DA(1)=PSAIEN1,DA=PSALINE,DIE="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,",DR="13///^S X="_PSANDC_$S(PSAUPC'="":";15///^S X="_PSAUPC,1:"")
F L +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE L -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
K DIE I $G(DTOUT)!($G(DUOUT)) S PSAOUT=0 Q
D VERDISP^PSAUTL4
Q
RECORD ;Adds adjusted data to DA ORDERS file
S PSANEW=0
I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0)) S ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0)="^58.811259SA^^"
I $D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B",PSADJFLD)) D Q
.S DA=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B",PSADJFLD,0))
.I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,DA,0)) D NEW Q
.D ADJ
;
NEW S:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0)) DIC("P")=$P(^DD(58.81125,9,0),"^",2) K DA
S DA(3)=PSAIEN,DA(2)=PSAIEN1,DA(1)=PSALINE,X=PSADJFLD,DIC="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="L",DLAYGO=58.811
F L +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIC L -^PSD(58.811,PSAIEN,1,PSAIEN1,0) K DIC,DLAYGO S DA=+Y
;
ADJ S DA(3)=PSAIEN,DA(2)=PSAIEN1,DA(1)=PSALINE,DIE="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
;
;PSA*3*3 (DaveB 1JUN98)
S DR="5///^S X=PSADJ"_$S(PSAREA'="":";6////^S X=PSAREA",1:"")_";7///^S X="_DT_";8////^S X="_DUZ ; *60
F L +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE
INDEX S DIK=DIE D IX1^DIK K DIE,DIK L -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
Q
;
DUOU ;Gets Dispense Units Per Order Unit
;DAVE B (PSA*3*12) If PSASUPP is defined, the item is supply
;no need to ask for dispense units per order unit.
I $G(PSASUPP)=1 W !,"Item appears to be marked for supply, no need to enter Dispense Units Per Order Unit." Q
W !,"DISPENSE UNITS: "_$S($P($G(^PSDRUG(PSA50IEN,660)),"^",8)'="":$P($G(^PSDRUG(PSA50IEN,660)),"^",8),1:"Blank")
S DIR(0)="NO^::2",DIR("A")="DISPENSE UNITS PER ORDER UNIT",DIR("B")=$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^")
S DIR("?")="Enter the number of dispense units contained in one order unit",DIR("??")="^D DUOUHELP^PSAPROC3"
D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
S $P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^")=+Y S:+Y PSASET=1
Q:Y'=""
;
W !!,"The dispense units per order unit must be entered",!,"to change the status of the invoice to Verified."
S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to enter the data now"
S DIR("?",1)="Enter Yes to return to the DISPENSE UNITS PER ORDER UNIT prompt.",DIR("?")="Enter No to bypass entering the dispense units now."
S DIR("??")="^D DUOUYN^PSAPROC8" D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
W ! G:+Y DUOU
Q
;
OU ;Get order unit
S DIC(0)="QAEMZ",DIC="^DIC(51.5,",DIC("A")="ORDER UNIT: ",DR=.01 S:+PSAOU&($P($G(^DIC(51.5,+PSAOU,0)),"^")'="") DIC("B")=$P(^DIC(51.5,+PSAOU,0),"^") D ^DIC K DIC
I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
;
;PSA*3*12 Dave B, allow verifier to change OU to original if necessary
G:Y=-1 OU S PSADJFLD="O",PSADJ=+Y,PSAREA="" D RECORD
Q
;
PHARM ;Pharmacy Location/Master Vault -- DR is set prior to the call.
K DA S DA(1)=PSAIEN,DA=PSAIEN1,DIE="^PSD(58.811,"_DA(1)_",1," D ^DIE K DIE
S:$G(DTOUT)!($G(DUOUT)) PSAOUT=1
Q
;
QTY ;Adjust the quantity received
S DIR(0)="N",DIR("A")="QUANTITY RECEIVED",DIR("B")=PSAQTY
S DIR("?",1)="If the quantity received is different than the invoiced or",DIR("?")="adjusted quantity, enter the correct quantity received.",DIR("??")="^D QTYHELP^PSAPROC3"
D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
Q:PSAQTY=+Y S PSADJ=+Y
S DIR(0)="F^1:30",DIR("A")="ADJUSTMENT REASON",DIR("?")="Enter the reason you adjusted the quantity received.",DIR("??")="^D ADJREA^PSAPROC3"
D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
S PSADJFLD="Q",PSAREA=Y D RECORD
Q
;
RECD ;Date Received
K PSARECD S PSAREC=$S(+$P(PSAIN,"^",7):+$P(PSAIN,"^",7),+$P(PSAIN,"^",6):+$P(PSAIN,"^",6),1:"")
S DIR(0)="D",DIR("A")="Date received",DIR("?")="Enter the date the drugs were received.",DIR("??")="^D RECHELP^PSAPROC3" S:PSAREC DIR("B")=$$FMTE^XLFDT(PSAREC)
D ^DIR K DIR I $G(DIRUT) S PSAOUT=1 Q
Q:'+$P(PSAIN,"^",7)&(+Y=+$P(PSAIN,"^",6))
Q:+$P(PSAIN,"^",6)'=+$P(PSAIN,"^",7)&(+$P(PSAIN,"^",7)=+Y)
S:+$P(PSAIN,"^",6)=+Y PSARECD="@"
S:+$P(PSAIN,"^",6)'=+Y&(+$P(PSAIN,"^",7)'=+Y) PSARECD=+Y
Q:'$D(PSARECD) K DA
S DA(1)=PSAIEN,DA=PSAIEN1,DIE="^PSD(58.811,"_DA(1)_",1,",DR="8///"_$S(+PSARECD:"^S X="_PSARECD,1:"@")
F L +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE L -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
K DIE
I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1
Q
;
REORDER ;Enter reorder level for drug if the field is blank.
S DIR(0)="NO^0:99999",DIR("A")="REORDER LEVEL (in Dispense Units)",DIR("??")="^D REORD^PSAPROC8",DIR("B")=+PSAREORD
S DIR("?")="Enter the minimum number of dispense units to keep in the "_$S(+$P(PSADATA,"^",10):"master vault",1:"pharmacy location")_"."
D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
S $P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^",2)=+Y
Q
STOCK ;Enter stock level for drug if the field is blank.
S DIR(0)="NO^0:99999",DIR("A")="STOCK LEVEL (in Dispense Units)",DIR("??")="^D STKLEVEL^PSAPROC8",DIR("B")=+PSASTOCK
S DIR("?")="Enter the ideal number of dispense units to keep on the shelf."
D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
S $P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^",4)=+Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAVER2 7439 printed Apr 09, 2024@20:54:10 Page 2
PSAVER2 ;BIR/JMB-Verify Invoices - CONT'D ;10/7/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,60,64**; 10/24/97;Build 4
+2 ;This routine contains the prompts for the fields that the verifier
+3 ;is allowed to edit.
+4 ;
+5 ;References to ^DIC(51.5, are covered by IA #1931
+6 ;References to ^PSDRUG( are covered by IA #2095
+7 ;References to ^PSDRUG("C" are covered by IA #2095
+8 ;
ASKDRUG WRITE !,"If the item will never be in the DRUG, press the Return key then",!,"answer YES to the ""Is this a supply item?"" prompt. To bypass this",!,"line item, enter ""^"" then press the Return key.",!
+1 SET PSAGAIN=0
SET PSABEFOR=PSADRG
SET DIC(0)="AEMQZ"
SET DIC="^PSDRUG("
DO ^DIC
KILL DIC
+2 IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
QUIT
+3 SET PSADJFLD="D"
SET PSAREA=""
SET PSASUPP=0
+4 IF +Y=-1
Begin DoDot:1
+5 SET PSAVER=1
DO SUPPLY^PSANDF
if PSAOUT
QUIT
IF 'PSASUPP
SET PSAGAIN=1
QUIT
+6 SET PSA50IEN=0
SET PSADJ=PSAREA
SET PSAREA=""
KILL ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)
+7 DO RECORD
End DoDot:1
if PSASUPP!(PSAOUT)
QUIT
+8 if $GET(PSAGAIN)
GOTO ASKDRUG
+9 SET (PSA50IEN,PSADJ,PSADRG)=+Y
DO RECORD
DO HDR^PSAVER1
DO VERDISP^PSAUTL4
+10 IF PSANDC'=""
IF $ORDER(^PSDRUG("C",PSANDC,PSA50IEN,0))
Begin DoDot:1
+11 SET PSASUB=+$ORDER(^PSDRUG("C",PSANDC,PSA50IEN,0))
SET $PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,2),"^",3)=PSASUB
+12 IF '+$PIECE($GET(^PSDRUG(PSA50IEN,1,PSASUB,0)),"^",7)
DO DUOU
QUIT
+13 IF +$PIECE($GET(^PSDRUG(PSA50IEN,1,PSASUB,0)),"^",7)
IF +$PIECE($GET(^PSDRUG(PSA50IEN,1,PSASUB,0)),"^",7)'=+$PIECE($GET(^PSDRUG(PSABEFOR,1,PSASUB,0)),"^",7)
DO DUOU
End DoDot:1
+14 ;
+15 IF PSANDC'=""
IF '$ORDER(^PSDRUG("C",PSANDC,PSA50IEN,0))
IF PSA50IEN'=PSABEFOR
DO DUOU
+16 ;
+17 IF PSANDC=""
IF PSAUPC=""
Begin DoDot:1
+18 WRITE !,"The vendor did not send a NDC or UPC for the drug. Enter the",!,"NDC if it is available. Enter the UPC if you do not know the NDC.",!
+19 SET DIR(0)="SA^N:NDC;U:UPC"
SET DIR("A")="Will you enter the NDC or UPC? "
SET DIR("B")="N"
SET DIR("??")="^D NDCUPC^PSANDF1"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+20 IF Y="N"
DO GETNDC^PSANDF
if PSAOUT
QUIT
SET PSANDC=Y
if PSANDC'=""
DO ADDDATA
+21 IF Y="U"
DO GETUPC^PSANDF
if PSAOUT
QUIT
SET PSANDC="S"_Y
SET PSAUPC=Y
if PSANDC'=""
DO ADDDATA
End DoDot:1
+22 QUIT
+23 ;
ADDDATA ;Adds the missing NDC and/or UPC
+1 KILL DA
SET DA(2)=PSAIEN
SET DA(1)=PSAIEN1
SET DA=PSALINE
SET DIE="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,"
SET DR="13///^S X="_PSANDC_$SELECT(PSAUPC'="":";15///^S X="_PSAUPC,1:"")
+2 FOR
LOCK +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+3 DO ^DIE
LOCK -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
+4 KILL DIE
IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=0
QUIT
+5 DO VERDISP^PSAUTL4
+6 QUIT
RECORD ;Adds adjusted data to DA ORDERS file
+1 SET PSANEW=0
+2 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0))
SET ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0)="^58.811259SA^^"
+3 IF $DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B",PSADJFLD))
Begin DoDot:1
+4 SET DA=$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B",PSADJFLD,0))
+5 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,DA,0))
DO NEW
QUIT
+6 DO ADJ
End DoDot:1
QUIT
+7 ;
NEW if '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,0))
SET DIC("P")=$PIECE(^DD(58.81125,9,0),"^",2)
KILL DA
+1 SET DA(3)=PSAIEN
SET DA(2)=PSAIEN1
SET DA(1)=PSALINE
SET X=PSADJFLD
SET DIC="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
SET DIC(0)="L"
SET DLAYGO=58.811
+2 FOR
LOCK +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+3 DO ^DIC
LOCK -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
KILL DIC,DLAYGO
SET DA=+Y
+4 ;
ADJ SET DA(3)=PSAIEN
SET DA(2)=PSAIEN1
SET DA(1)=PSALINE
SET DIE="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
+1 ;
+2 ;PSA*3*3 (DaveB 1JUN98)
+3 ; *60
SET DR="5///^S X=PSADJ"_$SELECT(PSAREA'="":";6////^S X=PSAREA",1:"")_";7///^S X="_DT_";8////^S X="_DUZ
+4 FOR
LOCK +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+5 DO ^DIE
INDEX SET DIK=DIE
DO IX1^DIK
KILL DIE,DIK
LOCK -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
+1 QUIT
+2 ;
DUOU ;Gets Dispense Units Per Order Unit
+1 ;DAVE B (PSA*3*12) If PSASUPP is defined, the item is supply
+2 ;no need to ask for dispense units per order unit.
+3 IF $GET(PSASUPP)=1
WRITE !,"Item appears to be marked for supply, no need to enter Dispense Units Per Order Unit."
QUIT
+4 WRITE !,"DISPENSE UNITS: "_$SELECT($PIECE($GET(^PSDRUG(PSA50IEN,660)),"^",8)'="":$PIECE($GET(^PSDRUG(PSA50IEN,660)),"^",8),1:"Blank")
+5 SET DIR(0)="NO^::2"
SET DIR("A")="DISPENSE UNITS PER ORDER UNIT"
SET DIR("B")=$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^")
+6 SET DIR("?")="Enter the number of dispense units contained in one order unit"
SET DIR("??")="^D DUOUHELP^PSAPROC3"
+7 DO ^DIR
KILL DIR
IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
QUIT
+8 SET $PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^")=+Y
if +Y
SET PSASET=1
+9 if Y'=""
QUIT
+10 ;
+11 WRITE !!,"The dispense units per order unit must be entered",!,"to change the status of the invoice to Verified."
+12 SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Do you want to enter the data now"
+13 SET DIR("?",1)="Enter Yes to return to the DISPENSE UNITS PER ORDER UNIT prompt."
SET DIR("?")="Enter No to bypass entering the dispense units now."
+14 SET DIR("??")="^D DUOUYN^PSAPROC8"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+15 WRITE !
if +Y
GOTO DUOU
+16 QUIT
+17 ;
OU ;Get order unit
+1 SET DIC(0)="QAEMZ"
SET DIC="^DIC(51.5,"
SET DIC("A")="ORDER UNIT: "
SET DR=.01
if +PSAOU&($PIECE($GET(^DIC(51.5,+PSAOU,0)),"^")'="")
SET DIC("B")=$PIECE(^DIC(51.5,+PSAOU,0),"^")
DO ^DIC
KILL DIC
+2 IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
QUIT
+3 ;
+4 ;PSA*3*12 Dave B, allow verifier to change OU to original if necessary
+5 if Y=-1
GOTO OU
SET PSADJFLD="O"
SET PSADJ=+Y
SET PSAREA=""
DO RECORD
+6 QUIT
+7 ;
PHARM ;Pharmacy Location/Master Vault -- DR is set prior to the call.
+1 KILL DA
SET DA(1)=PSAIEN
SET DA=PSAIEN1
SET DIE="^PSD(58.811,"_DA(1)_",1,"
DO ^DIE
KILL DIE
+2 if $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
+3 QUIT
+4 ;
QTY ;Adjust the quantity received
+1 SET DIR(0)="N"
SET DIR("A")="QUANTITY RECEIVED"
SET DIR("B")=PSAQTY
+2 SET DIR("?",1)="If the quantity received is different than the invoiced or"
SET DIR("?")="adjusted quantity, enter the correct quantity received."
SET DIR("??")="^D QTYHELP^PSAPROC3"
+3 DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+4 if PSAQTY=+Y
QUIT
SET PSADJ=+Y
+5 SET DIR(0)="F^1:30"
SET DIR("A")="ADJUSTMENT REASON"
SET DIR("?")="Enter the reason you adjusted the quantity received."
SET DIR("??")="^D ADJREA^PSAPROC3"
+6 DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+7 SET PSADJFLD="Q"
SET PSAREA=Y
DO RECORD
+8 QUIT
+9 ;
RECD ;Date Received
+1 KILL PSARECD
SET PSAREC=$SELECT(+$PIECE(PSAIN,"^",7):+$PIECE(PSAIN,"^",7),+$PIECE(PSAIN,"^",6):+$PIECE(PSAIN,"^",6),1:"")
+2 SET DIR(0)="D"
SET DIR("A")="Date received"
SET DIR("?")="Enter the date the drugs were received."
SET DIR("??")="^D RECHELP^PSAPROC3"
if PSAREC
SET DIR("B")=$$FMTE^XLFDT(PSAREC)
+3 DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+4 if '+$PIECE(PSAIN,"^",7)&(+Y=+$PIECE(PSAIN,"^",6))
QUIT
+5 if +$PIECE(PSAIN,"^",6)'=+$PIECE(PSAIN,"^",7)&(+$PIECE(PSAIN,"^",7)=+Y)
QUIT
+6 if +$PIECE(PSAIN,"^",6)=+Y
SET PSARECD="@"
+7 if +$PIECE(PSAIN,"^",6)'=+Y&(+$PIECE(PSAIN,"^",7)'=+Y)
SET PSARECD=+Y
+8 if '$DATA(PSARECD)
QUIT
KILL DA
+9 SET DA(1)=PSAIEN
SET DA=PSAIEN1
SET DIE="^PSD(58.811,"_DA(1)_",1,"
SET DR="8///"_$SELECT(+PSARECD:"^S X="_PSARECD,1:"@")
+10 FOR
LOCK +^PSD(58.811,PSAIEN,1,PSAIEN1,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+11 DO ^DIE
LOCK -^PSD(58.811,PSAIEN,1,PSAIEN1,0)
+12 KILL DIE
+13 IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
+14 QUIT
+15 ;
REORDER ;Enter reorder level for drug if the field is blank.
+1 SET DIR(0)="NO^0:99999"
SET DIR("A")="REORDER LEVEL (in Dispense Units)"
SET DIR("??")="^D REORD^PSAPROC8"
SET DIR("B")=+PSAREORD
+2 SET DIR("?")="Enter the minimum number of dispense units to keep in the "_$SELECT(+$PIECE(PSADATA,"^",10):"master vault",1:"pharmacy location")_"."
+3 DO ^DIR
KILL DIR
IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
QUIT
+4 SET $PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^",2)=+Y
+5 QUIT
STOCK ;Enter stock level for drug if the field is blank.
+1 SET DIR(0)="NO^0:99999"
SET DIR("A")="STOCK LEVEL (in Dispense Units)"
SET DIR("??")="^D STKLEVEL^PSAPROC8"
SET DIR("B")=+PSASTOCK
+2 SET DIR("?")="Enter the ideal number of dispense units to keep on the shelf."
+3 DO ^DIR
KILL DIR
IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
QUIT
+4 SET $PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^",4)=+Y
+5 QUIT
