2. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 8/29/2018 2:55:43 PM Central Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

2.1 Files compared

# Location File Last Modified
1 EPIP.zip\PSD_3.0_84_Aug_2018 EPIP_Remediation_Plan_(PSD_3.0_84).doc Tue Aug 28 12:23:02 2018 UTC
2 EPIP.zip\PSD_3.0_84_Aug_2018 EPIP_Remediation_Plan_(PSD_3.0_84).doc Tue Aug 28 12:42:08 2018 UTC

2.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 4 1996
Changed 3 6
Inserted 0 0
Removed 0 0

2.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

2.4 Active regular expressions

No regular expressions were active.

2.5 Comparison detail

  1   EPIP_Remed iation_Pla nExisting  Product In take Progr am (EPIP)
  2   Patch PSD* 3.0*84
  3   Remediatio n Plan
  4  
  5   Department  of Vetera ns Affairs
  6   August 201 8
  7   Version 2. 0
  8   Revision H istory
  9   DateVersio nDescripti onAuthor08 /01/20182. 0Updates t hroughoutE PIP Projec t Team04/0 3/20181.0I nitial (dr aft) versi onEPIP Pro ject TeamT able of Co ntents
  10   11.
  11   Introducti on
  12  
  13  
  14   12.
  15   Purpose
  16  
  17  
  18   13.
  19   Patch Desc ription
  20  
  21  
  22   23.1.
  23   Business E pics and S ub-Epics
  24  
  25  
  26   24.
  27   Points of  Contact
  28  
  29  
  30   25.
  31   Code Remed iation
  32  
  33  
  34   35.1.
  35   Standards  and Conven tions
  36  
  37  
  38   35.2.
  39   Review and  Analysis
  40  
  41  
  42   35.3.
  43   Coding Cha nges
  44  
  45  
  46   36.
  47   Testing
  48  
  49  
  50   36.1.
  51   Test Plan
  52  
  53  
  54   46.2.
  55   Test Envir onment
  56  
  57  
  58   46.3.
  59   Test Readi ness Revie w
  60  
  61  
  62   46.4.
  63   Testing Ph ases
  64  
  65  
  66   46.4.1.
  67   Unit Testi ng
  68  
  69  
  70   46.4.2.
  71   Component  Integratio n and Syst ems Testin g (CI/ST)
  72  
  73  
  74   46.4.3.
  75   Functional  Testing
  76  
  77  
  78   56.4.4.
  79   Regression  Testing
  80  
  81  
  82   56.4.5.
  83   Section 50 8 Complian ce Testing
  84  
  85  
  86   57.
  87   Documentat ion Remedi ation
  88  
  89  
  90   57.1.
  91   User Guide s
  92  
  93  
  94   57.2.
  95   Installati on Guides
  96  
  97  
  98   67.3.
  99   Technical  Manuals
  100  
  101  
  102   67.4.
  103   Operations  Manuals
  104  
  105  
  106   68.
  107   Project Re porting
  108  
  109  
  110   69.
  111   Project Sc hedule
  112  
  113  
  114   610.
  115   Deployment
  116  
  117  
  118   611.
  119   Sustainmen t Requirem ents
  120  
  121  
  122   612.
  123   Maintenanc e and Know ledge Tran sfer
  124  
  125  
  126   7Appendix  A:
  127   XINDEX Lis ting for M UMPS Code  Changes
  128  
  129  
  130   8Appendix  B:
  131   Source Cod e Changes
  132  
  133  
  134  
  135  
  136   Introducti on
  137   The Depart ment of Ve terans Aff airs (VA)  currently  utilizes t he Veteran s Health I nformation  Systems a nd Technol ogy Archit ecture (Vi stA) suite  of applic ations to  provide cl inical, fi nancial, i nfrastruct ure, and m anagement  tools. The  process o f advancin g “Class 3 ” field-de veloped Vi stA softwa re to “Cla ss 1” nati onally-dis tributed s tatus is r eferred to  as the Ex isting Pro duct Intak e Program  (EPIP). Th e VA’s goa l is to su pplement o ngoing act ivities as sociated w ith evalua ting and a dvancing f ield-devel oped softw are to a s tate that  meets nati onal stand ards and f acilitates  release f or Veteran s Health A dministrat ion (VHA)- wide use.
  138   Purpose
  139   The purpos e of this  document i s to fully  describe  the remedi ation plan  to be use d for the  successful  remediati on of the  intake pro duct code  to be depl oyed as pa tch PSD*3. 0*84. This  patch add resses the  following  NSRs:
  140   NSR2017110 1 Controll ed Substan ce Narcoti c Count In put
  141   This NSR h as been im plemented  locally at  the VA He alth Care  Systems in  Fargo ND,  Sioux Fal ls SD, For t Meade SD , Minneapo lis MN, an d St. Clou d MN.
  142   NSR2017111 1 Pharmacy  Activity  Report Sch ed II Meds
  143   This NSR h as been im plemented  locally at  the VA Me dical Cent er in Milw aukee WI.
  144   This docum ent addres ses the sc hedule, co de remedia tion, test ing, docum entation,  and delive ry of this  remediati on effort.
  145   Patch Desc ription
  146   PSD*3.0*84  provides  the follow ing enhanc ements to  VistA:
  147   Enhances t he Outpati ent Rx’s [ PSD OUTPAT IENT] opti on in the  Pharmacist  Menu [PSD  TRANSACTI ON MENU] t o require  users to e nter the c urrent on- hand narco tic medica tion count  without s eeing the  VistA comp uted count . The exis ting optio n displays  the VistA  narcotic  medication  count wit hout askin g users to  enter the  actual on -hand coun t, which d oes not en sure that  an actual  count was  performed  to confirm  that the  number sho wn in Vist A matches  the true c ount. The  modificati on ensures  that an a ctual coun t is perfo rmed and c ompares th e user's i nput again st current  VistA tot als. If th e balances  entered b y the user  do not ma tch the Vi stA count  after thre e attempts , then an 
  148   e-mail mes sage is se nt to the  new CS BAL ANCE DISCR EPANCY mai l group fo r further  investigat ion. The m ail group  is populat ed by each  site with  pharmacy  supervisor s who can  address ba lance disc repancies.  
  149   During the  post-inst allation p hase, rout ine PSD84P  checks to  see if th ere is a p re-existin g CS BALAN CE DISCREP ANCY mail  group. If  it does no t exist, t he routine  creates t he new mai l group an d displays  an on-scr een confir mation. Ro utine PSD8 4P is dele ted automa tically at  the end o f patch in stallation .
  150   This modif ication se rves as a  failsafe a gainst nar cotic dive rsion.
  151   Enhances t he "Daily  Activity L og (in lie u of VA FO RM 10-2320 )" [PSD DA ILY LOG] o ption in t he Product ion Report s [PSD PRO DUCTION RE PORTS] men u and the  "Daily Act ivity Log  (in lieu o f VA FORM  10-2320)"  [PSD DAILY  LOG TECH]  option in  the Techn ician (CS  Pharmacy)  Menu [PSD  PHARM TECH ] to group  all Sched ule II dru gs under o ne group n ame. The e xisting op tion allow s a user t o print al l activity  using the  [^ALL] gr oup select ion or req uires a us er to manu ally input  the name  of each in dividual d rug in the  group eve ry time a  Daily Acti vity Log r eport is r un. Manual ly inputti ng this in formation  is a signi ficant tim e burden a nd increas es the pos sibility o f data ent ry mistake s. This en hancement  allows the  user to e nter one g roup name  [^ALL CII  DRUGS] tha t selects  all Schedu le II drug s instead  of requiri ng entry o f individu al drug na mes. This  group name  must be t yped in fu ll; there  is no shor tcut or au to-complet e. 
  152   This modif ication en sures a mo re accurat e report,  thereby he lping to m onitor for  drug dive rsion patt erns and a iding staf f in troub leshooting  when the  electronic  supply co unt does n ot match t he number  of items o n-hand.
  153   Business E pics and S ub-Epics
  154   The Busine ss Epics a nd Sub-Epi cs for the  NSRs addr essed in t his remedi ation are:
  155   NSR2017110 1 Controll ed Substan ce Narcoti c Count In put
  156   BUSINESS E PIC 948795 : Narcotic  Count - F or Pharmac y supervis ors who ar e responsi ble for pr eventing n arcotics d iversion,  a capabili ty to forc e users to  enter the  current n arcotic co unt on han d when usi ng the Out patient RX  option [P SD OUTPATI ENT] withi n the Cont rolled Sub stances pa ckage befo re they se e the Vist A computed  count, th at then co mpares the  user ente red count  to the Vis tA compute d count. U nlike the  current ap proach whi ch simply  displays t he current  narcotic  count on h and to the  user, our  process e nsures tha t an actua l count wa s performe d and aler ts others  after seve ral failed  counts ar e entered  so that th e discrepa ncy can be  investiga ted.
  157   NSR2017111 1 Pharmacy  Activity  Report Sch ed II Meds
  158   BUSINESS E PIC 951126 : Schedule  II Drug A ctivity Re port - For  Pharmacy  supervisor s who moni tor Schedu le II drug s to ident ify narcot ics divers ion patter ns, a modi fication t o the sele ction crit eria for t he Daily A ctivity Lo g that all ows me to  select all  Schedule  II drugs b y entering  one group  name. Unl ike the cu rrent proc ess which  forces me  to enter e ach Schedu le II drug  manually,  our proce ss saves s taff time  and reduce s human er ror associ ated with  manual inp ut.
  159   Points of  Contact
  160   The VA Poi nt of Cont act (POC)  for NSR201 71101 Cont rolled Sub stance Nar cotic Coun t Input an d NSR20171 111 Pharma cy Activit y Report S ched II Me ds is Robe rt Silverm an (  HYPE R LINK "PII                               " PII                        
)
.
  161   Code Remed iation
  162   Leidos wil l review a nd analyze  the intak e product  code for c ompliance  with codin g standard s, pointer s, shared  tables, de pendencies , and any  interferen ce with Vi stA system s.
  163   Standards  and Conven tions
  164   Leidos wil l referenc e the http ://go. DNS     /sacc webs ite for ap plicable d ocuments a nd will ad here to VA  standards  to comple te the ana lysis of t his intake  product.  The output  of the VA  XINDEX ut ility will  be used t o analyze  the MUMPS  source cod e and docu ment the a ffected ro utines (se e Appendix  A).
  165   The MUMPS  coding sta ndards web site http: //71.174.6 2.16/Demo/ AnnoStd wi ll also be  used to e nsure that  the remed iated code  conforms  to VA stan dards.
  166   Review and  Analysis
  167   Review and  analysis  of this in take produ ct involve s two part s: 1) veri fication t hat the so urce code  changes sp ecified in  this docu ment provi de the des ired effec t, and 2)  verificati on that th e source c ode change s do not a dversely a ffect any  other Vist A or CPRS  functional ity. 
  168   Testing wi ll be perf ormed to v alidate th at the int ended effe ct of thes e products  is implem ented, and  that no o ther VistA  or CPRS G raphical U ser Interf ace (GUI)  functional ity is adv ersely aff ected.
  169   Coding Cha nges
  170   The coding  changes r equired fo r NSR20171 101 Contro lled Subst ance Narco tic Count  Input are  in the fol lowing MUM PS routine s: 
  171   Modified r outines: P SDOPT
  172   New routin es: PSDNBA L, PSD84P
  173   The coding  changes f or NSR2017 1111 Pharm acy Activi ty Report  Sched II M eds are in  the follo wing MUMPS  routines:  
  174   Modified r outines: P SDACT, PSD ACT1
  175   New routin es: None
  176   A detailed  analysis  of the cod ing change s is provi ded in App endix B.
  177   Testing
  178   Leidos wil l perform  all testin g-related  activities  to ensure  that the  remediated  code meet s the expe ctations o f the VA b usiness ow ner.
  179   Test Plan
  180   Leidos wil l configur e the test  environme nt, provid e code mod ifications  and end-t o-end test ing, and d eliver app licable te sting docu mentation,  following  Veteran-f ocused Int egration P rocess (VI P) guideli nes.
  181   The Leidos  developer  will modi fy the sof tware purs uant to th e VA stand ards defin ed in the  Standards  and Conven tions sect ion of thi s document , and will  conduct f ull unit t esting of  the functi onality an d verify p erformance  of all so ftware cod e before i t is relea sed to Lei dos SQA. S QA will th en perform  all appli cable test ing types  as describ ed in the  Testing Ph ases secti on of this  document.  The devel oper and S QA will re solve prob lems and a ddress iss ues as the y arise du ring testi ng and wil l document  issues us ing the Ra tional Tea m Concert  (RTC) defe ct trackin g tool.
  182   Test Envir onment
  183   Within fiv e working  days of ap proval of  this Remed iation Pla n, the dev eloper wil l configur e the deve lopment/te st environ ment on an  Austin In formation  Technology  Center (A ITC) serve r or other  VA-approv ed develop ment/test  environmen t used for  this inta ke product  and insta ll the rem ediated Ke rnel Insta llation an d Distribu tion Syste m (KIDS) b uild or ho st file. T he environ ment will  be restore d to its o riginal ba seline sta te by the  VistA syst em adminis trator aft er develop ment testi ng is comp leted, fol lowed by i nstallatio n of the r emediated  software.
  184   Upon notif ication fr om the dev eloper of  test envir onment rea diness, SQ A will com mence with  planned t esting act ivities. T he SQA tes t executio n and repo rting docu mentation  will resid e in the R ational Qu ality Mana ger (QM) “ EPIP” Proj ect. In or der to per form testi ng of this  VistA mod ification,  the follo wing tools  will be l everaged:  Rational Q M, Reflect ions emula tor, CPRS  GUI v31A ( 1.0.31.116 ), and Sna gIt.
  185   Test Readi ness Revie w
  186   Leidos wil l conduct  a Test Rea diness Rev iew (TRR)  at the con clusion of  unit test ing to ver ify the co ntents of  the softwa re to be t ested, the  test sche dule, test  environme nts, test  participan ts, and as sociated l ogistics.  Leidos wil l provide  an agenda  prior to t he TRR and  written m inutes aft er complet ion of the  TRR, in a ccordance  with the P erformance  Work Stat ement (PWS ).
  187   Testing Ph ases
  188   Leidos wil l perform  developmen t and SQA  testing ac tivities i n phases,  and will p rovide all  required  testing do cumentatio n.
  189   Unit Testi ng
  190   The develo per will c onduct uni t testing  of individ ual units  of source  code to de termine if  they are  fit for us e.
  191   Component  Integratio n and Syst ems Testin g (CI/ST)
  192   Component  integratio n and syst ems testin g will be  conducted  by SQA to  ensure tha t connecti vity to th e VistA ap plication  exists and  is functi oning norm ally. SQA  will recor d Passed/F ailed outc omes and c apture dis played con tent to do cument the  system te sting effo rt.
  193   Functional  Testing
  194   Functional  testing w ill be per formed by  SQA to tes t the code  modificat ions. This  testing w ill ensure  that the  software f unctionali ty is in a lignment w ith the Go vernment F urnished I nformation . SQA will  record Pa ssed/Faile d outcomes  and captu re display ed content  to docume nt the fun ctional te sting effo rt.
  195   Regression  Testing
  196   Regression  testing w ill be per formed by  SQA to ens ure that t he remedia ted code d oes not in troduce er rors to ex isting fun ctionality . The regr ession tes t framewor k will be  kept up-to -date with  manual te st cases a nd test sc ripts defi ning the i nputs and  expected o utcomes. S QA will re cord Passe d/Failed o utcomes an d capture  displayed  content to  document  the regres sion testi ng effort.
  197   Section 50 8 Complian ce Testing
  198   Section 50 8 testing  will be pe rformed on  VistA and  CPRS code  when new  user inter face chang es are int roduced by  the devel oper. The  VA-recomme nded Assis tive Techn ology tool , JAWS, wi ll be used  to conduc t the 508  testing. T est result s and rela ted docume ntation wi ll be subm itted to t he VA Sect ion 508 te am in acco rdance wit h the VA 5 08 testing  requireme nts. Defec ts found d uring test ing will b e assessed  and remed iated by t he develop er.
  199   Documentat ion Remedi ation
  200   Leidos wil l review e xisting VA  documenta tion for p ossible im pact as a  result of  this remed iation eff ort, and w ill make u pdates whe re applica ble.
  201   To determi ne the exi sting VA d ocumentati on that re quires mod ification,  Leidos wi ll conduct  a thoroug h review o f the docu ments curr ently avai lable from  the VA So ftware Doc ument Libr ary (VDL)  located at  https://w ww. DNS     /vdl/. Key word searc hes using  terms rele vant to th is remedia tion effor t will be  used to id entify doc uments tha t might be  impacted;  those doc uments wil l then be  reviewed i n their en tirety for  any neede d revision s.
  202   The follow ing sectio ns outline  the VDL d ocuments t o be revis ed for thi s remediat ion.
  203   User Guide s
  204   The follow ing User G uides will  be update d in the V DL:
  205   Controlled  Substance s (CS) Pha rmacist's  User Manua l
  206   Controlled  Substance s (CS) Sup ervisor's  User Manua l
  207   Installati on Guides
  208   The Nation al Patch M odule Patc h Descript ion docume nt for thi s remediat ion will p rovide the  procedure  for insta lling the  KIDS packa ge or host  file into  the VA Pr e-Producti on environ ments. The refore, no  Installat ion Guides  will be u pdated.
  209   Technical  Manuals
  210   The follow ing Techni cal Manual  will be u pdated in  the VDL:
  211   Controlled  Substance s (CS) Tec hnical Man ual 
  212   Operations  Manuals
  213   No Operati ons Manual s require  revision a s a result  of this m odificatio n.
  214   Project Re porting
  215   Leidos wil l provide  interim pr ogress upd ates durin g daily Sc rum calls  and weekly  managemen t calls wi th VA repr esentative s.
  216   Project Sc hedule
  217   Leidos wil l follow t he Scrum A gile metho dology for  software  developmen t. It is a nticipated  that this  patch wil l require  five 2-wee k sprints.
  218   Deployment
  219   Leidos wil l create a  KIDS pack age or hos t file con taining th e software  changes n ecessary t o fulfill  the requir ements for  this reme diation ef fort. The  new build,  along wit h all rela ted docume ntation, w ill be del ivered to  the Contra cting Offi ce Represe ntative (C OR) for ac ceptance.  If accepte d, these d eliverable s can then  be releas ed for nat ional VA c onsumption ; otherwis e, Leidos  will corre ct any def ects found  and repea t the nece ssary reme diation ac tivities.
  220   Sustainmen t Requirem ents
  221   Leidos wil l provide  maintenanc e support  for 90 day s to the V A to suppo rt the fin al Class 1  product a fter it is  nationall y released .
  222   Maintenanc e and Know ledge Tran sfer
  223   To facilit ate contin uous proce ss improve ment, Leid os will de liver Spri nt Review  and Retros pective sl ides and a  Lessons L earned Rep ort to VA  upon compl etion of t he final s print.
  224   XINDEX Lis ting for M UMPS Code  Changes
  225   The XINDEX  tool is t he standar d tool use d by the V A to analy ze MUMPS s ource code . Followin g is a lis ting of th e results  of the XIN DEX analys is of the  affected r outines.
  226                      V.  A.  C R O  S S  R E  F E R E N  C E R  7.3
  227                            [2008 V A Standard s & Conven tions]
  228                      UC I: VISTA C PU: ROU     Jul 26, 2 018@18:27: 46
  229   The BUILD  file Data  Dictionari es are bei ng process ed.
  230   The option  and funct ion files  are being  processed.
  231   Routines a re being p rocessed.
  232   Routines:  5  Faux Ro utines: 0
  233   PSD84P     PSDACT     PSDACT1    PSDNBAL    PSDOPT    
  234   --- CROSS  REFERENCIN G ---
  235   Compiled l ist of Err ors and Wa rnings                Jul 26, 20 18@18:27:4 6 page 1
  236   No errors  or warning s to repor t
  237   --- END -- -
  238   Source Cod e Changes
  239   This appen dix displa ys the Vis tA code be fore and a fter the u pdates req uired for  this code  modificati on were im plemented.  The follo wing routi nes were a ffected:
  240   Modified r outines: P SDACT, PSD ACT1, PSDO PT
  241   New routin es: PSDNBA L, PSD84P
  242   PSDACT
  243   Before:
  244   PSDACT ;BI R/BJW-Prin t Daily Ac tivity Log  ; 3 Feb 9 8
  245    ;;3.0; CO NTROLLED S UBSTANCES  ;**8**;13  Feb 97
  246    ;**Y2K co mpliance** ,"P" added  to date i nput strin g
  247    I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE)
  248    I '$D(^XU SEC("PSJ R PHARM",DUZ ))&('$D(^X USEC("PSD  TECH",DUZ) )) W !!,"C ontact you r Pharmacy  Coordinat or for acc ess to dis play the d aily CS ac tivity.",! !,"PSJ RPH ARM or PSD  TECH secu rity key r equired.", ! Q
  249   ASKD ;ask  disp locat ion
  250    S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4)
  251    G:$P(PSDS ITE,U,5) C HKD
  252    K DIC,DA  S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) "
  253    S DIC("A" )="Select  Primary Di spensing S ite: "
  254    S DIC("B" )=$P(PSDSI TE,U,4)
  255    D ^DIC K  DIC G:Y<0  END
  256    S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN
  257   CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no  CS stocke d drugs fo r your dis pensing va ult.",!! G  END
  258   DRUG ;ask  drug
  259    W !!,?5," You may se lect a sin gle drug,  several dr ugs,",!,?5 ,"or enter  ^ALL to s elect all  drugs.",!!
  260    W ! K DA, DIC
  261    F  S DIC( "W")="W:$P (^PSDRUG(Y ,0),""^"", 9) "" N/F" " I $P(^PS D(58.8,PSD S,1,Y,0)," "^"",14)]" """,$P(^(0 ),""^"",14 )'>DT W $C (7),"" ***  INACTIVE  ***""",DA( 1)=+PSDS,D IC(0)="QEA M",DIC="^P SD(58.8,"_ PSDS_",1,"  D ^DIC K  DIC Q:Y<0  D
  262    .S PSDRG( +Y)=""
  263    I '$D(PSD RG)&(X'="^ ALL") G EN D
  264    I X="^ALL " S ALL=1
  265   DATE W ! K  %DT S %DT ="AEPTX",% DT("A")="S tart with  Date: " D  ^%DT I Y<0  G END
  266    S PSDSD=Y  D D^DIQ S  PSDATE=Y, %DT("A")=" End with D ate: " D ^ %DT I Y<0  G END
  267    I Y<PSDSD  W !!,"The  ending da te of the  range must  be later  than the s tarting da te." G DAT E
  268    S PSDED=Y  D D^DIQ S  PSDATE=PS DATE_"^"_Y ,PSDSD=PSD SD-.00001
  269    S:'$P(PSD ED,".",2)  PSDED=PSDE D+.99999
  270    W !!,"Thi s report i s designed  for a 132  column fo rmat.",!," You may qu eue this r eport to p rint at a  later time .",!!
  271   DEV ;sel d evice
  272    S Y=$P($G (^PSD(58.8 ,+PSDS,2)) ,"^",9),C= $P(^DD(58. 8,24,0),"^ ",2) D Y^D IQ S PSDEV =Y
  273    W ! K %ZI S,IOP,IO(" Q"),POP S  %ZIS="QM", %ZIS("B")= PSDEV D ^% ZIS I POP  W !!,"NO D EVICE SELE CTED OR RE PORT PRINT ED!!",! G  END
  274    I $D(IO(" Q")) K IO( "Q"),ZTIO, ZTSAVE,ZTD TH,ZTSK S  PSDIO=ION, ZTIO="",ZT RTN="START ^PSDACT1", ZTDESC="CS  PHARM Com pile Daily  Activity  Log" D SAV E,^%ZTLOAD ,HOME^%ZIS  K ZTSK G  END
  275    U IO G ST ART^PSDACT 1
  276   END ;
  277    D KVAR^VA DPT
  278    K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M
  279    K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID")
  280    K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK
  281    D ^%ZISC  S:$D(ZTQUE UED) ZTREQ ="@"
  282    Q
  283   SAVE ;sets  variables  for queue ing
  284    S (ZTSAVE ("PSDS"),Z TSAVE("PSD SN"),ZTSAV E("PSDSD") ,ZTSAVE("P SDED"),ZTS AVE("PSDAT E"),ZTSAVE ("PSDIO")) =""
  285    S:$D(ALL)  ZTSAVE("A LL")="" S: $D(PSDRG)  ZTSAVE("PS DRG(")=""
  286    Q
  287    Q
  288   After:
  289   PSDACT ;BI R/BJW-Prin t Daily Ac tivity Log  ; 3 Feb 9 8
  290    ;;3.0;CON TROLLED SU BSTANCES ; **8,84**;1 3 Feb 97;B UILD 1
  291    ;**Y2K co mpliance** ,"P" added  to date i nput strin g
  292    I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE)
  293    I '$D(^XU SEC("PSJ R PHARM",DUZ ))&('$D(^X USEC("PSD  TECH",DUZ) )) W !!,"C ontact you r Pharmacy  Coordinat or for acc ess to dis play the d aily CS ac tivity.",! !,"PSJ RPH ARM or PSD  TECH secu rity key r equired.", ! Q
  294   ASKD ;ask  disp locat ion
  295    S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4)
  296    G:$P(PSDS ITE,U,5) C HKD
  297    K DIC,DA  S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) "
  298    S DIC("A" )="Select  Primary Di spensing S ite: "
  299    S DIC("B" )=$P(PSDSI TE,U,4)
  300    D ^DIC K  DIC G:Y<0  END
  301    S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN
  302   CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no  CS stocke d drugs fo r your dis pensing va ult.",!! G  END
  303   DRUG ;ask  drug
  304    W !!,?5," You may se lect a sin gle drug,  several dr ugs,",!,?5 ,"or enter  ^ALL to s elect all  drugs.",!!
  305    W ?5,"You  may also  enter ^ALL  CII DRUGS  to select  all",!,?5 ,"schedule  2 control led substa nces.",!!  ;rtw NSR 2 0171111 
  306    W ! K DA, DIC
  307    F  S DIC( "W")="W:$P (^PSDRUG(Y ,0),""^"", 9) "" N/F" " I $P(^PS D(58.8,PSD S,1,Y,0)," "^"",14)]" """,$P(^(0 ),""^"",14 )'>DT W $C (7),"" ***  INACTIVE  ***""",DA( 1)=+PSDS,D IC(0)="QEA M",DIC="^P SD(58.8,"_ PSDS_",1,"  D ^DIC K  DIC Q:Y<0  D
  308    .S PSDRG( +Y)=""
  309    ;I '$D(PS DRG)&(X'=" ^ALL") G E ND ;rtw re m'd NSR201 71111
  310    I '$D(PSD RG)&(X'="^ ALL")&(X'= "^ALL CII  DRUGS") G  END ;rtw r eplacement  NSR201711 11
  311   N PSDALL
  312    I X="^ALL " S ALL=1
  313    I X="^ALL  CII DRUGS " S PSDALL =1 ;;rtw a dd NSR2017 1111
  314   DATE W ! K  %DT S %DT ="AEPTX",% DT("A")="S tart with  Date: " D  ^%DT I Y<0  G END
  315    S PSDSD=Y  D D^DIQ S  PSDATE=Y, %DT("A")=" End with D ate: " D ^ %DT I Y<0  G END
  316    I Y<PSDSD  W !!,"The  ending da te of the  range must  be later  than the s tarting da te." G DAT E
  317    S PSDED=Y  D D^DIQ S  PSDATE=PS DATE_"^"_Y ,PSDSD=PSD SD-.00001
  318    S:'$P(PSD ED,".",2)  PSDED=PSDE D+.99999
  319    W !!,"Thi s report i s designed  for a 132  column fo rmat.",!," You may qu eue this r eport to p rint at a  later time .",!!
  320   DEV ;sel d evice
  321    S Y=$P($G (^PSD(58.8 ,+PSDS,2)) ,"^",9),C= $P(^DD(58. 8,24,0),"^ ",2) D Y^D IQ S PSDEV =Y
  322    W ! K %ZI S,IOP,IO(" Q"),POP S  %ZIS="QM", %ZIS("B")= PSDEV D ^% ZIS I POP  W !!,"NO D EVICE SELE CTED OR RE PORT PRINT ED!!",! G  END
  323    I $D(IO(" Q")) K IO( "Q"),ZTIO, ZTSAVE,ZTD TH,ZTSK S  PSDIO=ION, ZTIO="",ZT RTN="START ^PSDACT1", ZTDESC="CS  PHARM Com pile Daily  Activity  Log" D SAV E,^%ZTLOAD ,HOME^%ZIS  K ZTSK G  END
  324    U IO G ST ART^PSDACT 1
  325   END ;
  326    D KVAR^VA DPT
  327    K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M
  328    K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID")
  329    K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK
  330    D ^%ZISC  S:$D(ZTQUE UED) ZTREQ ="@"
  331    Q
  332   SAVE ;sets  variables  for queue ing
  333    S (ZTSAVE ("PSDS"),Z TSAVE("PSD SN"),ZTSAV E("PSDSD") ,ZTSAVE("P SDED"),ZTS AVE("PSDAT E"),ZTSAVE ("PSDIO")) =""
  334    S:$D(ALL)  ZTSAVE("A LL")="" S: $D(PSDRG)  ZTSAVE("PS DRG(")=""
  335    S:$D(PSDA LL) ZTSAVE ("PSDALL") ="" ;rtw a dd NSR2017 1111
  336    Q
  337   PSDACT1
  338   Before:
  339   PSDACT1 ;B IR/JPW,BJW -Print Dai ly Activit y Log (con t'd) ; 17  Jun 98
  340    ;;3.0; CO NTROLLED S UBSTANCES  ;**10,14,3 0,65**;13  Feb 97;Bui ld 5
  341    ;Referenc e to ^PRC( 442 suppor ted by IA  #682
  342    ;Referenc e to ^PRCS (410 suppo rted by IA  #198
  343    ;Referenc e to ^PSDR UG( suppor ted by IA  #221
  344    ;Referenc e to ^PSRX ( supporte d by IA #9 86
  345    ;Referenc e to ^DD(5 8.81 suppo rted by IA  #10154
  346    ;Referenc e to PSD(5 8.8 suppor ted by DBI A # 2711
  347    ;Referenc e to PSD(5 8.81 suppo rted by DB IA # 2808
  348    ;Referenc es to PSD( 58.84 supp orted by I A # 3485
  349    ;modified  for nois: tua-0498-3 2173,new c ode added  to t6
  350    ;op v.7 c hg the sta tus loc in  file 52
  351   START ;ent ry for com pile
  352    K ^TMP("P SDACT",$J)
  353    I $D(ALL)  F PSDR=0: 0 S PSDR=$ O(^PSD(58. 8,+PSDS,1, PSDR)) Q:' PSDR  I $D (^PSD(58.8 ,+PSDS,1,P SDR,0)) S  PSDRG(+PSD R)=""
  354    F PSD=PSD SD:0 S PSD =$O(^PSD(5 8.81,"ACT" ,PSD)) Q:' PSD!(PSD>P SDED) F PS DR=0:0 S P SDR=$O(^PS D(58.81,"A CT",PSD,PS DS,PSDR))  Q:'PSDR  D
  355    .Q:'$D(PS DRG(PSDR))
  356    .F TYP=0: 0 S TYP=$O (^PSD(58.8 1,"ACT",PS D,PSDS,PSD R,TYP)) Q: 'TYP!(TYP= 12) F PSDA =0:0 S PSD A=$O(^PSD( 58.81,"ACT ",PSD,PSDS ,PSDR,TYP, PSDA)) Q:' PSDA  D SE T
  357    G:$D(ZTQU EUED) PRTQ UE G PRINT ^PSDACT2
  358   END ;
  359    D KVAR^VA DPT
  360    K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M
  361    K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID")
  362    K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK
  363    D ^%ZISC  S:$D(ZTQUE UED) ZTREQ ="@"
  364    Q
  365   SET ;sets  data
  366    ;Dave B ( PSD*3*14)  Disregard  if type is  15.
  367    Q:'$D(^PS D(58.81,PS DA,0)) Q:T YP=5 Q:TYP =15 S NODE =^(0),QTY= $P(NODE,"^ ",6),BFWD= $P(NODE,"^ ",10)
  368    S PSDRGN= $S($P($G(^ PSDRUG(PSD R,0)),"^") ]"":$P(^(0 ),"^"),1:" ZZ/"_PSDR_ " NAME MIS SING")
  369    S PSDUZ=$ S(TYP=3:+$ P($G(^PSD( 58.81,PSDA ,1)),"^",1 4),TYP=4:+ $P($G(^PSD (58.81,PSD A,1)),"^", 14),TYP=13 :+$P($G(^P SD(58.81,P SDA,5)),"^ ",2),TYP=1 4:+$P($G(^ PSD(58.81, PSDA,4))," ^",2),1:+$ P(NODE,"^" ,7))
  370    S:TYP=2 P SDUZ=$S(+$ P($G(^PSD( 58.81,PSDA ,1)),"^"): +$P($G(^(1 )),"^"),1: +$P(NODE," ^",7))
  371    S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**")
  372    I TYP=1 D  T1 G TMP
  373    I TYP=2 D  T2 G TMP
  374    I TYP=3 Q :'$D(^PSD( 58.81,PSDA ,3)) D T3  G TMP
  375    Q:TYP=4
  376    I TYP=6 Q :'$D(^PSD( 58.81,PSDA ,6)) D T6  G TMP
  377    I TYP=7 D  T7 G TMP
  378    I TYP=9 D  T9 G TMP
  379    I TYP=11  D T11 G TM P
  380    I TYP=13  Q:'$D(^PSD (58.81,PSD A,5)) D T1 3 G TMP
  381    I TYP=14  Q:'$D(^PSD (58.81,PSD A,4)) D T1 4 G TMP
  382    I TYP=16  D T16 G TM P
  383    I TYP>18  D TOTH
  384   TMP ;
  385    S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**")
  386    ;PSD*3*30  (Dave B -  Identify  person wit h more tha n just **)
  387    I $G(PSDU ZN)="**" S  PSDUZ=$P( $G(^PSD(58 .81,PSDA,0 )),"^",7), PSDUZN=$P( $G(^VA(200 ,+PSDUZ,0) ),"^"),PSD UZN=$S(PSD UZN]"":$E( $P(PSDUZN, ",",2))_$E (PSDUZN),1 :"**")
  388    S ^TMP("P SDACT",$J, PSDRGN,PSD ,TYP,PSDA) =BFWD_"^"_ NUM_"^"_TE XT_"^"_QTY _"^"_PSDUZ N I $D(PSD RTS) S ^TM P("PSDACT" ,$J,PSDRGN ,PSD,TYP,P SDA)=^TMP( "PSDACT",$ J,PSDRGN,P SD,TYP,PSD A)_"^1"
  389    K PSDRTS  Q
  390   T1 S NUM=" ***",TEXT= "RECEIPT I NTO PHARMA CY"
  391    I $P($G(^ PSD(58.81, PSDA,8))," ^")]"" S N UM=$P($G(^ PSD(58.81, PSDA,8))," ^") Q
  392    I +$P(NOD E,"^",9) S  NUM=+$P(N ODE,"^",9) ,NUM=$P($G (^PRC(442, NUM,0)),"^ ") Q
  393    I +$P(NOD E,"^",8) S  NUM=+$P(N ODE,"^",8) ,NUM=$P($G (^PRCS(410 ,NUM,0))," ^") Q
  394    Q
  395   T2 S QTY=- QTY,NUM="D ISP",NAOU= +$P(NODE," ^",18) S:N AOU NAOU=$ P($G(^PSD( 58.8,+NAOU ,0)),"^")  S TEXT=$S( NAOU]"":NA OU,1:"DISP ENSED FROM  PHARMACY" )
  396    I +$P(NOD E,"^",17)  S NUM="GS  # "_$P(NOD E,"^",17)
  397    Q
  398   T3 S NUM=" GS # ",TEX T="RETURNE D TO STOCK "
  399    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  400    ;PSD*3*30  (Dave B -  more prec ise infor  on RTS)
  401    I $G(NUM) ="GS # " D
  402    .S RX=$P( $G(^PSD(58 .81,PSDA,6 )),"^"),RX NUM=$P($G( ^PSD(58.81 ,PSDA,6)), "^",5)
  403    .S PAT=$P ($G(^PSRX( RX,0)),"^" ,2) I PAT  S DFN=PAT  D PID^VADP T6 S Y=PAT ,C=$P(^DD( 58.81,73,0 ),"^",2) D  Y^DIQ S T EXT=Y_"("_ VA("BID")_ ")" K DFN, VA("BID"), VA("PID")
  404    .S NUM="R X # "_$G(R XNUM)_" (" _$S($P($G( ^PSD(58.81 ,PSDA,6)), U,2):"R"_$ P($G(^(6)) ,U,2),$P($ G(^(6)),U, 4):"P"_$P( $G(^(6)),U ,4),1:"O") _")"
  405    .S QTY=$P (^PSD(58.8 1,PSDA,3), "^",2),BFW D=$P(^PSD( 58.81,PSDA ,0),"^",10 ),PSDRTS=1  Q
  406    I $G(PSDR TS)=1 Q
  407    S QTY=$P( ^PSD(58.81 ,PSDA,3)," ^",2),BFWD =$P(^(3)," ^",7)
  408    Q
  409   T6 S QTY=- QTY,NUM="R X # ",TEXT ="OUTPATIE NT RX" N R XNUM
  410    S RX=+$P( ^PSD(58.81 ,PSDA,6)," ^"),RXNUM= $S($P(^(6) ,"^",5)]"" :$P(^(6)," ^",5),$P($ G(^PSRX(RX ,0)),"^")] "":$P(^(0) ,"^"),1:"U NKNOWN"),N UM=NUM_RXN UM
  411    S NUM=NUM _" ("_$S($ P($G(^PSD( 58.81,PSDA ,6)),U,2): "R"_$P($G( ^(6)),U,2) ,$P($G(^(6 )),U,4):"P "_$P($G(^( 6)),U,4),1 :"O")_")"
  412    S PAT=+$P ($G(^PSRX( RX,0)),"^" ,2)
  413    S PSDRXIN =RX D VER^ PSDOPT
  414    ;W !,TEXT ," ",RXNUM
  415    S TEXT=$S ('$O(^PSRX ("B",RXNUM ,0)):"RX D ELETED",$G (PSDSTA)=1 3:"RX DELE TED",1:"UN KNOWN")
  416    ;W !,TEXT
  417    K PSDSTA, PSOVR,PSDR XIN
  418    I PAT S D FN=PAT D P ID^VADPT6  D
  419    .K C S Y= PAT,C=$P(^ DD(58.81,7 3,0),"^",2 ) D Y^DIQ  S TEXT=Y_"  ("_VA("BI D")_")" K  DFN,VA("BI D"),VA("PI D")
  420    Q
  421   T7 S NUM=" GS # ",TEX T="CANCEL  UNVERIFIED  ORDER",QT Y=0
  422    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  423    Q
  424   T9 S NUM=" ADJ",TEXT= $S($D(^PSD (58.81,+PS DA,9)):$P( NODE,"^",1 6),1:"ADJU STMENT")
  425    I $P(NODE ,"^",16)]" " S TEXT=$ P(NODE,"^" ,16)
  426    I $D(^PSD (58.81,PSD A,3)) S NU M="DEST #  "_$P(^(3), "^",8),TEX T="HOLDING  FOR DESTR UCTION"
  427    Q
  428   T11 S NUM= "***",TEXT ="INITIALI ZE BALANCE  AT SETUP"
  429    Q
  430   T13 S NUM= "GS # ",TE XT="CANCEL  VERIFIED  ORDER"
  431    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  432    S QTY=$P( ^PSD(58.81 ,PSDA,5)," ^",3),BFWD =$P(^(5)," ^",5)
  433    Q
  434   T14 S NUM= "GS # ",TE XT="EDIT V ERIFIED OR DER"
  435    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  436    S:$D(^PSD (58.81,PSD A,8)) TEXT ="EDIT VER IFIED INVO ICE",NUM=$ P(^PSD(58. 81,PSDA,8) ,"^",1) ;  <*65-RJS>
  437    S QTY=$P( ^PSD(58.81 ,PSDA,4)," ^",4),BFWD =$P(^(4)," ^",7)
  438    Q
  439   T16 S NUM= "TRV",TEXT ="TRANSFER  TO VAULT"
  440    Q
  441   TOTH ;Type  = 19,20,2 1,22
  442    S NUM="IN V",TEXT=$G (^PSD(58.8 4,+TYP,0)) ,QTY=""
  443    Q
  444   PRTQUE ;qu eues print  after com pile
  445    K ZTSAVE, ZTIO S ZTI O=PSDIO,ZT RTN="PRINT ^PSDACT2", ZTDESC="CS  PHARM Pri nt Daily A ctivity Lo g",ZTDTH=$ H,ZTSAVE(" ^TMP(""PSD ACT"",$J," )="",ZTSAV E("PSDSN") ="",ZTSAVE ("PSDATE") =""
  446    D ^%ZTLOA D K ZTSK G  END 
  447   After:
  448   PSDACT1 ;B IR/JPW,BJW -Print Dai ly Activit y Log (con t'd) ; 17  Jun 98
  449    ;;3.0;CON TROLLED SU BSTANCES ; **10,14,30 ,65,84**;1 3 Feb 97;B uild 5
  450    ;Referenc e to ^PRC( 442 suppor ted by IA  #682
  451    ;Referenc e to ^PRCS (410 suppo rted by IA  #198
  452    ;Referenc e to ^PSDR UG( suppor ted by IA  #221
  453    ;Referenc e to ^PSRX ( supporte d by IA #9 86
  454    ;Referenc e to ^DD(5 8.81 suppo rted by IA  #10154
  455    ;Referenc e to PSD(5 8.8 suppor ted by DBI A # 2711
  456    ;Referenc e to PSD(5 8.81 suppo rted by DB IA # 2808
  457    ;Referenc es to PSD( 58.84 supp orted by I A # 3485
  458    ;modified  for nois: tua-0498-3 2173,new c ode added  to t6
  459    ;op v.7 c hg the sta tus loc in  file 52
  460   START ;ent ry for com pile
  461    K ^TMP("P SDACT",$J)
  462    I $D(ALL)  F PSDR=0: 0 S PSDR=$ O(^PSD(58. 8,+PSDS,1, PSDR)) Q:' PSDR  I $D (^PSD(58.8 ,+PSDS,1,P SDR,0)) S  PSDRG(+PSD R)=""
  463    I $D(PSDA LL) F PSDR =0:0 S PSD R=$O(^PSD( 58.8,+PSDS ,1,PSDR))  Q:'PSDR  D   ;rtw add ed NSR2017 1111 
  464    . I $D(^P SD(58.8,+P SDS,1,PSDR ,0)) I $P( ^PSDRUG(+P SDR,0),U,3 )["2" S PS DRG(+PSDR) ="" ;rtw a dded NSR20 171111
  465    F PSD=PSD SD:0 S PSD =$O(^PSD(5 8.81,"ACT" ,PSD)) Q:' PSD!(PSD>P SDED) F PS DR=0:0 S P SDR=$O(^PS D(58.81,"A CT",PSD,PS DS,PSDR))  Q:'PSDR  D
  466    .Q:'$D(PS DRG(PSDR))
  467    .F TYP=0: 0 S TYP=$O (^PSD(58.8 1,"ACT",PS D,PSDS,PSD R,TYP)) Q: 'TYP!(TYP= 12) F PSDA =0:0 S PSD A=$O(^PSD( 58.81,"ACT ",PSD,PSDS ,PSDR,TYP, PSDA)) Q:' PSDA  D SE T
  468    G:$D(ZTQU EUED) PRTQ UE G PRINT ^PSDACT2
  469   END ;
  470    D KVAR^VA DPT
  471    K %,%DT,% H,%I,%ZIS, ACT,ALL,BF WD,C,DA,DA TE,DIC,DIR ,DIROUT,DI RUT,DTOUT, DUOUT,LN,M FG,NAOU,NO DE,NQTY,NU M
  472    K PAT,PG, PHARM,POP, PSD,PSDA,P SDATE,PSDE D,PSDEV,PS DIO,PSDOUT ,PSDPN,PSD R,PSDRG,PS DRGN,PSDS, PSDSD,PSDS N,PSDUZ,PS DUZN,RX,TE XT,TYP,QTY ,TYPE,X,Y, VA("BID"), VA("PID")
  473    K ^TMP("P SDACT",$J) ,ZTDESC,ZT DTH,ZTIO,Z TRTN,ZTSAV E,ZTSK
  474    K PSDALL  ;rtw added  NSR201711 11
  475    D ^%ZISC  S:$D(ZTQUE UED) ZTREQ ="@"
  476    Q
  477   SET ;sets  data
  478    ;Dave B ( PSD*3*14)  Disregard  if type is  15.
  479    Q:'$D(^PS D(58.81,PS DA,0)) Q:T YP=5 Q:TYP =15 S NODE =^(0),QTY= $P(NODE,"^ ",6),BFWD= $P(NODE,"^ ",10)
  480    S PSDRGN= $S($P($G(^ PSDRUG(PSD R,0)),"^") ]"":$P(^(0 ),"^"),1:" ZZ/"_PSDR_ " NAME MIS SING")
  481    S PSDUZ=$ S(TYP=3:+$ P($G(^PSD( 58.81,PSDA ,1)),"^",1 4),TYP=4:+ $P($G(^PSD (58.81,PSD A,1)),"^", 14),TYP=13 :+$P($G(^P SD(58.81,P SDA,5)),"^ ",2),TYP=1 4:+$P($G(^ PSD(58.81, PSDA,4))," ^",2),1:+$ P(NODE,"^" ,7))
  482    S:TYP=2 P SDUZ=$S(+$ P($G(^PSD( 58.81,PSDA ,1)),"^"): +$P($G(^(1 )),"^"),1: +$P(NODE," ^",7))
  483    S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**")
  484    I TYP=1 D  T1 G TMP
  485    I TYP=2 D  T2 G TMP
  486    I TYP=3 Q :'$D(^PSD( 58.81,PSDA ,3)) D T3  G TMP
  487    Q:TYP=4
  488    I TYP=6 Q :'$D(^PSD( 58.81,PSDA ,6)) D T6  G TMP
  489    I TYP=7 D  T7 G TMP
  490    I TYP=9 D  T9 G TMP
  491    I TYP=11  D T11 G TM P
  492    I TYP=13  Q:'$D(^PSD (58.81,PSD A,5)) D T1 3 G TMP
  493    I TYP=14  Q:'$D(^PSD (58.81,PSD A,4)) D T1 4 G TMP
  494    I TYP=16  D T16 G TM P
  495    I TYP>18  D TOTH
  496   TMP ;
  497    S PSDUZN= $P($G(^VA( 200,+PSDUZ ,0)),"^"), PSDUZN=$S( PSDUZN]"": $E($P(PSDU ZN,",",2)) _$E(PSDUZN ),1:"**")
  498    ;PSD*3*30  (Dave B -  Identify  person wit h more tha n just **)
  499    I $G(PSDU ZN)="**" S  PSDUZ=$P( $G(^PSD(58 .81,PSDA,0 )),"^",7), PSDUZN=$P( $G(^VA(200 ,+PSDUZ,0) ),"^"),PSD UZN=$S(PSD UZN]"":$E( $P(PSDUZN, ",",2))_$E (PSDUZN),1 :"**")
  500    S ^TMP("P SDACT",$J, PSDRGN,PSD ,TYP,PSDA) =BFWD_"^"_ NUM_"^"_TE XT_"^"_QTY _"^"_PSDUZ N I $D(PSD RTS) S ^TM P("PSDACT" ,$J,PSDRGN ,PSD,TYP,P SDA)=^TMP( "PSDACT",$ J,PSDRGN,P SD,TYP,PSD A)_"^1"
  501    K PSDRTS  Q
  502   T1 S NUM=" ***",TEXT= "RECEIPT I NTO PHARMA CY"
  503    I $P($G(^ PSD(58.81, PSDA,8))," ^")]"" S N UM=$P($G(^ PSD(58.81, PSDA,8))," ^") Q
  504    I +$P(NOD E,"^",9) S  NUM=+$P(N ODE,"^",9) ,NUM=$P($G (^PRC(442, NUM,0)),"^ ") Q
  505    I +$P(NOD E,"^",8) S  NUM=+$P(N ODE,"^",8) ,NUM=$P($G (^PRCS(410 ,NUM,0))," ^") Q
  506    Q
  507   T2 S QTY=- QTY,NUM="D ISP",NAOU= +$P(NODE," ^",18) S:N AOU NAOU=$ P($G(^PSD( 58.8,+NAOU ,0)),"^")  S TEXT=$S( NAOU]"":NA OU,1:"DISP ENSED FROM  PHARMACY" )
  508    I +$P(NOD E,"^",17)  S NUM="GS  # "_$P(NOD E,"^",17)
  509    Q
  510   T3 S NUM=" GS # ",TEX T="RETURNE D TO STOCK "
  511    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  512    ;PSD*3*30  (Dave B -  more prec ise infor  on RTS)
  513    I $G(NUM) ="GS # " D
  514    .S RX=$P( $G(^PSD(58 .81,PSDA,6 )),"^"),RX NUM=$P($G( ^PSD(58.81 ,PSDA,6)), "^",5)
  515    .S PAT=$P ($G(^PSRX( RX,0)),"^" ,2) I PAT  S DFN=PAT  D PID^VADP T6 S Y=PAT ,C=$P(^DD( 58.81,73,0 ),"^",2) D  Y^DIQ S T EXT=Y_"("_ VA("BID")_ ")" K DFN, VA("BID"), VA("PID")
  516    .S NUM="R X # "_$G(R XNUM)_" (" _$S($P($G( ^PSD(58.81 ,PSDA,6)), U,2):"R"_$ P($G(^(6)) ,U,2),$P($ G(^(6)),U, 4):"P"_$P( $G(^(6)),U ,4),1:"O") _")"
  517    .S QTY=$P (^PSD(58.8 1,PSDA,3), "^",2),BFW D=$P(^PSD( 58.81,PSDA ,0),"^",10 ),PSDRTS=1  Q
  518    I $G(PSDR TS)=1 Q
  519    S QTY=$P( ^PSD(58.81 ,PSDA,3)," ^",2),BFWD =$P(^(3)," ^",7)
  520    Q
  521   T6 S QTY=- QTY,NUM="R X # ",TEXT ="OUTPATIE NT RX" N R XNUM
  522    S RX=+$P( ^PSD(58.81 ,PSDA,6)," ^"),RXNUM= $S($P(^(6) ,"^",5)]"" :$P(^(6)," ^",5),$P($ G(^PSRX(RX ,0)),"^")] "":$P(^(0) ,"^"),1:"U NKNOWN"),N UM=NUM_RXN UM
  523    S NUM=NUM _" ("_$S($ P($G(^PSD( 58.81,PSDA ,6)),U,2): "R"_$P($G( ^(6)),U,2) ,$P($G(^(6 )),U,4):"P "_$P($G(^( 6)),U,4),1 :"O")_")"
  524    S PAT=+$P ($G(^PSRX( RX,0)),"^" ,2)
  525    S PSDRXIN =RX D VER^ PSDOPT
  526    ;W !,TEXT ," ",RXNUM
  527    S TEXT=$S ('$O(^PSRX ("B",RXNUM ,0)):"RX D ELETED",$G (PSDSTA)=1 3:"RX DELE TED",1:"UN KNOWN")
  528    ;W !,TEXT
  529    K PSDSTA, PSOVR,PSDR XIN
  530    I PAT S D FN=PAT D P ID^VADPT6  D
  531    .K C S Y= PAT,C=$P(^ DD(58.81,7 3,0),"^",2 ) D Y^DIQ  S TEXT=Y_"  ("_VA("BI D")_")" K  DFN,VA("BI D"),VA("PI D")
  532    Q
  533   T7 S NUM=" GS # ",TEX T="CANCEL  UNVERIFIED  ORDER",QT Y=0
  534    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  535    Q
  536   T9 S NUM=" ADJ",TEXT= $S($D(^PSD (58.81,+PS DA,9)):$P( NODE,"^",1 6),1:"ADJU STMENT")
  537    I $P(NODE ,"^",16)]" " S TEXT=$ P(NODE,"^" ,16)
  538    I $D(^PSD (58.81,PSD A,3)) S NU M="DEST #  "_$P(^(3), "^",8),TEX T="HOLDING  FOR DESTR UCTION"
  539    Q
  540   T11 S NUM= "***",TEXT ="INITIALI ZE BALANCE  AT SETUP"
  541    Q
  542   T13 S NUM= "GS # ",TE XT="CANCEL  VERIFIED  ORDER"
  543    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  544    S QTY=$P( ^PSD(58.81 ,PSDA,5)," ^",3),BFWD =$P(^(5)," ^",5)
  545    Q
  546   T14 S NUM= "GS # ",TE XT="EDIT V ERIFIED OR DER"
  547    I +$P(NOD E,"^",17)  S NUM=NUM_ $P(NODE,"^ ",17)
  548    S:$D(^PSD (58.81,PSD A,8)) TEXT ="EDIT VER IFIED INVO ICE",NUM=$ P(^PSD(58. 81,PSDA,8) ,"^",1) ;  <*65-RJS>
  549    S QTY=$P( ^PSD(58.81 ,PSDA,4)," ^",4),BFWD =$P(^(4)," ^",7)
  550    Q
  551   T16 S NUM= "TRV",TEXT ="TRANSFER  TO VAULT"
  552    Q
  553   TOTH ;Type  = 19,20,2 1,22
  554    S NUM="IN V",TEXT=$G (^PSD(58.8 4,+TYP,0)) ,QTY=""
  555    Q
  556   PRTQUE ;qu eues print  after com pile
  557    K ZTSAVE, ZTIO S ZTI O=PSDIO,ZT RTN="PRINT ^PSDACT2", ZTDESC="CS  PHARM Pri nt Daily A ctivity Lo g",ZTDTH=$ H,ZTSAVE(" ^TMP(""PSD ACT"",$J," )="",ZTSAV E("PSDSN") ="",ZTSAVE ("PSDATE") =""
  558    D ^%ZTLOA D K ZTSK G  END
  559   PSDOPT
  560   Before: 
  561   PSDOPT ;BI R/JPW,LTL, BJW - Outp atient Rx  Entry ;2/5 /04 12:15p m
  562    ;;3.0;CON TROLLED SU BSTANCES;* *10,11,15, 21,30,39,4 8,62,69,71 ,79**;13 F eb 97;Buil d 20
  563    ;Referenc e to ^PSDR UG( suppor ted by DBI A #221
  564    ;Referenc es to ^PSD (58.8 are  covered by  DBIA #271 1
  565    ;Referenc es to file  58.81 are  covered b y DBIA #28 08
  566    ;Referenc e to PSRX(  supported  by DBIA # 986
  567    ;Referenc e to PSOFU NC support ed by DBIA  #981
  568    ;Line Tag  FINAL^PSO LSET suppo rted by DB IA #982
  569    ;
  570    ;mod.for  nois:tua-0 498-32173, askp,bc1;v er
  571    ;enhancem ent for Ou tpat V7 st atus code  of 12,13,1 4,15 in as kp
  572    ;
  573    ;further  modificati ons relate d to the d eletion of
  574    ;refills  made in Ap ril 1999 
  575    ;
  576    ;PSD*3*39  Kill all  variables
  577    D PSDKLL^ PSDOPT2
  578    I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE)
  579    I '$D(^XU SEC("PSJ R PHARM",DUZ )),'$D(^XU SEC("PSD T ECH ADV",D UZ)) W !!, "Please co ntact your  Pharmacy  Coordinato r for acce ss",!,"to  log Outpat ient Presc riptions.  Either the  PSJ RPHAR M",!,"or P SD TECH AD V security  key requi red.",!! Q
  580    I $P($G(^ VA(200,DUZ ,20)),U,4) ']"" N XQH  S XQH="PS D ESIG" D  EN^XQH G E ND
  581    N X,X1 D  SIG^XUSESI G I X1=""  G END
  582    N LN S (P SDOUT,NEW) =0,PSDUZ=D UZ,$P(LN," -",80)="", Y=DT
  583    X ^DD("DD ") S RPDT= Y
  584   ASKD ;ask  disp site
  585    S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4)
  586    G:$P(PSDS ITE,U,5) C HKD
  587    K DIC,DA  S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) ,$S('$D(^( ""I"")):1, +^(""I"")> DT:1,'^("" I""):1,1:0 )"
  588    S DIC("A" )="Select  Primary Di spensing S ite: ",DIC ("B")=$P(P SDSITE,U,4 )
  589    W ! D ^DI C K DIC G: Y<0 END
  590    S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN
  591   CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no  stocked d rugs for t his Pharma cy Vault!! ",!! G END
  592   ASKPH ;ask  releasing  RPH
  593    S DIC="^V A(200,",DI C(0)="QEAM ",DIC("S") ="I $D(^XU SEC(""PSOR PH"",+Y))"
  594    S DIC("A" )="Please  identify P harmacist  for Outpat ient Relea se: "
  595    S:$D(^XUS EC("PSORPH ",DUZ)) DI C("B")=$P( $G(^VA(200 ,DUZ,0)),U )
  596    W ! D ^DI C K DIC G: Y<1 END S  PSDRPH=+Y
  597   ASKP ;ask  rx #
  598    K PSDSEL, PSDPOST,PS DREL
  599    ;PSD*3*30  (Dave Blo cker ) Loc k the scri pt node
  600    I $G(PSDR X)'="" L - ^PSRX(PSDR X)
  601    W ! K DIR ,NEW,PSDRX ,PSDRXIN,R XNUM S PSD OUT=0 S DI R("A")="En ter/Wand P RESCRIPTIO N number"
  602    S DIR("?" )="^D HELP ^PSODISP", DIR(0)="F^ 1:35" D ^D IR K DIR
  603    G:$D(DTOU T)!($D(DUO UT)) END G :X="" ASKP H
  604    S X=$$UP^ XLFSTR(X)
  605    I X'["-"  D  S PSDRX =$G(PSDRXI N)
  606    .S PSDRX= 0 F  S PSD RX=$O(^PSR X("B",X,PS DRX)) Q:'P SDRX  S PS DRXIN=PSDR X D VER
  607    I X'["-", '$G(PSDRX) !('$D(^PSR X(+$G(PSDR X),0))) W  !,"INVALID  PRESCRIPT ION NUMBER " G ASKP
  608    ;
  609    ;PSD*3*30  - lock th e script
  610    I X'["-"  L +^PSRX(P SDRX):5 I  '$T W !!," Sorry, som eone else  is editing  this pres cription.  Please try  again lat er." K PSD RX G ASKP
  611    ;
  612    ;DAVE B ( PSD*3*15)  Show previ ous postin gs
  613    I X'["-"  I $G(PSOVR )=1,$G(PSD STA)=12!($ G(PSDSTA)= 13)!($G(PS DSTA)=14)! ($G(PSDSTA )=15)!($G( PSDSTA)=11 ) S PSDXXX =X D CHKRF  I $G(PSDN EXT)=1 G A SKP
  614    ;<JD *62
  615    ;
  616    S PSD(1)= X,DIC="^DI C(4,",DR=9 9,DA=+$P($ G(^XMB(1,1 ,"XUS")),U ,17)
  617    K DIQ S D IQ="PSD" D  EN^DIQ1 S  X=PSD(1)  K DIC,DR,D IQ
  618    I X["-",$ P(X,"-")'= PSD(4,DA,9 9) K DA,PS D W !?7,$C (7)," INVA LID STATIO N NUMBER ! !",! G ASK P
  619    K DA,PSD
  620    I X["-" S  PSDRX=$P( X,"-",2) I  (PSDRX'?1 N.N.1U) W  !?7,$C(7), " INVALID  PRESCRIPTI ON NUMBER"  G ASKP
  621    I X["-" I  '$D(^PSRX (+$G(PSDRX ),0))!($G( PSDRX)']"" ) W !?7,$C (7)," NON- EXISTENT P RESCRIPTIO N" G ASKP
  622    ;
  623    I X["-",$ D(^PSRX(PS DRX,0)) S  PSDRXIN=+P SDRX D VER  I PSOVR=1 ,$G(PSDSTA )=12!($G(P SDSTA)=13) !($G(PSDST A)=14)!($G (PSDSTA)=1 5) D CHKRF  I $G(PSDN EXT)=1 G A SKP
  624    I X["-" L  +^PSRX(PS DRX):5 I ' $T W !!,"S orry, some one else i s editing  this presc ription. P lease try  again late r." K PSDR X G ASKP
  625    ;
  626    ; (PSD*3* 21) Check  for transm ission sta tus for ba rcode entr y
  627    ;
  628    G:$D(^PSR X(PSDRX,0) ) BC1
  629    W !?7,$C( 7)," IMPRO PER BARCOD E FORMAT"  G ASKP
  630   BC1 ;
  631    S PSDRXIN =+PSDRX D  VER
  632    I $G(PSDS TA)=13!(+$ P($G(^PSRX (+PSDRX,0) ),"^",2)=0 ) W !?7,$C (7)," PRES CRIPTION H AS BEEN DE LETED." G  ASKP
  633    I $G(PSDS TA),$S($G( PSDSTA)=2: 0,$G(PSDST A)=5:0,$G( PSDSTA)=11 :0,$G(PSDS TA)=12:0,$ G(PSDSTA)= 14:0,$G(PS DSTA)=15:0 ,1:1) D  K  J,RX0,RX2 ,ST,ST0 G  ASKP
  634    .S RX0=$G (^PSRX(+PS DRX,0)),RX 2=^PSRX(+P SDRX,2),J= PSDRX S $P (RX0,"^",1 5)=$G(PSDS TA) D ^PSO FUNC
  635    .W !!,$C( 7)," Statu s of ",ST, " is not a ppropriate  for selec tion."
  636    K PSDSTA, PSOVR,PSDR XIN
  637    S RXNUM=$ P($G(^PSRX (+PSDRX,0) ),U),PSDR= +$P($G(^(0 )),U,6),DF N=+$P($G(^ (0)),U,2), QTY=$P($G( ^(0)),U,7) ,PSDRN=$P( $G(^PSDRUG (PSDR,0)), "^")
  638    N C S Y=D FN,C=$P(^D D(58.81,73 ,0),U,2) D  Y^DIQ S P ATN=Y
  639    D PID^VAD PT6
  640    I '$D(^PS D(58.8,+PS DS,1,PSDR, 0)) W !!,P SDRN," is  not curren tly stocke d in ",PSD SN,".",!!, "** No act ion taken.  **",!! G  END
  641    I $D(^PSD (58.81,"AO P",PSDRX))  D ^PSDOPT 2 I PSDOUT  D MSG G E ND
  642    G ^PSDOPT 0
  643   CHK ;displ ays and ch ecks if ok
  644   CLLDIR I $ D(PSDSEL(" OR")) S DI R(0)="S^1: Original;" ,CNT=1
  645    I $D(PSDS EL("RF"))  D
  646    .S X1=0 F   S X1=$O( PSDSEL("RF ",X1)) Q:X 1=""  D
  647    ..I $D(PS DRET("RF", X1)),(PSDR ET("RF",X1 )\1)=$P(PS DSEL("RF", X1),"^") D  RTSDTC^PS DOPT2 Q
  648    ..I $D(PS DRET("RF", X1)),PSDRE T("RF",X1) <$P(PSDSEL ("RF",X1), "^") D CLL DIR2 Q
  649    ..I '$D(P SDRET("RF" ,X1)) D CL LDIR2 Q
  650    ..Q
  651    I $D(PSDS EL("PR"))  D
  652    .S X1=0 F   S X1=$O( PSDSEL("PR ",X1)) Q:X 1=""  I '$ D(PSDRET(" PR",X1)) S  CNT=$G(CN T)+1,DIR(0 )=$S($G(CN T)=1:"S^1: Partial #" _X1,1:DIR( 0)_CNT_":P artial #"_ X1)_" ("_$ P(PSDSEL(" PR",X1),"^ ",2)_");"
  653    I $G(DIR( 0))'="" D
  654    .K PSDERR  D ^DIR I  $D(DIRUT)  S PSDERR=1  Q
  655    .S PSDA=$ E(Y(0))
  656    Q:$D(PSDE RR)
  657    Q:'$D(Y(0 )) I PSDA= "O" S DAT= $P($G(^PSR X(PSDRX,2) ),U,2),PSD POST=$P(PS DSEL("OR") ,"^",3),PS DREL=$P(PS DSEL("OR") ,"^",4) G  PROCESS
  658    I PSDA="R " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("RF" ,XXX)),"^" ,1),QTY=$P (PSDSEL("R F",XXX),U, 2),PSDPOST =$P(PSDSEL ("RF",XXX) ,U,3),PSDR EL=$P(PSDS EL("RF",XX X),U,4) G  PROCESS
  659    I PSDA="P " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("PR" ,XXX)),"^" ,1),QTY=$P (PSDSEL("P R",XXX),U, 2),PSDPOST =$P(PSDSEL ("PR",XXX) ,U,3),PSDR EL=$P(PSDS EL("PR",XX X),U,4) G  PROCESS
  660    W !,"Erro r somewher e" G ASKP
  661   PROCESS ;p rocess sel ection
  662    I PSDA'=" O" S PSDFL NO=XXX ;fi ll number
  663    I PSDA="O " S NEW=1, (NEW(1),NE W(2))=0 ;O riginal
  664    I PSDA="R " S NEW(1) =XXX,(NEW, NEW(2))=0  ;Refill
  665    I PSDA="P " S NEW(2) =XXX,(NEW, NEW(1))=0  ;Partial
  666    S X=0 F   S X=$O(^PS RX(PSDRX,4 ,X)) Q:X'> 0 S STATUS =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,4),NUMBER =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,3) I $G(S TATUS)'=3  D
  667    .I NUMBER =0,$G(NEW) =1,$G(NEW( 1))=0 D CM OPMSG
  668    .I NUMBER =$G(NEW(1) ),$G(NEW)= 0,PSDA'="P ",'$D(PSDR ET("RF",NU MBER)) D C MOPMSG
  669    I $G(PSDO UT)=1 G AS KP
  670    ;
  671    D:PSDA="O " PSDORIG^ PSDOPT1 D: PSDA="R" P SDRFL^PSDO PT1 D:PSDA ="P" PSDPR TL^PSDOPT1
  672    I $G(PSDO UT)=1 G AS KP
  673    I $G(PSDP OST)=1,$G( PSDREL)=""  W !,"This  fill has  already be en posted. ",$C(7) G  ASKP
  674    I $G(PSDR EL)'="",$G (PSDPOST)' >0 W !,"Th is fill ha s already  been relea sed.",$C(7 )
  675    I $G(PSDR EL)'="",$G (PSDPOST)> 0 W !,"Thi s fill has  already b een posted  & release d, no furt her action  required. ",$C(7) G  ASKP
  676    D DISPLAY  G:PSDOUT  END
  677    K DA,DIR, DIRUT S DI R(0)="YA", DIR("B")=" YES",DIR(" A")="Is th is OK? "
  678    S DIR("?" ,1)="Answe r 'YES' to  log this  RX transac tion in yo ur CS vaul t,",DIR("? ")="answer  'NO' to r eselect a  prescripti on, or '^'  to quit."
  679    D ^DIR K  DIR I Y<1  D MSG G:$D (DIRUT) EN D G:Y<1 AS KP
  680    D ^PSDOPT 1 G ASKP
  681   END K %,%H ,%I,BAL,C, CNT,DA,DAT ,DD,DFN,DI C,DIE,DIK, DINUM,DIR, DIROUT,DIR UT,DLAYGO, DO,DR,JJ,L N,NEW,NODE ,NODE6 D F INAL^PSOLS ET
  682    I $G(PSDR X)'="" L - ^PSRX(PSDR X)
  683    K PATN,PH ARM,PHARMN ,PRF,PSDA, PSDATE,PSD OUT,PSDR,P SDRN,PSDRP H,PSDRX,PS DS,PSDSN,P SDT,PSDUZ, PSOCSUB,QT Y,RF,RPDT, RXNUM,X,Y
  684    D KVAR^VA DPT K VA(" PID"),VA(" BID")
  685    Q
  686   CHKEY ;che ck if user  has acces s
  687    I '$D(^XU SEC("PSJ R PHARM",DUZ )) D  S PS DOUT=1
  688    .W !!?12, "** You ha ve no acce ss to rele ase this p rescriptio n."
  689    .W !?15," The PSJ RP HARM secur ity key is  required.  **",!
  690    Q
  691   CLLDIR2 S  CNT=$G(CNT )+1,DIR(0) =$S($G(CNT )=1:"S^1:R efill #"_X 1,1:DIR(0) _CNT_":Ref ill #"_X1) _";"
  692    Q
  693   DISPLAY ;d isp data
  694    W !!,?20, "View Cont rolled Sub stances Rx  # ",RXNUM ,!,?28,RPD T,!,LN,!!
  695    W "Locati on: ",?10, PSDSN,?55
  696    S PSDRN(1 )=$S(NEW:" Original", $G(NEW(1)) :"Refill # "_NEW(1),1 :"Partial  #"_$G(NEW( 2))) W PSD RN(1)
  697    W !,"Drug : ",?10,PS DRN,?55,"Q uantity: " ,QTY
  698    ;
  699    ;DAVE B ( PSD*3*15)  check for  Non-numeri c quantity
  700    I QTY'?.N  W !,"The  Quantity i s not stri ctly numer ic. This w ill cause  the new ba lance to b e",!,"calc ulated inc orrectly." ,!
  701    W !,"Pati ent: ",?10 ,PATN_" (" _VA("BID") _")",?55,P SDRN(1),"  Date: ",?6 5,$E(DAT,4 ,5)_"/"_$E (DAT,6,7)_ "/"_$E(DAT ,2,3),!
  702    S BAL=+$P ($G(^PSD(5 8.8,+PSDS, 1,PSDR,0)) ,"^",4) I  QTY>BAL W  !!,?5,"You r balance  is ",BAL," .",!,?5,"Y ou may not  dispense  lower than  your bala nce.",!! D  MSG S PSD OUT=1 Q
  703    W !!,?15, "Old Balan ce: ",BAL, ?40,"New B alance: ", BAL-QTY,!!
  704    Q
  705   MSG W $C(7 ),!!,"No a ction take n. This tr ansaction  has not be en recorde d.",!!
  706    Q
  707   VER ;Curre nt Outpati ent Versio n, and Rx  status add ed 6/17/98
  708    K PSDSTA  S PSDHOLDX =$G(X) S P SOVR=$$VER SION^XPDUT L("PSO") S  X=$G(PSDH OLDX) K PS DHOLDX S P SOVR=$S($G (PSOVR)>6: 1,1:0)
  709    I $G(PSDR XIN) S PSD STA=$S(PSO VR:$P($G(^ PSRX(PSDRX IN,"STA")) ,"^"),1:$P ($G(^PSRX( PSDRXIN,0) ),"^",15))
  710    Q
  711   CHKRF ;Dav e B (PSD*3 *30) if it s deleted,  show stat us.
  712    W !,"This  RX has a  status of  '"_$S(PSDS TA=11:"EXP IRED",PSDS TA=12:"DIS CONTINUED" ,PSDSTA=13 :"DELETED" ,PSDSTA=14 :"DISCONTI NUED BY PR OVIDER",PS DSTA=15:"D ISCONTINUE D (EDIT)", 1:"Unknown  Procedure ")_$S(PSDS TA=12:"'." ,1:"', no  action can  be taken. ")
  713    ;< JD*62
  714    I $O(^PSR X(PSDRX,"A ",0))>0 W  !!,"Below  is a list  of actions  taken on  the prescr iption.",! !,"DATE/TI ME",?22,"P ERSON",?45 ,"ACTIVITY ",! F X=1: 1:53 W "="  F X=1:1:( IOM-1) W " ="
  715    S X3=0 F   S X3=$O(^ PSRX(PSDRX ,"A",X3))  Q:X3=""  S  DATA=$G(^ PSRX(PSDRX ,"A",X3,0) ),Y=$P(DAT A,"^",1) X  ^DD("DD")  S DATE=Y, X=$P(DATA, "^",2) D
  716    .I $G(X)' ="" S ACTI VITY=$$EXT ERNAL^DILF D(52.3,.02 ,,X)
  717    .S DELDUZ =$$EXTERNA L^DILFD(52 .3,.03,,$P (DATA,"^", 3)) S DELD UZ=$S($G(D ELDUZ)="": "Unknown ( "_$P(DATA, "^",3)_")" ,1:DELDUZ)
  718    .K DELREA S S DELREA S=$P(DATA, "^",5)
  719    .W !,DATE ,?22,DELDU Z,?45,ACTI VITY I $G( DELREAS)'= "" W !,"Co mment: ",$ G(DELREAS)
  720    I $G(PSDS TA)'=12 S  PSDNEXT=1  Q
  721   ASK12 R !, "Do you wi sh to cont inue? NO / / ",AN:DTI ME S:AN=""  AN="N"
  722    I "YyNn"' [AN W !,"A nswer 'N'o , and you  will promp ted for an other pres cription."  G ASK12
  723    I "nN"[AN  S PSDNEXT =1 Q
  724    K PSDNEXT
  725    Q
  726   CMOPMSG W  !,?10,"Thi s is a CMO P fill and  has been  transmitte d, dispens ed or ",!? 10,"retran smitted.", ! S PSDOUT =1 Q
  727   KLLALL ;Ki ll all
  728   After: 
  729   PSDOPT ;BI R/JPW,LTL, BJW - Outp atient Rx  Entry ;2/5 /04 12:15p m
  730    ;;3.0;CON TROLLED SU BSTANCES;* *10,11,15, 21,30,39,4 8,62,69,71 ,79,84**;1 3 Feb 97;B uild 20
  731    ;Referenc e to ^PSDR UG( suppor ted by DBI A #221
  732    ;Referenc es to ^PSD (58.8 are  covered by  DBIA #271 1
  733    ;Referenc es to file  58.81 are  covered b y DBIA #28 08
  734    ;Referenc e to PSRX(  supported  by DBIA # 986
  735    ;Referenc e to PSOFU NC support ed by DBIA  #981
  736    ;Line Tag  FINAL^PSO LSET suppo rted by DB IA #982
  737    ;
  738    ;mod.for  nois:tua-0 498-32173, askp,bc1;v er
  739    ;enhancem ent for Ou tpat V7 st atus code  of 12,13,1 4,15 in as kp
  740    ;
  741    ;further  modificati ons relate d to the d eletion of
  742    ;refills  made in Ap ril 1999 
  743    ;
  744    ;PSD*3*39  Kill all  variables
  745    D PSDKLL^ PSDOPT2
  746    I '$D(PSD SITE) D ^P SDSET Q:'$ D(PSDSITE)
  747    I '$D(^XU SEC("PSJ R PHARM",DUZ )),'$D(^XU SEC("PSD T ECH ADV",D UZ)) W !!, "Please co ntact your  Pharmacy  Coordinato r for acce ss",!,"to  log Outpat ient Presc riptions.  Either the  PSJ RPHAR M",!,"or P SD TECH AD V security  key requi red.",!! Q
  748    I $P($G(^ VA(200,DUZ ,20)),U,4) ']"" N XQH  S XQH="PS D ESIG" D  EN^XQH G E ND
  749    N X,X1 D  SIG^XUSESI G I X1=""  G END
  750    N LN S (P SDOUT,NEW) =0,PSDUZ=D UZ,$P(LN," -",80)="", Y=DT
  751    X ^DD("DD ") S RPDT= Y
  752   ASKD ;ask  disp site
  753    S PSDS=$P (PSDSITE,U ,3),PSDSN= $P(PSDSITE ,U,4)
  754    G:$P(PSDS ITE,U,5) C HKD
  755    K DIC,DA  S DIC=58.8 ,DIC(0)="Q EAZ",DIC(" S")="I $P( ^(0),""^"" ,3)=+PSDSI TE,$S($P(^ (0),""^"", 2)[""M"":1 ,$P(^(0)," "^"",2)["" S"":1,1:0) ,$S('$D(^( ""I"")):1, +^(""I"")> DT:1,'^("" I""):1,1:0 )"
  756    S DIC("A" )="Select  Primary Di spensing S ite: ",DIC ("B")=$P(P SDSITE,U,4 )
  757    W ! D ^DI C K DIC G: Y<0 END
  758    S PSDS=+Y ,PSDSN=$P( Y,"^",2),$ P(PSDSITE, U,3)=+Y,$P (PSDSITE,U ,4)=PSDSN
  759   CHKD I '$O (^PSD(58.8 ,PSDS,1,0) ) W !!,"Th ere are no  stocked d rugs for t his Pharma cy Vault!! ",!! G END
  760   ASKPH ;ask  releasing  RPH
  761    S DIC="^V A(200,",DI C(0)="QEAM ",DIC("S") ="I $D(^XU SEC(""PSOR PH"",+Y))"
  762    S DIC("A" )="Please  identify P harmacist  for Outpat ient Relea se: "
  763    S:$D(^XUS EC("PSORPH ",DUZ)) DI C("B")=$P( $G(^VA(200 ,DUZ,0)),U )
  764    W ! D ^DI C K DIC G: Y<1 END S  PSDRPH=+Y
  765   ASKP ;ask  rx #
  766    K PSDSEL, PSDPOST,PS DREL
  767    ;PSD*3*30  (Dave Blo cker ) Loc k the scri pt node
  768    I $G(PSDR X)'="" L - ^PSRX(PSDR X)
  769    W ! K DIR ,NEW,PSDRX ,PSDRXIN,R XNUM S PSD OUT=0 S DI R("A")="En ter/Wand P RESCRIPTIO N number"
  770    S DIR("?" )="^D HELP ^PSODISP", DIR(0)="F^ 1:35" D ^D IR K DIR
  771    G:$D(DTOU T)!($D(DUO UT)) END G :X="" ASKP H
  772    S X=$$UP^ XLFSTR(X)
  773    I X'["-"  D  S PSDRX =$G(PSDRXI N)
  774    .S PSDRX= 0 F  S PSD RX=$O(^PSR X("B",X,PS DRX)) Q:'P SDRX  S PS DRXIN=PSDR X D VER
  775    I X'["-", '$G(PSDRX) !('$D(^PSR X(+$G(PSDR X),0))) W  !,"INVALID  PRESCRIPT ION NUMBER " G ASKP
  776    ;
  777    ;PSD*3*30  - lock th e script
  778    I X'["-"  L +^PSRX(P SDRX):5 I  '$T W !!," Sorry, som eone else  is editing  this pres cription.  Please try  again lat er." K PSD RX G ASKP
  779    ;
  780    ;DAVE B ( PSD*3*15)  Show previ ous postin gs
  781    I X'["-"  I $G(PSOVR )=1,$G(PSD STA)=12!($ G(PSDSTA)= 13)!($G(PS DSTA)=14)! ($G(PSDSTA )=15)!($G( PSDSTA)=11 ) S PSDXXX =X D CHKRF  I $G(PSDN EXT)=1 G A SKP
  782    ;<JD *62
  783    ;
  784    S PSD(1)= X,DIC="^DI C(4,",DR=9 9,DA=+$P($ G(^XMB(1,1 ,"XUS")),U ,17)
  785    K DIQ S D IQ="PSD" D  EN^DIQ1 S  X=PSD(1)  K DIC,DR,D IQ
  786    I X["-",$ P(X,"-")'= PSD(4,DA,9 9) K DA,PS D W !?7,$C (7)," INVA LID STATIO N NUMBER ! !",! G ASK P
  787    K DA,PSD
  788    I X["-" S  PSDRX=$P( X,"-",2) I  (PSDRX'?1 N.N.1U) W  !?7,$C(7), " INVALID  PRESCRIPTI ON NUMBER"  G ASKP
  789    I X["-" I  '$D(^PSRX (+$G(PSDRX ),0))!($G( PSDRX)']"" ) W !?7,$C (7)," NON- EXISTENT P RESCRIPTIO N" G ASKP
  790    ;
  791    I X["-",$ D(^PSRX(PS DRX,0)) S  PSDRXIN=+P SDRX D VER  I PSOVR=1 ,$G(PSDSTA )=12!($G(P SDSTA)=13) !($G(PSDST A)=14)!($G (PSDSTA)=1 5) D CHKRF  I $G(PSDN EXT)=1 G A SKP
  792    I X["-" L  +^PSRX(PS DRX):5 I ' $T W !!,"S orry, some one else i s editing  this presc ription. P lease try  again late r." K PSDR X G ASKP
  793    ;
  794    ; (PSD*3* 21) Check  for transm ission sta tus for ba rcode entr y
  795    ;
  796    G:$D(^PSR X(PSDRX,0) ) BC1
  797    W !?7,$C( 7)," IMPRO PER BARCOD E FORMAT"  G ASKP
  798   BC1 ;
  799    S PSDRXIN =+PSDRX D  VER
  800    I $G(PSDS TA)=13!(+$ P($G(^PSRX (+PSDRX,0) ),"^",2)=0 ) W !?7,$C (7)," PRES CRIPTION H AS BEEN DE LETED." G  ASKP
  801    I $G(PSDS TA),$S($G( PSDSTA)=2: 0,$G(PSDST A)=5:0,$G( PSDSTA)=11 :0,$G(PSDS TA)=12:0,$ G(PSDSTA)= 14:0,$G(PS DSTA)=15:0 ,1:1) D  K  J,RX0,RX2 ,ST,ST0 G  ASKP
  802    .S RX0=$G (^PSRX(+PS DRX,0)),RX 2=^PSRX(+P SDRX,2),J= PSDRX S $P (RX0,"^",1 5)=$G(PSDS TA) D ^PSO FUNC
  803    .W !!,$C( 7)," Statu s of ",ST, " is not a ppropriate  for selec tion."
  804    K PSDSTA, PSOVR,PSDR XIN
  805    S RXNUM=$ P($G(^PSRX (+PSDRX,0) ),U),PSDR= +$P($G(^(0 )),U,6),DF N=+$P($G(^ (0)),U,2), QTY=$P($G( ^(0)),U,7) ,PSDRN=$P( $G(^PSDRUG (PSDR,0)), "^")
  806    N C S Y=D FN,C=$P(^D D(58.81,73 ,0),U,2) D  Y^DIQ S P ATN=Y
  807    D PID^VAD PT6
  808    I '$D(^PS D(58.8,+PS DS,1,PSDR, 0)) W !!,P SDRN," is  not curren tly stocke d in ",PSD SN,".",!!, "** No act ion taken.  **",!! G  END
  809    I $D(^PSD (58.81,"AO P",PSDRX))  D ^PSDOPT 2 I PSDOUT  D MSG G E ND
  810    G ^PSDOPT 0
  811   CHK ;displ ays and ch ecks if ok
  812   CLLDIR I $ D(PSDSEL(" OR")) S DI R(0)="S^1: Original;" ,CNT=1
  813    I $D(PSDS EL("RF"))  D
  814    .S X1=0 F   S X1=$O( PSDSEL("RF ",X1)) Q:X 1=""  D
  815    ..I $D(PS DRET("RF", X1)),(PSDR ET("RF",X1 )\1)=$P(PS DSEL("RF", X1),"^") D  RTSDTC^PS DOPT2 Q
  816    ..I $D(PS DRET("RF", X1)),PSDRE T("RF",X1) <$P(PSDSEL ("RF",X1), "^") D CLL DIR2 Q
  817    ..I '$D(P SDRET("RF" ,X1)) D CL LDIR2 Q
  818    ..Q
  819    I $D(PSDS EL("PR"))  D
  820    .S X1=0 F   S X1=$O( PSDSEL("PR ",X1)) Q:X 1=""  I '$ D(PSDRET(" PR",X1)) S  CNT=$G(CN T)+1,DIR(0 )=$S($G(CN T)=1:"S^1: Partial #" _X1,1:DIR( 0)_CNT_":P artial #"_ X1)_" ("_$ P(PSDSEL(" PR",X1),"^ ",2)_");"
  821    I $G(DIR( 0))'="" D
  822    .K PSDERR  D ^DIR I  $D(DIRUT)  S PSDERR=1  Q
  823    .S PSDA=$ E(Y(0))
  824    Q:$D(PSDE RR)
  825    Q:'$D(Y(0 )) I PSDA= "O" S DAT= $P($G(^PSR X(PSDRX,2) ),U,2),PSD POST=$P(PS DSEL("OR") ,"^",3),PS DREL=$P(PS DSEL("OR") ,"^",4) G  PROCESS
  826    I PSDA="R " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("RF" ,XXX)),"^" ,1),QTY=$P (PSDSEL("R F",XXX),U, 2),PSDPOST =$P(PSDSEL ("RF",XXX) ,U,3),PSDR EL=$P(PSDS EL("RF",XX X),U,4) G  PROCESS
  827    I PSDA="P " S XX=$P( Y(0),"#",2 ),XXX=$P(X X," ",1),D AT=$P($G(P SDSEL("PR" ,XXX)),"^" ,1),QTY=$P (PSDSEL("P R",XXX),U, 2),PSDPOST =$P(PSDSEL ("PR",XXX) ,U,3),PSDR EL=$P(PSDS EL("PR",XX X),U,4) G  PROCESS
  828    W !,"Erro r somewher e" G ASKP
  829   PROCESS ;p rocess sel ection
  830    I PSDA'=" O" S PSDFL NO=XXX ;fi ll number
  831    I PSDA="O " S NEW=1, (NEW(1),NE W(2))=0 ;O riginal
  832    I PSDA="R " S NEW(1) =XXX,(NEW, NEW(2))=0  ;Refill
  833    I PSDA="P " S NEW(2) =XXX,(NEW, NEW(1))=0  ;Partial
  834    S X=0 F   S X=$O(^PS RX(PSDRX,4 ,X)) Q:X'> 0 S STATUS =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,4),NUMBER =$P($G(^PS RX(PSDRX,4 ,X,0)),"^" ,3) I $G(S TATUS)'=3  D
  835    .I NUMBER =0,$G(NEW) =1,$G(NEW( 1))=0 D CM OPMSG
  836    .I NUMBER =$G(NEW(1) ),$G(NEW)= 0,PSDA'="P ",'$D(PSDR ET("RF",NU MBER)) D C MOPMSG
  837    I $G(PSDO UT)=1 G AS KP
  838    ;
  839    D:PSDA="O " PSDORIG^ PSDOPT1 D: PSDA="R" P SDRFL^PSDO PT1 D:PSDA ="P" PSDPR TL^PSDOPT1
  840    I $G(PSDO UT)=1 G AS KP
  841    I $G(PSDP OST)=1,$G( PSDREL)=""  W !,"This  fill has  already be en posted. ",$C(7) G  ASKP
  842    I $G(PSDR EL)'="",$G (PSDPOST)' >0 W !,"Th is fill ha s already  been relea sed.",$C(7 )
  843    I $G(PSDR EL)'="",$G (PSDPOST)> 0 W !,"Thi s fill has  already b een posted  & release d, no furt her action  required. ",$C(7) G  ASKP
  844    D DISPLAY  G:PSDOUT  END
  845   I $G(PSDQU IT) K PSDQ UIT G ASKP  ;RTW
  846    K DA,DIR, DIRUT S DI R(0)="YA", DIR("B")=" YES",DIR(" A")="Is th is OK? "
  847    S DIR("?" ,1)="Answe r 'YES' to  log this  RX transac tion in yo ur CS vaul t,",DIR("? ")="answer  'NO' to r eselect a  prescripti on, or '^'  to quit."
  848    D ^DIR K  DIR I Y<1  D MSG G:$D (DIRUT) EN D G:Y<1 AS KP
  849    D ^PSDOPT 1 G ASKP
  850   END K %,%H ,%I,BAL,C, CNT,DA,DAT ,DD,DFN,DI C,DIE,DIK, DINUM,DIR, DIROUT,DIR UT,DLAYGO, DO,DR,JJ,L N,NEW,NODE ,NODE6 D F INAL^PSOLS ET
  851    I $G(PSDR X)'="" L - ^PSRX(PSDR X)
  852    K PATN,PH ARM,PHARMN ,PRF,PSDA, PSDATE,PSD OUT,PSDQUI T,PSDR,PSD RN,PSDRPH, PSDRX,PSDS ,PSDSN,PSD T,PSDUZ,PS OCSUB,QTY, RF,RPDT,RX NUM,X,Y
  853    D KVAR^VA DPT K VA(" PID"),VA(" BID")
  854    Q
  855   CHKEY ;che ck if user  has acces s
  856    I '$D(^XU SEC("PSJ R PHARM",DUZ )) D  S PS DOUT=1
  857    .W !!?12, "** You ha ve no acce ss to rele ase this p rescriptio n."
  858    .W !?15," The PSJ RP HARM secur ity key is  required.  **",!
  859    Q
  860   CLLDIR2 S  CNT=$G(CNT )+1,DIR(0) =$S($G(CNT )=1:"S^1:R efill #"_X 1,1:DIR(0) _CNT_":Ref ill #"_X1) _";"
  861    Q
  862   DISPLAY ;d isp data
  863    W !!,?20, "View Cont rolled Sub stances Rx  # ",RXNUM ,!,?28,RPD T,!,LN,!!
  864    W "Locati on: ",?10, PSDSN,?55
  865    S PSDRN(1 )=$S(NEW:" Original", $G(NEW(1)) :"Refill # "_NEW(1),1 :"Partial  #"_$G(NEW( 2))) W PSD RN(1)
  866    W !,"Drug : ",?10,PS DRN,?55,"Q uantity: " ,QTY
  867    ;
  868    ;DAVE B ( PSD*3*15)  check for  Non-numeri c quantity
  869    I QTY'?.N  W !,"The  Quantity i s not stri ctly numer ic. This w ill cause  the new ba lance to b e",!,"calc ulated inc orrectly." ,!
  870    W !,"Pati ent: ",?10 ,PATN_" (" _VA("BID") _")",?55,P SDRN(1),"  Date: ",?6 5,$E(DAT,4 ,5)_"/"_$E (DAT,6,7)_ "/"_$E(DAT ,2,3),!
  871    S BAL=+$P ($G(^PSD(5 8.8,+PSDS, 1,PSDR,0)) ,"^",4) I  QTY>BAL W  !!,?5,"You r balance  is ",BAL," .",!,?5,"Y ou may not  dispense  lower than  your bala nce.",!! D  MSG S PSD OUT=1 Q
  872    N PSDOUT
  873    D ^PSDNBA L ;RTW NSR 20171101
  874    I PSDOUT= 1 S PSDQUI T=PSDOUT D  MSG Q  ;R TW NSR2017 1101
  875    W !!,?15, "Old Balan ce: ",BAL, ?40,"New B alance: ", BAL-QTY,!!
  876    Q
  877   MSG W $C(7 ),!!,"No a ction take n. This tr ansaction  has not be en recorde d.",!!
  878    Q
  879   VER ;Curre nt Outpati ent Versio n, and Rx  status add ed 6/17/98
  880    K PSDSTA  S PSDHOLDX =$G(X) S P SOVR=$$VER SION^XPDUT L("PSO") S  X=$G(PSDH OLDX) K PS DHOLDX S P SOVR=$S($G (PSOVR)>6: 1,1:0)
  881    I $G(PSDR XIN) S PSD STA=$S(PSO VR:$P($G(^ PSRX(PSDRX IN,"STA")) ,"^"),1:$P ($G(^PSRX( PSDRXIN,0) ),"^",15))
  882    Q
  883   CHKRF ;Dav e B (PSD*3 *30) if it s deleted,  show stat us.
  884    W !,"This  RX has a  status of  '"_$S(PSDS TA=11:"EXP IRED",PSDS TA=12:"DIS CONTINUED" ,PSDSTA=13 :"DELETED" ,PSDSTA=14 :"DISCONTI NUED BY PR OVIDER",PS DSTA=15:"D ISCONTINUE D (EDIT)", 1:"Unknown  Procedure ")_$S(PSDS TA=12:"'." ,1:"', no  action can  be taken. ")
  885    ;< JD*62
  886    I $O(^PSR X(PSDRX,"A ",0))>0 W  !!,"Below  is a list  of actions  taken on  the prescr iption.",! !,"DATE/TI ME",?22,"P ERSON",?45 ,"ACTIVITY ",! F X=1: 1:53 W "="  F X=1:1:( IOM-1) W " ="
  887    S X3=0 F   S X3=$O(^ PSRX(PSDRX ,"A",X3))  Q:X3=""  S  DATA=$G(^ PSRX(PSDRX ,"A",X3,0) ),Y=$P(DAT A,"^",1) X  ^DD("DD")  S DATE=Y, X=$P(DATA, "^",2) D
  888    .I $G(X)' ="" S ACTI VITY=$$EXT ERNAL^DILF D(52.3,.02 ,,X)
  889    .S DELDUZ =$$EXTERNA L^DILFD(52 .3,.03,,$P (DATA,"^", 3)) S DELD UZ=$S($G(D ELDUZ)="": "Unknown ( "_$P(DATA, "^",3)_")" ,1:DELDUZ)
  890    .K DELREA S S DELREA S=$P(DATA, "^",5)
  891    .W !,DATE ,?22,DELDU Z,?45,ACTI VITY I $G( DELREAS)'= "" W !,"Co mment: ",$ G(DELREAS)
  892    I $G(PSDS TA)'=12 S  PSDNEXT=1  Q
  893   ASK12 R !, "Do you wi sh to cont inue? NO / / ",AN:DTI ME S:AN=""  AN="N"
  894    I "YyNn"' [AN W !,"A nswer 'N'o , and you  will promp ted for an other pres cription."  G ASK12
  895    I "nN"[AN  S PSDNEXT =1 Q
  896    K PSDNEXT
  897    Q
  898   CMOPMSG W  !,?10,"Thi s is a CMO P fill and  has been  transmitte d, dispens ed or ",!? 10,"retran smitted.", ! S PSDOUT =1 Q
  899   KLLALL ;Ki ll all
  900   PSDNBAL (N ew)
  901   PSDNBAL ;E PIP/RTW -  Ask CS Rem aining Bal ance ;29 A ug 94
  902    ;;3.0;CON TROLLED SU BSTANCES N ARCOTIC BA LANCE;**84 **;13 Feb  97;Build 8
  903    ; ICR# TY PE DESCRIP TION
  904    ;----- -- ----- ---- ---------- ---------- ---------- --
  905    ;10026 Su pport ^DIR
  906    ;4986 Sup port ^%DTC
  907    ;1140 Sup port ^XMD
  908    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- -
  909    S PSDTRY= 1
  910   ENTER ;
  911    S PSDOUT= 0
  912    S DIR(0)= "N"
  913    S DIR("A" )=" Enter  the remain ing balanc e (^ to qu it)"
  914    S DIR("T" )=DTIME
  915    S DIR("?" ,1)="Enter  The remai ning Balan ce on hand "
  916    S DIR("?" ,2)="The s ystem will  compare a gainst the  database. "
  917    S DIR("?" ,3)="You w ill have 3  tries to  complete b efore a me ssage is s ent"
  918    S DIR("?" ,4)="to th e CS BALAN CE DISCREP ANCY mail  group"
  919    S DIR("?" )=" "
  920    D ^DIR K  DIR S PSDA NS=Y I $D( DIRUT) S P SDOUT=1 G  EXIT
  921    S PSDQDB= (BAL-QTY)
  922    W:PSDANS= PSDQDB !!, "Balance c onfirmed,  Thank you  ",! ;RTW
  923    S PSDQCHO =$S(PSDANS =PSDQDB:"E XIT",1:"PS DATMPT")
  924    D @PSDQCH O
  925    Q
  926   EXIT ;
  927    K PSDTRY, PSDQCHO,PS DANS,PSDQD B,PSDPHN,X MDUZ,XMY,X MSUB,XMZ,P SDWANS,PSD RN
  928    K ^TMP($J ,"MSG")
  929    Q
  930    ;;
  931   PSDATMPT I  PSDTRY=1  D MESS1 S  PSDTRY=PSD TRY+1 G EN TER
  932    I PSDTRY= 2 D MESS2  S PSDTRY=P SDTRY+1 G  ENTER
  933    I PSDTRY= 3 D MESG
  934    Q
  935   MESS1 W !! ,"Sorry th e remainin g balance  you entere d does not  match the  balance", !,"on reco rd in the  CS package .",!!,"Ple ase check  to ensure  you have d ispensed t he right d rug and",! ," dispens ed the cor rect quant ity.",!
  936    Q
  937   MESS2 W !! ,"This wil l be the l ast entry  in the rem aining bal ance check .",!!,"If  the entry  still does  not match  a message  will be s ent to the ",!,"appro priate per son for re view."
  938    W " You m ay proceed  if you ha ve dispens ed the",!, "correct d rug in the  correct q uantity. T hank you." ,!
  939    Q
  940   MESG ;Ask  comment an d send mes sage
  941    S DIR(0)= "F"
  942    S DIR("A" )="Enter a  comment ( ^ to quit) "
  943    S DIR("T" )=DTIME
  944    S DIR("?" ,1)="Enter  comment w ith any co ncerns abo ut the bal ance discr epancy."
  945    S DIR("?" ,2)="You a re limited  to 245 ch aracters."
  946    S DIR("?" )=" "
  947    D ^DIR K  DIR S PSDW ANS=Y I $D (DIRUT) G  EXIT
  948    K XMTEXT
  949    S XMSUB=" Possible C S Balance  Remaining  Discrepanc y"
  950    S XMY(DUZ )="" ;To U ser
  951    S XMY("G. CS BALANCE  DISCREPAN CY")="" ; 
  952    S ^TMP($J ,"MSG","B" ,1)="There  were thre e failed a ttempts to  enter the  current r emaining b alance for  the follo wing drug. "
  953    S ^TMP($J ,"MSG","B" ,2)=" "
  954    S ^TMP($J ,"MSG","B" ,3)=" Drug  : "_PSDRN
  955    S ^TMP($J ,"MSG","B" ,4)=" Rx #  : "_RXNUM
  956    S ^TMP($J ,"MSG","B" ,5)=" Rx Q ty : "_QTY
  957    S ^TMP($J ,"MSG","B" ,6)="Balan ce Entered  : "_PSDAN S
  958    S ^TMP($J ,"MSG","B" ,7)="Balan ce in Vist A : "_PSDQ DB
  959    N Y,DIFRO M
  960    D NOW^%DT C S Y=% X  ^DD("DD")
  961    S ^TMP($J ,"MSG","B" ,8)=" Time  : "_Y
  962    S XMDUZ=. 5
  963    S PSDPHN= $P(^VA(200 ,DUZ,0),"^ ",1)
  964    S ^TMP($J ,"MSG","B" ,9)=" Phar macist : " _PSDPHN
  965    S ^TMP($J ,"MSG","B" ,10)=" Com ment : "_P SDWANS
  966    S ^TMP($J ,"MSG","B" ,11)=" "
  967    S ^TMP($J ,"MSG","B" ,12)="Than k you for  checking o n this pos sible disc repancy."   ;
  968    S XMTEXT= "^TMP($J," "MSG"",""B "","
  969    D ^XMD
  970    W:$D(XMZ)  !!,"Messa ge sent to  the CS BA LANCE DISC REPANCY Ma il Group", !!," You e ntered a r emaining b alance of  ",PSDANS
  971    D EXIT
  972    Q
  973   PSD84P (Ne w)
  974   PSD84P ;EP IP/RTW - P SD CONTROL  SUBSTANCE  WARNING P OST INSTAL L ; 05/074 /18 18:46p m
  975    ;;3.0;CON TROLLED SU BSTANCES ; **84**;13  Feb 97;BUI LD 1
  976    ; ICR# Ty pe Descrip tion
  977    ;----- -- -- ------- ---------- ---------- ----------
  978    ;10111 Su p FM looku p on file  3.8 using  ^DIC API 
  979    ;
  980   MAILGRP ;N eed to che ck for a p re existin g mail gro up called  CS BALANCE  DISCREPAN CY if it e xists do n othing.
  981    N PSDMG,P SDMSG,PSDN IEN,PSDRX
  982    S PSDMG=$ $FIND1^DIC (3.8,"","X ","CS BALA NCE DISCRE PANCY","", "","")
  983    D:'PSDMG
  984    . N PSDMG RP,PSDDESC R,PSDTYPE, PSDORG,MSG ,FDA2,FDA, PSDIEN
  985    . S PSDMG RP="CS BAL ANCE DISCR EPANCY",PS DTYPE="PR" ,PSDORG=". 5"
  986    . S PSDDE SCR(1)="Ph armacy Sup ervisors G roup for r eporting N arcotic Ba lance Disc repancies"
  987    . S FDA(3 .8,"+1,",. 01)=PSDMGR P
  988    . S FDA(3 .8,"+1,",4 )=PSDTYPE
  989    . S FDA(3 .8,"+1,",5 )=PSDORG
  990    . D UPDAT E^DIE(""," FDA","FDAI EN","MSG")
  991    . S PSDNI EN=$O(^XMB (3.8,"B"," CS BALANCE  DISCREPAN CY",0))
  992    . S PSDMS G(1)="Phar macy Super visors Gro up for rep orting Nar cotic Bala nce Discre pancies"
  993    . D WP^DI E(3.8,PSDN IEN_",",3, ,"PSDMSG")
  994    . K FDA,F DAIEN
  995    I $D(MSG)  D  Q
  996    . S PSDRX ="Mail Gro up Creatio n Failed.  The follow ing error  message wa s returned :"
  997    . W !
  998    . D MES^X PDUTL(PSDR X)
  999    S PSDRX=" Mail Group  created s uccessfull y."
  1000    D MES^XPD UTL(PSDRX)
  1001    Q