PSDNBAL ;EPIP/RTW - Ask CS Remaining Balance ;29 Aug 94
;;3.0;CONTROLLED SUBSTANCES NARCOTIC BALANCE;**84,92**;13 Feb 97;Build 3
; ICR# TYPE DESCRIPTION
;----- ------- ------------------------------------
;10026 Support ^DIR
;4986 Support ^%DTC
;1140 Support ^XMD
;---------------------------------------------------------------------
N PSDNOT S PSDNOT=1 ;p92
S PSDTRY=1
ENTER ;
N DIRUT
S PSDOUT=0
I PSDNOT D
. W !,"*** NOTICE: You have 3 valid attempts to enter the correct remaining balance"
. W !," before a message is sent to the CS BALANCE DISCREPANCY mail group.",!
. S PSDNOT=0
S DIR(0)="N:^0:999999.99:2"
S DIR("A")=" Enter the remaining balance (^ to quit)"
S DIR("T")=DTIME
S DIR("??")="^D HLPMSG^PSDNBAL"
D ^DIR K DIR S PSDANS=Y I $D(DIRUT) S PSDOUT=1 G EXIT
S PSDQDB=(BAL-QTY)
W:PSDANS=PSDQDB !!,"Balance confirmed, Thank you ",! ;RTW
S PSDQCHO=$S(PSDANS=PSDQDB:"EXIT",1:"PSDATMPT")
D @PSDQCHO
Q
HLPMSG ;
W !!,"Enter the remaining balance on hand. The system will compare"
W !,"against the database. You will have a total of 3 valid attempts"
W !,"before a message is sent to the CS BALANCE DISCREPANCY mail"
W !,"group."
W !,""
W !,"Input must be a numeric amount with no more than two decimal"
W !,"digits. Invalid attempts will not count against your total"
W !,"attempts."
Q
EXIT ;
K PSDTRY,PSDQCHO,PSDANS,PSDQDB,PSDPHN,XMDUZ,XMY,XMSUB,XMZ,PSDWANS,PSDRN
K ^TMP($J,"MSG")
Q
;;
PSDATMPT I PSDTRY=1 D MESS1 S PSDTRY=PSDTRY+1 G ENTER
I PSDTRY=2 D MESS2 S PSDTRY=PSDTRY+1 G ENTER
I PSDTRY=3 D MESG
Q
MESS1 W !!,"Sorry the remaining balance you entered does not match the balance",!,"on record in the CS package.",!!,"Please check to ensure you have dispensed the right drug and",!," dispensed the correct quantity.",!
Q
MESS2 W !!,"This will be the last entry in the remaining balance check.",!!,"If the entry still does not match a message will be sent to the",!,"appropriate person for review."
W " You may proceed if you have dispensed the",!,"correct drug in the correct quantity. Thank you.",!
Q
MESG ;Ask comment and send message
S DIR(0)="F"
S DIR("A")="Enter a comment (^ to quit)"
S DIR("T")=DTIME
S DIR("?",1)="Enter comment with any concerns about the balance discrepancy."
S DIR("?",2)="You are limited to 245 characters."
S DIR("?")=" "
D ^DIR K DIR S PSDWANS=Y I $D(DIRUT) G EXIT
K XMTEXT
S XMSUB="Possible CS Balance Remaining Discrepancy"
S XMY(DUZ)="" ;To User
S XMY("G.CS BALANCE DISCREPANCY")="" ;
S ^TMP($J,"MSG","B",1)="There were three failed attempts to enter the current remaining balance for the following drug."
S ^TMP($J,"MSG","B",2)=" "
S ^TMP($J,"MSG","B",3)=" Drug : "_PSDRN
S ^TMP($J,"MSG","B",4)=" Rx # : "_RXNUM
S ^TMP($J,"MSG","B",5)=" Rx Qty : "_QTY
S ^TMP($J,"MSG","B",6)="Balance Entered : "_PSDANS
S ^TMP($J,"MSG","B",7)="Balance in VistA : "_PSDQDB
N Y,DIFROM
D NOW^%DTC S Y=% X ^DD("DD")
S ^TMP($J,"MSG","B",8)=" Time : "_Y
S XMDUZ=.5
S PSDPHN=$P(^VA(200,DUZ,0),"^",1)
S ^TMP($J,"MSG","B",9)=" Pharmacist : "_PSDPHN
S ^TMP($J,"MSG","B",10)=" Comment : "_PSDWANS
S ^TMP($J,"MSG","B",11)=" "
S ^TMP($J,"MSG","B",12)="Thank you for checking on this possible discrepancy." ;
S XMTEXT="^TMP($J,""MSG"",""B"","
D ^XMD
W:$D(XMZ) !!,"Message sent to the CS BALANCE DISCREPANCY Mail Group",!!," You entered a remaining balance of ",PSDANS
D EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDNBAL 3561 printed Oct 16, 2024@17:47:39 Page 2
PSDNBAL ;EPIP/RTW - Ask CS Remaining Balance ;29 Aug 94
+1 ;;3.0;CONTROLLED SUBSTANCES NARCOTIC BALANCE;**84,92**;13 Feb 97;Build 3
+2 ; ICR# TYPE DESCRIPTION
+3 ;----- ------- ------------------------------------
+4 ;10026 Support ^DIR
+5 ;4986 Support ^%DTC
+6 ;1140 Support ^XMD
+7 ;---------------------------------------------------------------------
+8 ;p92
NEW PSDNOT
SET PSDNOT=1
+9 SET PSDTRY=1
ENTER ;
+1 NEW DIRUT
+2 SET PSDOUT=0
+3 IF PSDNOT
Begin DoDot:1
+4 WRITE !,"*** NOTICE: You have 3 valid attempts to enter the correct remaining balance"
+5 WRITE !," before a message is sent to the CS BALANCE DISCREPANCY mail group.",!
+6 SET PSDNOT=0
End DoDot:1
+7 SET DIR(0)="N:^0:999999.99:2"
+8 SET DIR("A")=" Enter the remaining balance (^ to quit)"
+9 SET DIR("T")=DTIME
+10 SET DIR("??")="^D HLPMSG^PSDNBAL"
+11 DO ^DIR
KILL DIR
SET PSDANS=Y
IF $DATA(DIRUT)
SET PSDOUT=1
GOTO EXIT
+12 SET PSDQDB=(BAL-QTY)
+13 ;RTW
if PSDANS=PSDQDB
WRITE !!,"Balance confirmed, Thank you ",!
+14 SET PSDQCHO=$SELECT(PSDANS=PSDQDB:"EXIT",1:"PSDATMPT")
+15 DO @PSDQCHO
+16 QUIT
HLPMSG ;
+1 WRITE !!,"Enter the remaining balance on hand. The system will compare"
+2 WRITE !,"against the database. You will have a total of 3 valid attempts"
+3 WRITE !,"before a message is sent to the CS BALANCE DISCREPANCY mail"
+4 WRITE !,"group."
+5 WRITE !,""
+6 WRITE !,"Input must be a numeric amount with no more than two decimal"
+7 WRITE !,"digits. Invalid attempts will not count against your total"
+8 WRITE !,"attempts."
+9 QUIT
EXIT ;
+1 KILL PSDTRY,PSDQCHO,PSDANS,PSDQDB,PSDPHN,XMDUZ,XMY,XMSUB,XMZ,PSDWANS,PSDRN
+2 KILL ^TMP($JOB,"MSG")
+3 QUIT
+4 ;;
PSDATMPT IF PSDTRY=1
DO MESS1
SET PSDTRY=PSDTRY+1
GOTO ENTER
+1 IF PSDTRY=2
DO MESS2
SET PSDTRY=PSDTRY+1
GOTO ENTER
+2 IF PSDTRY=3
DO MESG
+3 QUIT
MESS1 WRITE !!,"Sorry the remaining balance you entered does not match the balance",!,"on record in the CS package.",!!,"Please check to ensure you have dispensed the right drug and",!," dispensed the correct quantity.",!
+1 QUIT
MESS2 WRITE !!,"This will be the last entry in the remaining balance check.",!!,"If the entry still does not match a message will be sent to the",!,"appropriate person for review."
+1 WRITE " You may proceed if you have dispensed the",!,"correct drug in the correct quantity. Thank you.",!
+2 QUIT
MESG ;Ask comment and send message
+1 SET DIR(0)="F"
+2 SET DIR("A")="Enter a comment (^ to quit)"
+3 SET DIR("T")=DTIME
+4 SET DIR("?",1)="Enter comment with any concerns about the balance discrepancy."
+5 SET DIR("?",2)="You are limited to 245 characters."
+6 SET DIR("?")=" "
+7 DO ^DIR
KILL DIR
SET PSDWANS=Y
IF $DATA(DIRUT)
GOTO EXIT
+8 KILL XMTEXT
+9 SET XMSUB="Possible CS Balance Remaining Discrepancy"
+10 ;To User
SET XMY(DUZ)=""
+11 ;
SET XMY("G.CS BALANCE DISCREPANCY")=""
+12 SET ^TMP($JOB,"MSG","B",1)="There were three failed attempts to enter the current remaining balance for the following drug."
+13 SET ^TMP($JOB,"MSG","B",2)=" "
+14 SET ^TMP($JOB,"MSG","B",3)=" Drug : "_PSDRN
+15 SET ^TMP($JOB,"MSG","B",4)=" Rx # : "_RXNUM
+16 SET ^TMP($JOB,"MSG","B",5)=" Rx Qty : "_QTY
+17 SET ^TMP($JOB,"MSG","B",6)="Balance Entered : "_PSDANS
+18 SET ^TMP($JOB,"MSG","B",7)="Balance in VistA : "_PSDQDB
+19 NEW Y,DIFROM
+20 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+21 SET ^TMP($JOB,"MSG","B",8)=" Time : "_Y
+22 SET XMDUZ=.5
+23 SET PSDPHN=$PIECE(^VA(200,DUZ,0),"^",1)
+24 SET ^TMP($JOB,"MSG","B",9)=" Pharmacist : "_PSDPHN
+25 SET ^TMP($JOB,"MSG","B",10)=" Comment : "_PSDWANS
+26 SET ^TMP($JOB,"MSG","B",11)=" "
+27 ;
SET ^TMP($JOB,"MSG","B",12)="Thank you for checking on this possible discrepancy."
+28 SET XMTEXT="^TMP($J,""MSG"",""B"","
+29 DO ^XMD
+30 if $DATA(XMZ)
WRITE !!,"Message sent to the CS BALANCE DISCREPANCY Mail Group",!!," You entered a remaining balance of ",PSDANS
+31 DO EXIT
+32 QUIT
