Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSDNBAL

PSDNBAL.m

Go to the documentation of this file.
  1. PSDNBAL ;EPIP/RTW - Ask CS Remaining Balance ;29 Aug 94
  1. ;;3.0;CONTROLLED SUBSTANCES NARCOTIC BALANCE;**84,92**;13 Feb 97;Build 3
  1. ; ICR# TYPE DESCRIPTION
  1. ;----- ------- ------------------------------------
  1. ;10026 Support ^DIR
  1. ;4986 Support ^%DTC
  1. ;1140 Support ^XMD
  1. ;---------------------------------------------------------------------
  1. N PSDNOT S PSDNOT=1 ;p92
  1. S PSDTRY=1
  1. ENTER ;
  1. N DIRUT
  1. S PSDOUT=0
  1. I PSDNOT D
  1. . W !,"*** NOTICE: You have 3 valid attempts to enter the correct remaining balance"
  1. . W !," before a message is sent to the CS BALANCE DISCREPANCY mail group.",!
  1. . S PSDNOT=0
  1. S DIR(0)="N:^0:999999.99:2"
  1. S DIR("A")=" Enter the remaining balance (^ to quit)"
  1. S DIR("T")=DTIME
  1. S DIR("??")="^D HLPMSG^PSDNBAL"
  1. D ^DIR K DIR S PSDANS=Y I $D(DIRUT) S PSDOUT=1 G EXIT
  1. S PSDQDB=(BAL-QTY)
  1. W:PSDANS=PSDQDB !!,"Balance confirmed, Thank you ",! ;RTW
  1. S PSDQCHO=$S(PSDANS=PSDQDB:"EXIT",1:"PSDATMPT")
  1. D @PSDQCHO
  1. Q
  1. HLPMSG ;
  1. W !!,"Enter the remaining balance on hand. The system will compare"
  1. W !,"against the database. You will have a total of 3 valid attempts"
  1. W !,"before a message is sent to the CS BALANCE DISCREPANCY mail"
  1. W !,"group."
  1. W !,""
  1. W !,"Input must be a numeric amount with no more than two decimal"
  1. W !,"digits. Invalid attempts will not count against your total"
  1. W !,"attempts."
  1. Q
  1. EXIT ;
  1. K PSDTRY,PSDQCHO,PSDANS,PSDQDB,PSDPHN,XMDUZ,XMY,XMSUB,XMZ,PSDWANS,PSDRN
  1. K ^TMP($J,"MSG")
  1. Q
  1. ;;
  1. PSDATMPT I PSDTRY=1 D MESS1 S PSDTRY=PSDTRY+1 G ENTER
  1. I PSDTRY=2 D MESS2 S PSDTRY=PSDTRY+1 G ENTER
  1. I PSDTRY=3 D MESG
  1. Q
  1. 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.",!
  1. Q
  1. 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."
  1. W " You may proceed if you have dispensed the",!,"correct drug in the correct quantity. Thank you.",!
  1. Q
  1. MESG ;Ask comment and send message
  1. S DIR(0)="F"
  1. S DIR("A")="Enter a comment (^ to quit)"
  1. S DIR("T")=DTIME
  1. S DIR("?",1)="Enter comment with any concerns about the balance discrepancy."
  1. S DIR("?",2)="You are limited to 245 characters."
  1. S DIR("?")=" "
  1. D ^DIR K DIR S PSDWANS=Y I $D(DIRUT) G EXIT
  1. K XMTEXT
  1. S XMSUB="Possible CS Balance Remaining Discrepancy"
  1. S XMY(DUZ)="" ;To User
  1. S XMY("G.CS BALANCE DISCREPANCY")="" ;
  1. S ^TMP($J,"MSG","B",1)="There were three failed attempts to enter the current remaining balance for the following drug."
  1. S ^TMP($J,"MSG","B",2)=" "
  1. S ^TMP($J,"MSG","B",3)=" Drug : "_PSDRN
  1. S ^TMP($J,"MSG","B",4)=" Rx # : "_RXNUM
  1. S ^TMP($J,"MSG","B",5)=" Rx Qty : "_QTY
  1. S ^TMP($J,"MSG","B",6)="Balance Entered : "_PSDANS
  1. S ^TMP($J,"MSG","B",7)="Balance in VistA : "_PSDQDB
  1. N Y,DIFROM
  1. D NOW^%DTC S Y=% X ^DD("DD")
  1. S ^TMP($J,"MSG","B",8)=" Time : "_Y
  1. S XMDUZ=.5
  1. S PSDPHN=$P(^VA(200,DUZ,0),"^",1)
  1. S ^TMP($J,"MSG","B",9)=" Pharmacist : "_PSDPHN
  1. S ^TMP($J,"MSG","B",10)=" Comment : "_PSDWANS
  1. S ^TMP($J,"MSG","B",11)=" "
  1. S ^TMP($J,"MSG","B",12)="Thank you for checking on this possible discrepancy." ;
  1. S XMTEXT="^TMP($J,""MSG"",""B"","
  1. D ^XMD
  1. W:$D(XMZ) !!,"Message sent to the CS BALANCE DISCREPANCY Mail Group",!!," You entered a remaining balance of ",PSDANS
  1. D EXIT
  1. Q