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

PSIVSET.m

Go to the documentation of this file.
  1. PSIVSET ;BIR/PR-IV PACKAGE ENTRY POINT ;12 DEC 97 / 9:18 AM
  1. ;;5.0;INPATIENT MEDICATIONS;**35,81,91,407**;16 DEC 1997;Build 26
  1. ;
  1. ; Reference to ^PS(59.7 is supported by DBIA# 2181.
  1. ;
  1. ; PSJ*407 - Liberty ITS/RJH - 08/22 - Significant modifications to prevent
  1. ; users from being allowed to update the IV Room file (#59.5)
  1. ; without the PSJI MGR security key
  1. ;
  1. D NOW^%DTC S Y=%
  1. ;W !!,"INPATIENT MEDICATIONS (IV) (Version: ",$P($P($T(PSIVSET+1),";;",2)," ",1,2),")",!
  1. ENOR ;
  1. S (PSIVCT,PSIVSN)=0 D NOW^%DTC F X=0:0 S X=$O(^PS(59.5,X)) Q:'X D
  1. .I $S(+'$G(^PS(59.5,X,"I")):1,+$G(^PS(59.5,X,"I"))>%:1,1:0) S PSIVCT=PSIVCT+1 S PSIVSN=X
  1. I PSIVCT=1 D ENCHK I $D(%) S:%=-1!(%=2) XQUIT="" G:%=2!(%=-1) Q1
  1. ;I PSIVCT=1 S PSIVSN=$O(^PS(59.5,0)) D ENCHK I $D(%) S:%=-1!(%=2) XQUIT="" G:%=2!(%=-1) Q1
  1. MULT ;
  1. ; PSJ*407/RJH - Begin changes
  1. ; I PSIVCT>1 K DIC S DIC="^PS(59.5,",DIC(0)="QEAM",DIC("S")="I $S($P($G(^(""I"")),U)="""":1,1:$P(^(""I""),U)>DT)" D ^DIC K DIC S:Y<0 XQUIT="" Q:Y<0 S PSIVSN=+Y D ENCHK I $D(%) G:%=2 MULT S:%=-1 XQUIT="" G:%=-1 Q1
  1. I PSIVCT>1 D
  1. . I '$D(^TMP("PSJUSER",$J,"FLAG")) D Q
  1. .. K DIC S DIC="^PS(59.5,",DIC(0)="QEAM",DIC("S")="I $S($P($G(^(""I"")),U)="""":1,1:$P(^(""I""),U)>DT)" D ^DIC K DIC
  1. .. S:Y<0 XQUIT="" Q:Y<0
  1. .. S PSIVSN=+Y D ENCHK I $D(%) G:%=2 MULT S:%=-1 XQUIT="" G:%=-1 Q1
  1. .. Q
  1. . S PSIVSN=$G(^TMP("PSJUSER",$J,"FLAG")) D ENCHK I $D(%) G:%=2 MULT S:%=-1 XQUIT="" G:%=-1 Q1
  1. . Q
  1. ;
  1. Q:+$G(DONE)=1 ;P407
  1. ; PSJ*407/RJH - End changes
  1. I 'PSIVCT W !!,"Whoops ... You don't have an IV ROOM defined ... ",!,"You MUST define at least one IV ROOM before you can continue.",! S DIC="^PS(59.5,",DIC(0)="QEAML",DLAYGO=59.5,DIC("A")="Select IV ROOM: " D ^DIC I Y'>0 S XQUIT="" G Q1
  1. I 'PSIVCT S DIE=DIC,(DA,PSIVSN)=+Y,DR="[PSJI SITE PARAMETERS]" K DIC D ^DIE,ENCHK
  1. Q ;
  1. I PSIVSN<1 W !!,"You have not selected a valid IV ROOM" S %=1 D YN^DICN I %=0 G Q
  1. I PSIVSN<1 G:%=1 PSIVSET S XQUIT="" G Q1
  1. S IOP=$P(^PS(59.5,PSIVSN,0),U,2) I IOP]"" S %ZIS="QN" D ^%ZIS I ION]"" W !!,"Current IV LABEL device is: ",ION S PSIVPL=ION
  1. E D ENLD
  1. S IOP=$P(^PS(59.5,PSIVSN,0),U,3) I IOP]"" S %ZIS="QN" D ^%ZIS I ION]"" W !!,"Current IV REPORT device is: ",ION S PSIVPR=ION
  1. E D ENPD
  1. ;D ^%ZISC - check if %ZISC created mismatch in PSIVPL/PSIVPR = ION; don't que later
  1. D ^%ZISC S:PSIVPL="HOME" PSIVPL=ION S:PSIVPR="HOME" PSIVPR=ION
  1. Q1 K IOP,PSIVCT,%ZIS,% Q
  1. ;
  1. ENCHK ;
  1. ; PSJ*407/RJH - Begin changes
  1. N OPT1,OPTS ; PSJ*407
  1. D SETUP ; PSJ*407
  1. S DONE=0 ; PSJ*407
  1. S OPT1=$P($G(XQY0),U,1) ; PSJ*407 - This should be the calling menu option
  1. ;
  1. S PSIV=1 S:'$D(^PS(59.5,PSIVSN,5)) $P(^(5),U)="" I '$D(^PS(59.5,PSIVSN,1)) S PSIV=0 W !!,$C(7),"This IV room is missing parameters."
  1. E S PSIVSITE=^PS(59.5,PSIVSN,1),$P(PSIVSITE,U,20,21)=$G(^PS(59.5,PSIVSN,5)) D
  1. .; F TYP="A","P","H","S","C" I '$D(^PS(59.5,PSIVSN,2,"AC",TYP)) W !!,$C(7),"Manufacturing Time(s) missing for " S X=$$CODES^PSIVUTL(TYP,59.51,.02) W X S PSIV=0 ; PSJ*407
  1. . F TYP="A","P","H","S","C" I '$D(^PS(59.5,PSIVSN,2,"AC",TYP)),'$D(^TMP("PSJUSER",$J,"DSPFLAG")) S PSIV=0 S ^TMP("PSJUSER",$J,"FLAG")=PSIVSN D ; PSJ*407
  1. . Q ; PSJ*407
  1. AGA ;
  1. ; I 'PSIV R !!,"Would you like to edit this IV room" S %=1 D YN^DICN Q:%=2!(%=-1) W:'% !,"Answer Yes or No.",! G:'% AGA S DIE="^PS(59.5,",DR="[PSJI SITE PARAMETERS]",DA=PSIVSN D ^DIE G ENCHK ; PSJ*407
  1. ; I PSIVSN W !!,"You are signed on under the ",$P(^PS(59.5,PSIVSN,0),"^")," IV ROOM" K % ; PSJ*407
  1. I PSIVSN,PSIV D Q ; The IV Room is defined and set up properly
  1. . W !!,"You are signed on under the ",$P(^PS(59.5,PSIVSN,0),"^")," IV ROOM" K %
  1. . K PSIV,TYP,%X,%Y,C,D,D0,D1,DA,DIC,DIE,DR,X,Y,Z
  1. . Q
  1. ;
  1. ; If we're here, then the IV Room is missing Coverages
  1. I OPT1="PSJI SITE PARAMETERS" D SITEMSG Q
  1. ; I '$D(^TMP("PSJUSER",$J,"DSPFLAG")),(OPT1="PSJI MGR"),($G(XQY0)'["PSJI SUPERVISOR") D MSG1(1) Q
  1. I '$D(^TMP("PSJUSER",$J,"SUPFLAG")),(OPT1="PSJI MGR")!(OPT1="PSJI SUPERVISOR") D MSG1(1) Q
  1. I $D(OPTS(OPT1)) D MSG1(0) Q
  1. ; K PSIV,TYP,%X,%Y,C,D,D0,D1,DA,DIC,DIE,DR,X,Y,Z Q ; PSJ*407
  1. Q
  1. ; PSJ*407/RJH - End changes
  1. ;
  1. ENLD ;Get label device.
  1. W ! K IOP S %ZIS="NQ",%ZIS("B")=$S($P(^PS(59.5,PSIVSN,0),U,2)]"":$P(^(0),U,2),1:"HOME"),%ZIS("A")="Enter IV LABEL device: " D ^%ZIS S:POP ION="HOME"
  1. S PSIVPL=ION K IOP,%ZIS Q
  1. ENPD ;Get printer device.
  1. W ! K IOP S %ZIS("B")=$S($P(^PS(59.5,PSIVSN,0),U,3)]"":$P(^(0),U,3),1:"HOME"),%ZIS="NQ",%ZIS("A")="Enter IV REPORT device: " D ^%ZIS S:POP ION="HOME"
  1. S PSIVPR=ION K IOP,%ZIS Q
  1. DEVX W !!,$C(7),"You must select a device."
  1. Q
  1. SITEPARM ; Edit IV Site Parameters.
  1. D ^PSIVXU Q:$D(XQUIT)
  1. N CHK,DIC,DIE,DA,DR,DLAYGO,DIOV,DTOUT,PSGDT,Z
  1. S DIC=59.7,DIC(0)="AEMQ" D ^DIC Q:Y<0
  1. S DIE=DIC,DA=+Y,DR=32 D ^DIE
  1. D ^PSIVXU Q:$D(XQUIT) S (DIC,DLAYGO)=59.5,DIC(0)="AEQMLZ" D ^DIC S:Y>0 DIE=DIC,DA=+Y,DR="[PSJI SITE PARAMETERS]" D:Y>0 ^DIE,ENCHK^PSIVSET,SET^PSIVXU D ENIVKV^PSGSETU
  1. ; ----------------------------------------------------------------------------
  1. ; PSJ*407/RJH - Begin changes
  1. ; Added Quit to SITEPARM tag and new tags below
  1. Q
  1. SITEMSG ;
  1. D MISSING
  1. W !,!,"Please select "_$P(^PS(59.5,PSIVSN,0),U,1)_" IV ROOM to update the Parameters."
  1. W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT
  1. S ^TMP("PSJUSER",$J,"DSPFLAG")=1
  1. K PSIV,TYP,%X,%Y,C,D,D0,D1,DA,DIC,DIE,DR,X,Y,Z
  1. Q
  1. ;
  1. MSG1(FLG) ;
  1. D MISSING
  1. W !,!,"The "_$P(^PS(59.5,PSIVSN,0),U,1)_" IV ROOM can be updated using option 'Site Parameters (IV)'"
  1. W !,"by a holder of the PSJI MGR VistA Security Key. Contact the"
  1. W !,"Pharmacy Informaticist to update the IV Room parameters."
  1. I 'FLG W !!,"You are being returned to the Option Menu." S DONE=1
  1. W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT,DIRUT
  1. I FLG S ^TMP("PSJUSER",$J,"SUPFLAG")=1
  1. K PSIV,TYP,%X,%Y,C,D,D0,D1,DA,DIC,DIE,DR,X,Y,Z
  1. Q
  1. ;
  1. MISSING ; Show the missing coverage time(s)
  1. F TYP="A","P","H","S","C" I '$D(^PS(59.5,PSIVSN,2,"AC",TYP)) D
  1. . W !!,$C(7),"Coverage Time(s) missing for " S X=$$CODES^PSIVUTL(TYP,59.51,.02) W X
  1. . Q
  1. Q
  1. ;
  1. SETUP ; Menu options to check to display missing coverage warnings to the user
  1. ; S OPTS(Menu option from #19)="". Menu option is piece one of XQY0
  1. S OPTS("PSJI RETURN BY BARCODE ID")=""
  1. S OPTS("PSJI LBLMENU")=""
  1. S OPTS("PSJI LBLI")=""
  1. S OPTS("PSJI MAN")=""
  1. S OPTS("PSJI ORDER")=""
  1. S OPTS("PSJI RETURNS")=""
  1. S OPTS("PSJI SUSMENU")=""
  1. S OPTS("PSJI SUSLBDEL")=""
  1. S OPTS("PSJI INDIVIDUAL SUSPENSE")=""
  1. S OPTS("PSJI SUSLBLS")=""
  1. S OPTS("PSJI SUSMAN")=""
  1. S OPTS("PSJI SUSREP")=""
  1. S OPTS("PSJI SUSLIST")=""
  1. S OPTS("PSJU VBW")=""
  1. S OPTS("PSJ ECO")=""
  1. S OPTS("PSJ OE")=""
  1. Q
  1. ; PSJ*407/RJH - End changes