PSSFILED ;BIR/CML3-VARIOUS FILED UPKEEP ;09/15/97
;;1.0;PHARMACY DATA MANAGEMENT;**38,47,172,201**;9/30/97;Build 25
;Reference to ^PSGGAO supported by DBIA #2148
;Reference to ^PSGSET supported by DBIA #2152
;Reference to ^PSGSETU supported by DBIA 2153
;Reference to ^PS(57.7 supported by DBIA 2111
;Reference to ^PS(59.6 supported by DBIA 2110
;Reference to ^PS(57.5 supported by DBIA 2112
;Reference to ^PS(53.2 supported by DBIA 2115
;
;This routine is no longer used, with the exception of the ENMI, ENOMI, OMILE, ENOMIX and
;CHKOMI, CHKVAL, ISOMIDUP, EXEHLP, CHKNSY, DELOMI, ISNSYDUP linetags. Quits were inserted at each sub-routine in Patch PSS*1*38.
DONE ;S X="PSGSETU" X ^%ZOSF("TEST") I D ENKV^PSGSETU K D0,D1,D2,PSGRBS Q
Q
;
GED ; generic edit
;S DA=+Y,DR=".01;1" W ! D ^DIE Q
Q
;
ENAT ; team file
Q
;F S DIC="^PS(57.7,",DIC(0)="QEAMIL",DLAYGO=57.7,DIC("A")="Select WARD: " W ! D ^DIC K DIC,DLAYGO Q:Y'>0 S DA=+Y,DIE="^PS(57.7,",DR="[PSJUMATE]" D ^DIE
G DONE
;
ENAS ; schedules file - no longer used
;F S DIC="^PS(51.1,",DIC(0)="QEAMIL",DIC("W")="W "" "",$P(^(0),""^"",2)",DLAYGO=51.1,DIC("DR")="4////PSJ" W ! D ^DIC K DIC,DLAYGO Q:+Y'>0 S DIE="^PS(51.1,",DR="[PSJUADE]",DA=+Y W ! D ^DIE
Q
;
ENMR ; med route file
Q
N MRNO,MR K DIE,DIC,DR,Y
S PSSOTH=$S($P($G(^PS(59.7,1,40.2)),"^"):1,1:0)
F S DIC="^PS(51.2,",DIC(0)="QEAMIL",DLAYGO=51.2 W ! D
.D ^DIC K DIC,DLAYGO Q:+Y'>0 S MRNO=+Y,MR=$P(Y,U,2),DA=+Y,DIE="^PS(51.2,",DR=".01;1;3;4;S:'$G(PSSOTH) Y=""@1"";4.1;@1"
.D ^DIE D DF
K X,MRNO,MR,Y,DA,DR,PSSOTH,DIE
Q
;
ENWG ; ward group file
Q
;F S DIC="^PS(57.5,",DIC(0)="QEAMIL",DLAYGO=57.5 W ! D ^DIC K DA,DIC,DR Q:+Y'>0 S DA=+Y,DIE="^PS(57.5,",DR="[PSJU WG]" D ^DIE
G DONE
;
CHKNSY(PSSMIFLD) ; -- check Name and Synonym Fields **pss_1_201**
; Called by: Name (#.01)and Synonym (#.5) Input Transforms
; Input -- PSSMIFLD Field -- .01=NAME, .5=SYNONYM
; X Name (#.01) or Synonym (#.5)
; PSSMIACT Action -- for Lookup=LKUP and Edit=EDIT -- set in ENMI line tag
; PSSMIEN Medication Instruction file (#51) IEN -- set in ENMI line tag
; Output -- X is killed if duplicate exists
N PSSMIDA,PSSYNEWF
;
; -- check for missing variable, exit if not defined
I $G(PSSMIFLD)']"" Q
;
; -- convert input to upper case
S X=$$UP^XLFSTR(X)
;
; -- check if field value equals X on edit and exit
I $G(PSSMIACT)="EDIT",$$GETVAL($G(PSSMIFLD),+$G(PSSMIEN))=X Q
;
; -- initialize message variables
K PSSMIMSG
;
; -- check field length and "B" cross-reference, kill X, setup message array to display and exit
IF $L(X)>9!($L(X)<1)!'(X?.ANP)!($D(^PS(51,"B",X))) K X D:$G(PSSMIACT)="LKUP" Q
. S PSSMIMSG=1
. S PSSMIMSG(1)=" Answer must be 1 to 9 characters in length, and must be unique among all"
. S PSSMIMSG(2)=" NAME(S), SYNONYM(S), and OLD MED INSTRUCTION NAME(S)."
. D EN^DDIOL(.PSSMIMSG,"","!") K PSSMIMSG
;
; -- if new synonym set flag
S PSSYNEWF=0
I $G(PSSMIFLD)="SYNONYM",$P($G(^PS(51,+$G(PSSMIEN),0)),"^",3)="" S PSSYNEWF=1
;
; -- check for duplicates on edit, kill X, setup message array to display in executable help and exit
I $G(PSSMIACT)="EDIT",$$ISOMIDUP(X,.PSSMIDA),'$G(PSSYNEWF) K X D Q
. S PSSMIMSG=1
. S PSSMIMSG(1)=" A duplicate exists in the OLD MED INSTRUCTION NAME(S) multiple"
. S PSSMIMSG(2)=" for "_$S($G(PSSMIDA)=+$G(PSSMIEN):"this entry",$G(PSSMIDA)>0:"the entry "_$P($G(^PS(51,PSSMIDA,0)),"^",1)_" ("_PSSMIDA_")",1:"")_"."
;
; -- check for duplicates, kill X, set up message array to display on lookup or executable help and exit
I $$ISOMIDUP(X,.PSSMIDA) K X D Q
. S PSSMIMSG=1
. S PSSMIMSG(1)=" Duplicate exists in Old Med Instruction Name multiple for"
. S PSSMIMSG(2)=" "_$S($G(PSSMIDA)=+$G(PSSMIEN):"this entry.",$G(PSSMIDA)>0:"the entry "_$P($G(^PS(51,PSSMIDA,0)),"^",1)_" ("_PSSMIDA_") in the file.",1:"")_" Please enter a new name."
. I $G(PSSMIACT)="LKUP" D EN^DDIOL(.PSSMIMSG,"","!") K PSSMIMSG
Q
;
GETVAL(PSSMIFLD,PSSMIEN,PSSMIENO) ; -- get Name or Synonym or Old Medication Instruction Name Field Value **pss_1_201**
; Called by: Name (#.01)and Synonym (#.5) Input Transforms
; Input -- PSSMIFLD Field -- .01=NAME, .5=SYNONYM, 33,.01=OMINAME
; PSSMIEN Medication Instruction file (#51) IEN
; PSSMIENO Old Med Instruction Name(s) multiple (#51.33) IEN
; Output -- Name (#.01) or Synonym (#.5) or Old Medication Instruction Name Field (#51.33,.01) Value
N PSSFLDVL
;
; -- check for missing variable, exit if not defined
I $G(PSSMIFLD)']"" Q ""
; -- initialize variables
S PSSFLDVL=""
; -- if Name, get Name (#.01) and exit
I PSSMIFLD="NAME",+$G(PSSMIEN)>0 D Q PSSFLDVL
. S PSSFLDVL=$P($G(^PS(51,PSSMIEN,0)),"^",1)
; -- if Synonym, get Synonym (#.5) and exit
I PSSMIFLD="SYNONYM",+$G(PSSMIEN)>0 D Q PSSFLDVL
. S PSSFLDVL=$P($G(^PS(51,PSSMIEN,0)),"^",3)
; -- if Old Medication Instruction Name, get Old Medication Instruction Name Field (#51.33,.01)and exit
I PSSMIFLD="OMINAME",+$G(PSSMIEN)>0,+$G(PSSMIENO)>0 D Q PSSFLDVL
. S PSSFLDVL=$P($G(^PS(51,PSSMIEN,6,PSSMIENO,0)),"^",1)
Q PSSFLDVL
;
ISOMIDUP(X,PSSMIDA) ; -- Is there a duplicate in the Old Med Instruction Name(s) sub-file (#51.33) **pss_1_201**
; Input -- X Medication Instruction file (#51) Name (#.01) field or Synonym (#.5) field
; Output -- 1=Duplicate Found and 0=Unable to Check or No Duplicate Found
; PSSMIDA Old Med Instruction Name(s) multiple (#51.33) IEN Array
N PSSDUPF,PSSOMINM
; -- check for missing variable, exit if not defined
I $G(X)']"" Q 0
; -- initialize variables
S PSSOMINM="",PSSDUPF=0
; -- loop through "D" cross-reference looking for duplicate
F S PSSOMINM=$O(^PS(51,"D",PSSOMINM)) Q:PSSOMINM=""!($G(PSSDUPF)) D
.I PSSOMINM=X D
. . ; -- if duplicate found set flag
. . S PSSDUPF=1
. . ; -- get IENS for duplicate Old Med Instruction Name
. . S PSSMIDA=+$O(^PS(51,"D",PSSOMINM,0)),PSSMIDA(1)=+$O(^(PSSMIDA,0))
Q +$G(PSSDUPF)
;
EXEHLP ; -- Name, Synonym and Old Med Instruction Name Fields Executable Help **pss_1_201**
; Called by: Name (#.01), Synonym (#.5) and Old Med Instruction Name(s) (#51.33,.01) Executable Help
; Input -- PSSMIMSG Medication Instruction Message Flag and Array -- set in OMICHK and CHKNSY line tags
; Output -- None
I $G(PSSMIMSG) D EN^DDIOL(.PSSMIMSG,"","!") K PSSMIMSG
Q
;
CHKOMI(PSSMIFLD) ; -- check Old Med Instruction Name Field **pss_1_201**
; Called by: Old Med Instruction Name(s) (#51.33,.01) Input Transform
; Input -- PSSMIFLD Field -- 33,.01=OMINAME
; X Old Med Instruction Name(s) multiple (#51.33) Name (#.01) field
; PSSMIACT Action -- for Lookup=LKUP and Edit=EDIT -- set in ENMI line tag
; PSSMIEN Medication Instruction file (#51) IEN -- set in ENMI line tag
; PSSMIENO Old Med Instruction Name(s) multiple (#51.33) IEN -- set in ENOMI line tag
; Output -- X is killed if duplicate exists
N PSSMIDA,PSSMI0
;
; -- check for missing variable, exit if not defined
I $G(PSSMIFLD)']"" Q
;
; -- convert input to upper case
S X=$$UP^XLFSTR(X)
;
; -- check if user requested to delete Old Med Instruction subfile entry, delete and exit
I $G(PSSMIACT)="LKUP",X="@",+$G(PSSMIEN)>0 D K X Q
. N PSSOMIDF
. S PSSOMIDF=$$OMILE(PSSMIEN,.PSSMIENO)
. I +$G(PSSMIEN)>0,+$G(PSSMIENO)>0 D
. . D DELOMI(PSSMIEN,PSSMIENO)
. . ; -- re-set DIC("A") and PSSMIENO if Old Med Instruction subfile entry is deleted on lookup
. . S DIC("A")="Select OLD MED INSTRUCTION NAME(S): "_$$OMILE(PSSDA)
. ELSE D
. . D EN^DDIOL("??","","?2")
;
; -- check if field value equals X on edit and exit
I $G(PSSMIACT)="EDIT",$$GETVAL($G(PSSMIFLD),+$G(PSSMIEN),+$G(PSSMIENO))=X Q
;
; -- initialize message variables
K PSSMIMSG
;
; -- check field length, kill X, setup message array to display and exit
IF $L(X)>9!($L(X)<1)!'(X?.ANP) K X D:$G(PSSMIACT)="LKUP" Q
. S PSSMIMSG=1
. S PSSMIMSG(1)=" Answer must be 1 to 9 characters in length, and must be unique among all"
. S PSSMIMSG(2)=" NAME(S), SYNONYM(S), and OLD MED INSTRUCTION NAME(S)."
. D EN^DDIOL(.PSSMIMSG,"","!") K PSSMIMSG
;
; -- check for duplicate Old Med Instruction, kill X, set up message array to display on lookup or executable help and exit
I $$ISOMIDUP(X,.PSSMIDA) K X D Q
. S PSSMIMSG=1
. S PSSMIMSG(1)=" Duplicate exists in Old Med Instruction Name multiple for"
. S PSSMIMSG(2)=" "_$S($G(PSSMIDA)=+$G(PSSMIEN):"this entry.",$G(PSSMIDA)>0:"the entry "_$P($G(^PS(51,PSSMIDA,0)),"^",1)_" ("_PSSMIDA_") in the file.",1:"")_$S($G(PSSMIACT)="LKUP":" Please enter a new name.",1:"")
. I $G(PSSMIACT)="LKUP" D EN^DDIOL(.PSSMIMSG,"","!") K PSSMIMSG
;
; -- check for duplicate Name or Synonym, set up message array to display on lookup or executable help, kill X and exit
I $$ISNSYDUP(X,.PSSMIDA),$G(PSSMIDA)>0 D K X Q
. ; -- determine which field is the duplicate Name or Synonym
. S PSSMI0=$G(^PS(51,PSSMIDA,0)) S PSSMIFLD=$S($P(PSSMI0,"^",1)=X:"NAME",$P(PSSMI0,"^",3)=X:"SYNONYM",1:"UNKNOWN")
. S PSSMIMSG=1
. S PSSMIMSG(1)=" An OLD MED INSTRUCTION NAME(S) entry cannot be the same as an"
. S PSSMIMSG(2)=" existing "_$G(PSSMIFLD)_" field."
. I $G(PSSMIACT)="LKUP" D EN^DDIOL(.PSSMIMSG,"","!") K PSSMIMSG
Q
;
DELOMI(PSSMIEN,PSSMIENO) ; -- delete entry from OLD MED INSTRUCTION NAME(S) multiple #51.33 **pss_1_201**
; Input -- PSSMIEN Medication Instruction file (#51) IEN
; PSSMIENO Old Med Instruction Name(s) multiple (#51.33) IEN
; Output -- None
N DIR,X,Y
; -- check for missing variables, exit if not defined
I +$G(PSSMIEN)'>0!(+$G(PSSMIENO)'>0) Q
; -- ask user if sure want to delete
S DIR("A")=" SURE YOU WANT TO DELETE"
S DIR(0)="Y"
D ^DIR
I '$G(Y) D Q
. D EN^DDIOL(" (No) <NOTHING DELETED>","","?2")
ELSE D
. D EN^DDIOL(" (Yes)","","?2")
. N DA,DIK,X
. ; -- delete entry
. S DA=PSSMIENO,DA(1)=PSSMIEN
. S DIK="^PS(51,"_DA(1)_",""6"","
. D ^DIK
Q
;
ISNSYDUP(X,PSSMIDA) ; -- Is there a duplicate in the Name or Synonym field of the Medication Instruction file (#51) **pss_1_201**
; Input -- X Old Med Instruction Name(s) multiple (#51.33) Name (#.01) field
; Output -- 1=Duplicate Found and 0=Unable to Check or No Duplicate Found
; PSSMIDA Medication Instruction file (#51) IEN
N PSSDUPF,PSSNM
; -- check for missing variable, exit if not defined
I $G(X)']"" Q 0
; -- initialize variables
S PSSNM="",PSSDUPF=0
; -- loop throung "B" cross-reference looking for duplicate
F S PSSNM=$O(^PS(51,"B",PSSNM)) Q:PSSNM=""!($G(PSSDUPF)) D
.I PSSNM=X D
. . ; -- if duplicate found set flag
. . S PSSDUPF=1
. . ; -- get IEN for duplicate Medication Instruction Name
. . S PSSMIDA=+$O(^PS(51,"B",PSSNM,0))
Q +$G(PSSDUPF)
;
ENMI ; medication instruction file **enhancements made in pss_1_201**
N DD,DIC,DIE,DLAYGO,DA,DO,DR,PSSFINF,PSSMIEN,PSSMINME,PSSMIACT,PSSOTH,Y
S PSSOTH=$S($P($G(^PS(59.7,1,40.2)),"^"):1,1:0)
S DIC="^PS(51,",DIC(0)="EAMIL",DLAYGO=51,PSSMIACT="LKUP" W ! D ^DIC K DIC G ENMIQ:+Y'>0
S PSSMIEN=+Y,PSSMINME=$P(Y,U,2),PSSFINF=0
S DIE="^PS(51,",DA=PSSMIEN,DR=".01;.5;1;S:'$G(PSSOTH) Y=""@1"";1.1;@1;9;30;32;32.1;31;S PSSFINF=1",PSSMIACT="EDIT" D ^DIE I +$G(DA)>0,$G(PSSFINF) D ENOMI(PSSMINME,PSSMIEN)
; -- re-prompt until user does not select an entry
G ENMI
ENMIQ Q
;
ENOMI(PSSPMI,PSSDA) ; prompt to display interaction for OLD MED INSTRUCTION NAME(S) multiple **enhancements made in pss_1_201**
Q:$G(PSSPMI)']""!($G(PSSDA)'>0)
;
SELOMI ; -- select Old Med Instruction Name
NEW DD,DIC,DIE,DLAYGO,DA,DO,DR,PSSADDF,PSSMIACT,PSSMIENO,Y
SET DA(1)=PSSDA,DIC="^PS(51,"_DA(1)_",6,",PSSMIACT="LKUP",DIC(0)="EAMIL",DIC("A")="Select OLD MED INSTRUCTION NAME(S): "_$$OMILE(PSSDA) D ^DIC K DIC G ENOMIQ:+Y'>0
S PSSMIENO=+Y
SET DA(1)=PSSDA,DIE="^PS(51,"_DA(1)_",6,",DA=PSSMIENO,DR=".01",PSSMIACT="EDIT" D ^DIE
; -- re-prompt until user does not select an entry
G SELOMI
ENOMIQ Q
;
OMILE(PSSDA,PSSLR) ;
NEW PSSLE SET PSSLE=""
IF $G(^PS(51,$G(PSSDA),6,0))'="" SET PSSLR=999999 FOR SET PSSLR=$O(^PS(51,$G(PSSDA),6,PSSLR),-1) S:$G(^PS(51,$G(PSSDA),6,PSSLR,0))'="" PSSLE=$G(^PS(51,$G(PSSDA),6,PSSLR,0))_"// " Q:PSSLR'=""
Q $G(PSSLE)
;
ENOMIX(PSSPMI,PSSDA) ; used by the 'AF' xref for adding an edited NAME (#.01) field's old value in the MEDICATION INSTRUCTION (#51) file to the OLD MED INSTRUCTION NAME(S) multiple **pss_1_201**
Q:$G(PSSPMI)']""!($G(PSSDA)'>0)
;
NEW PSSMCHK,PSSRCHK,PSSMFL1,PSSMFL2,PSSMFL3
SET (PSSRCHK,PSSMCHK,PSSMFL1,PSSMFL2,PSSMFL3)=0
;
IF $P(^PS(51,$G(PSSDA),0),U,1)=PSSPMI SET PSSMFL1=1
FOR SET PSSMCHK=$O(^PS(51,$G(PSSDA),6,PSSMCHK)) Q:'+PSSMCHK!($G(PSSMFL2)) D
.IF ^PS(51,$G(PSSDA),6,PSSMCHK,0)=PSSPMI SET PSSMFL2=1
FOR SET PSSRCHK=$O(^PS(51,"D",PSSRCHK)) Q:PSSRCHK']""!($G(PSSMFL3)) D
.IF PSSRCHK=PSSPMI SET PSSMFL3=1
IF '$G(PSSMFL1),'$G(PSSMFL2),'$G(PSSMFL3),$G(PSSDA) KILL DO SET X=PSSPMI,DA(1)=$G(PSSDA),DIC=DIC_DA(1)_",6,",DIC(0)="L" DO FILE^DICN SET DIC="^PS(51,",DA=PSSDA
Q
;
ENDRG ; standard drug fields
Q
D NOW^%DTC S PSGDT=% F S DIC="^PSDRUG(",DIC(0)="AEIMOQ",DIC("A")="Select DISPENSE DRUG: " W ! D ^DIC K DIC Q:+Y'>0 D DE
K PSIUA,PSIUDA,PSIUX G DONE
;
DE ;
Q
I $D(^PSDRUG(+Y,"I")),^("I"),^("I")<PSGDT W $C(7),$C(7),!!?3,"*** WARNING, THIS DRUG IS INACTIVE. ***",!
;W ! S DIE="^PSDRUG(",(DA,PSIUDA)=+Y,DR="[PSJ FILED]"
S PSIUX="U^UNIT DOSE PHARMACY^1" D ^PSSGIU,^DIE:PSIUA'["^" K DA,DIE,DR Q
;
ENOSE ; order set enter/edit
Q
;K DIC F S DLAYGO=53.2,DIC="^PS(53.2,",DIC(0)="QEAML",DIC("A")="Select ORDER SET: " W ! D ^DIC K DIC Q:Y'>0 S DA=+Y S DIE="^PS(53.2,",DR="[PSJUOSE]" D ^DIE K D0,D1,DA,DIE,DR,PSGNEDFD,PSGS0XT,PSGS0Y
G DONE
;
RBCHK ; used to validate room-bed
Q
;F Z0=0:0 S Z0=$O(^PS(57.7,DA(2),1,Z0)) Q:'Z0 I Z0'=DA(1),$D(^(Z0,1,"B",X)) W !?19,X," is already under ",$S('$D(^PS(57.7,DA(2),1,Z0,0)):"another team ("_Z0_")!",$P(^(0),"^")]"":$P(^(0),"^")_"!",1:"another team ("_Z0_")!") Q
I 'Z0,$D(^DIC(42,DA(2),2,+$O(^DIC(42,DA(2),2,"B",$P(X,"-"),0)),1,"B",$P(X,"-",2))) K Z0 Q
K X,Z0 Q
;
RBQ ; show room-beds for a ward
Q
W !,"ANSWER WITH A ROOM-BED FROM THIS WARD ",$S('$D(^DIC(42,DA(1),0)):"",$P(^(0),"^")]"":" ("_$P(^(0),"^")_")",1:"") Q:'$D(^(0)) W !,"DO YOU WANT THE ENTIRE ROOM-BED LIST" S %=0 D YN^DICN Q:%'=1
W ! S (Z0,Z3)=0 F Z1=0:0 S Z1=$O(^DIC(42,DA(1),2,Z1)) Q:'Z1 I $D(^(Z1,0)) S Z4=$P(^(0),"^") I Z4]"" F Z2=0:0 S Z2=$O(^DIC(42,DA(1),2,Z1,1,Z2)) Q:'Z2 I $D(^(Z2,0)),$P(^(0),"^")]"" S Z0=Z0+1 D:'(Z0#11) RBNP Q:Z3["^" W ?1,Z4,"-",$P(^(0),"^"),!
K Z0,Z1,Z2,Z3,Z4 Q
;
RBNP ;W """^"" TO STOP: " R Z3:DTIME W:'$T $C(7) S:'$T Z3="^" W *13," ",*13 Q
Q
;
ENPPD ; edit pharmacy patient data
Q
; W !!?3,"...This option is still under development...",! Q
;D ENCV^PSGSETU I $D(XQUIT) Q
;S PSGRETF=1 F D ENDPT^PSGP Q:PSGP'>0 D ENHEAD^PSGO S DA=PSGP,DR="[PSJUPDE]",DIE="^PS(55," W ! D ^DIE
;K PSGRETF G DONE
;
ENCPDD ; edit patient's default stop date (wall)
Q
;S X="PSGSETU" X ^%ZOSF("TEST") I D ENCV^PSGSETU I $D(XQUIT) Q
;S X="PSGGAO" X ^%ZOSF("TEST") I F D ENAO^PSGGAO Q:PSGP'>0 D
;.S WDN=$P($G(^DPT(PSGP,.1)),"^") W:WDN="" !!?2,"The patient is not currently on a ward."
;.I WDN]"" S WD=$O(^DIC(42,"B",WDN,0)),WD=$O(^PS(59.6,"B",+WD,0)) I $S('WD:1,1:'$P($G(^PS(59.6,WD,0)),"^",4)) S X="PLEASE NOTE: The 'SAME STOP DATE' parameter for the ward ("_WDN_") is not turned on. Any date entered here will be ignored "
;.I S X=X_"until the parameter is turned on for this ward." W $C(7),!!?2 F Y=1:1:$L(X," ") S X(1)=$P(X," ",Y) W:$L(X(1))+$X>78 ! W X(1)," "
;.S DA=PSGP,DR="62.01T",DIE="^PS(55," W !! D ^DIE
;K WD,WDN G DONE
;
ENSYS ; edit system file
Q
S DIE="^PS(59.7,",DA=1,DR="21;26;26.2" W ! D ^DIE K DIE,DA,DR Q
;
ENPLSP ; edit pick list site parameters
Q
;K DIC F Q=0:1 S DIC="^PS(59.4,",DIC(0)="QEAM" S:'Q DIC("B")=PSJSYSW W ! D ^DIC K DIC Q:Y'>0 S DA=+Y,DIE="^PS(59.4,",DR="[PSJUPLSP]" D ^DIE
;G DONE
;
ENCS ; change current site & parameters
Q
I $D(PSJSYSW0)#2 W !!,"Current site: ",$P(PSJSYSW0,"^")
;S PSGCSF=1 S X="PSGSET" X ^%ZOSF("TEST") I D ^PSGSET,ENKV^PSGSETU W:$D(XQUIT) !!?5,"(The Inpatient site you are currently working under has not changed.)" K PSGCSF,PSGORSET,XQUIT Q
;
DF ; Add/edit Med route, instruction... to the Dosage form file.
Q
S DIR("A")="Would you like to update the Dosage Form file"
S DIR("?")="If your answer is Yes, you will be able to Add/edit the Med routes, Instructions, Verb, Noun and Preposition that associate with this Dosage form."
S DIR(0)="Y",DIR("B")="Y" D ^DIR Q:Y'=1
NEW Y,DFNO K DIE,DIC,DA,DR
F S DIC="^PS(50.606,",DIC(0)="QEAMI" D ^DIC Q:+Y'>0 S DFNO=+Y D
. I $G(MR)]"",'$D(^PS(50.606,DFNO,"MR","B",MRNO)) S DIE="^PS(50.606,",DR="1",DA=DFNO D ^DIE
. K DIE,DIC,DR,MR S DIE="^PS(50.606,",DR="1;2;3;5;6",DA=DFNO D ^DIE
Q
ENII ; infusion instruction file
F S DIC="^PS(53.47,",DIC(0)="QEAMIL",DLAYGO=53.47 W ! D ^DIC K DIC Q:+Y'>0 D
.Q:($P(Y,"^",3))
.S DIE="^PS(53.47,",DA=+Y,DR=".01;1" D ^DIE
K DIC,DIE,DLAYGO,DA,DR,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSFILED 17341 printed Sep 23, 2025@20:07:16 Page 2
PSSFILED ;BIR/CML3-VARIOUS FILED UPKEEP ;09/15/97
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**38,47,172,201**;9/30/97;Build 25
+2 ;Reference to ^PSGGAO supported by DBIA #2148
+3 ;Reference to ^PSGSET supported by DBIA #2152
+4 ;Reference to ^PSGSETU supported by DBIA 2153
+5 ;Reference to ^PS(57.7 supported by DBIA 2111
+6 ;Reference to ^PS(59.6 supported by DBIA 2110
+7 ;Reference to ^PS(57.5 supported by DBIA 2112
+8 ;Reference to ^PS(53.2 supported by DBIA 2115
+9 ;
+10 ;This routine is no longer used, with the exception of the ENMI, ENOMI, OMILE, ENOMIX and
+11 ;CHKOMI, CHKVAL, ISOMIDUP, EXEHLP, CHKNSY, DELOMI, ISNSYDUP linetags. Quits were inserted at each sub-routine in Patch PSS*1*38.
DONE ;S X="PSGSETU" X ^%ZOSF("TEST") I D ENKV^PSGSETU K D0,D1,D2,PSGRBS Q
+1 QUIT
+2 ;
GED ; generic edit
+1 ;S DA=+Y,DR=".01;1" W ! D ^DIE Q
+2 QUIT
+3 ;
ENAT ; team file
+1 QUIT
+2 ;F S DIC="^PS(57.7,",DIC(0)="QEAMIL",DLAYGO=57.7,DIC("A")="Select WARD: " W ! D ^DIC K DIC,DLAYGO Q:Y'>0 S DA=+Y,DIE="^PS(57.7,",DR="[PSJUMATE]" D ^DIE
+3 GOTO DONE
+4 ;
ENAS ; schedules file - no longer used
+1 ;F S DIC="^PS(51.1,",DIC(0)="QEAMIL",DIC("W")="W "" "",$P(^(0),""^"",2)",DLAYGO=51.1,DIC("DR")="4////PSJ" W ! D ^DIC K DIC,DLAYGO Q:+Y'>0 S DIE="^PS(51.1,",DR="[PSJUADE]",DA=+Y W ! D ^DIE
+2 QUIT
+3 ;
ENMR ; med route file
+1 QUIT
+2 NEW MRNO,MR
KILL DIE,DIC,DR,Y
+3 SET PSSOTH=$SELECT($PIECE($GET(^PS(59.7,1,40.2)),"^"):1,1:0)
+4 FOR
SET DIC="^PS(51.2,"
SET DIC(0)="QEAMIL"
SET DLAYGO=51.2
WRITE !
Begin DoDot:1
+5 DO ^DIC
KILL DIC,DLAYGO
if +Y'>0
QUIT
SET MRNO=+Y
SET MR=$PIECE(Y,U,2)
SET DA=+Y
SET DIE="^PS(51.2,"
SET DR=".01;1;3;4;S:'$G(PSSOTH) Y=""@1"";4.1;@1"
+6 DO ^DIE
DO DF
End DoDot:1
+7 KILL X,MRNO,MR,Y,DA,DR,PSSOTH,DIE
+8 QUIT
+9 ;
ENWG ; ward group file
+1 QUIT
+2 ;F S DIC="^PS(57.5,",DIC(0)="QEAMIL",DLAYGO=57.5 W ! D ^DIC K DA,DIC,DR Q:+Y'>0 S DA=+Y,DIE="^PS(57.5,",DR="[PSJU WG]" D ^DIE
+3 GOTO DONE
+4 ;
CHKNSY(PSSMIFLD) ; -- check Name and Synonym Fields **pss_1_201**
+1 ; Called by: Name (#.01)and Synonym (#.5) Input Transforms
+2 ; Input -- PSSMIFLD Field -- .01=NAME, .5=SYNONYM
+3 ; X Name (#.01) or Synonym (#.5)
+4 ; PSSMIACT Action -- for Lookup=LKUP and Edit=EDIT -- set in ENMI line tag
+5 ; PSSMIEN Medication Instruction file (#51) IEN -- set in ENMI line tag
+6 ; Output -- X is killed if duplicate exists
+7 NEW PSSMIDA,PSSYNEWF
+8 ;
+9 ; -- check for missing variable, exit if not defined
+10 IF $GET(PSSMIFLD)']""
QUIT
+11 ;
+12 ; -- convert input to upper case
+13 SET X=$$UP^XLFSTR(X)
+14 ;
+15 ; -- check if field value equals X on edit and exit
+16 IF $GET(PSSMIACT)="EDIT"
IF $$GETVAL($GET(PSSMIFLD),+$GET(PSSMIEN))=X
QUIT
+17 ;
+18 ; -- initialize message variables
+19 KILL PSSMIMSG
+20 ;
+21 ; -- check field length and "B" cross-reference, kill X, setup message array to display and exit
+22 IF $LENGTH(X)>9!($LENGTH(X)<1)!'(X?.ANP)!($DATA(^PS(51,"B",X)))
KILL X
if $GET(PSSMIACT)="LKUP"
Begin DoDot:1
+23 SET PSSMIMSG=1
+24 SET PSSMIMSG(1)=" Answer must be 1 to 9 characters in length, and must be unique among all"
+25 SET PSSMIMSG(2)=" NAME(S), SYNONYM(S), and OLD MED INSTRUCTION NAME(S)."
+26 DO EN^DDIOL(.PSSMIMSG,"","!")
KILL PSSMIMSG
End DoDot:1
QUIT
+27 ;
+28 ; -- if new synonym set flag
+29 SET PSSYNEWF=0
+30 IF $GET(PSSMIFLD)="SYNONYM"
IF $PIECE($GET(^PS(51,+$GET(PSSMIEN),0)),"^",3)=""
SET PSSYNEWF=1
+31 ;
+32 ; -- check for duplicates on edit, kill X, setup message array to display in executable help and exit
+33 IF $GET(PSSMIACT)="EDIT"
IF $$ISOMIDUP(X,.PSSMIDA)
IF '$GET(PSSYNEWF)
KILL X
Begin DoDot:1
+34 SET PSSMIMSG=1
+35 SET PSSMIMSG(1)=" A duplicate exists in the OLD MED INSTRUCTION NAME(S) multiple"
+36 SET PSSMIMSG(2)=" for "_$SELECT($GET(PSSMIDA)=+$GET(PSSMIEN):"this entry",$GET(PSSMIDA)>0:"the entry "_$PIECE($GET(^PS(51,PSSMIDA,0)),"^",1)_" ("_PSSMIDA_")",1:"")_"."
End DoDot:1
QUIT
+37 ;
+38 ; -- check for duplicates, kill X, set up message array to display on lookup or executable help and exit
+39 IF $$ISOMIDUP(X,.PSSMIDA)
KILL X
Begin DoDot:1
+40 SET PSSMIMSG=1
+41 SET PSSMIMSG(1)=" Duplicate exists in Old Med Instruction Name multiple for"
+42 SET PSSMIMSG(2)=" "_$SELECT($GET(PSSMIDA)=+$GET(PSSMIEN):"this entry.",$GET(PSSMIDA)>0:"the entry "_$PIECE($GET(^PS(51,PSSMIDA,0)),"^",1)_" ("_PSSMIDA_") in the file.",1:"")_" Please enter a new name."
+43 IF $GET(PSSMIACT)="LKUP"
DO EN^DDIOL(.PSSMIMSG,"","!")
KILL PSSMIMSG
End DoDot:1
QUIT
+44 QUIT
+45 ;
GETVAL(PSSMIFLD,PSSMIEN,PSSMIENO) ; -- get Name or Synonym or Old Medication Instruction Name Field Value **pss_1_201**
+1 ; Called by: Name (#.01)and Synonym (#.5) Input Transforms
+2 ; Input -- PSSMIFLD Field -- .01=NAME, .5=SYNONYM, 33,.01=OMINAME
+3 ; PSSMIEN Medication Instruction file (#51) IEN
+4 ; PSSMIENO Old Med Instruction Name(s) multiple (#51.33) IEN
+5 ; Output -- Name (#.01) or Synonym (#.5) or Old Medication Instruction Name Field (#51.33,.01) Value
+6 NEW PSSFLDVL
+7 ;
+8 ; -- check for missing variable, exit if not defined
+9 IF $GET(PSSMIFLD)']""
QUIT ""
+10 ; -- initialize variables
+11 SET PSSFLDVL=""
+12 ; -- if Name, get Name (#.01) and exit
+13 IF PSSMIFLD="NAME"
IF +$GET(PSSMIEN)>0
Begin DoDot:1
+14 SET PSSFLDVL=$PIECE($GET(^PS(51,PSSMIEN,0)),"^",1)
End DoDot:1
QUIT PSSFLDVL
+15 ; -- if Synonym, get Synonym (#.5) and exit
+16 IF PSSMIFLD="SYNONYM"
IF +$GET(PSSMIEN)>0
Begin DoDot:1
+17 SET PSSFLDVL=$PIECE($GET(^PS(51,PSSMIEN,0)),"^",3)
End DoDot:1
QUIT PSSFLDVL
+18 ; -- if Old Medication Instruction Name, get Old Medication Instruction Name Field (#51.33,.01)and exit
+19 IF PSSMIFLD="OMINAME"
IF +$GET(PSSMIEN)>0
IF +$GET(PSSMIENO)>0
Begin DoDot:1
+20 SET PSSFLDVL=$PIECE($GET(^PS(51,PSSMIEN,6,PSSMIENO,0)),"^",1)
End DoDot:1
QUIT PSSFLDVL
+21 QUIT PSSFLDVL
+22 ;
ISOMIDUP(X,PSSMIDA) ; -- Is there a duplicate in the Old Med Instruction Name(s) sub-file (#51.33) **pss_1_201**
+1 ; Input -- X Medication Instruction file (#51) Name (#.01) field or Synonym (#.5) field
+2 ; Output -- 1=Duplicate Found and 0=Unable to Check or No Duplicate Found
+3 ; PSSMIDA Old Med Instruction Name(s) multiple (#51.33) IEN Array
+4 NEW PSSDUPF,PSSOMINM
+5 ; -- check for missing variable, exit if not defined
+6 IF $GET(X)']""
QUIT 0
+7 ; -- initialize variables
+8 SET PSSOMINM=""
SET PSSDUPF=0
+9 ; -- loop through "D" cross-reference looking for duplicate
+10 FOR
SET PSSOMINM=$ORDER(^PS(51,"D",PSSOMINM))
if PSSOMINM=""!($GET(PSSDUPF))
QUIT
Begin DoDot:1
+11 IF PSSOMINM=X
Begin DoDot:2
+12 ; -- if duplicate found set flag
+13 SET PSSDUPF=1
+14 ; -- get IENS for duplicate Old Med Instruction Name
+15 SET PSSMIDA=+$ORDER(^PS(51,"D",PSSOMINM,0))
SET PSSMIDA(1)=+$ORDER(^(PSSMIDA,0))
End DoDot:2
End DoDot:1
+16 QUIT +$GET(PSSDUPF)
+17 ;
EXEHLP ; -- Name, Synonym and Old Med Instruction Name Fields Executable Help **pss_1_201**
+1 ; Called by: Name (#.01), Synonym (#.5) and Old Med Instruction Name(s) (#51.33,.01) Executable Help
+2 ; Input -- PSSMIMSG Medication Instruction Message Flag and Array -- set in OMICHK and CHKNSY line tags
+3 ; Output -- None
+4 IF $GET(PSSMIMSG)
DO EN^DDIOL(.PSSMIMSG,"","!")
KILL PSSMIMSG
+5 QUIT
+6 ;
CHKOMI(PSSMIFLD) ; -- check Old Med Instruction Name Field **pss_1_201**
+1 ; Called by: Old Med Instruction Name(s) (#51.33,.01) Input Transform
+2 ; Input -- PSSMIFLD Field -- 33,.01=OMINAME
+3 ; X Old Med Instruction Name(s) multiple (#51.33) Name (#.01) field
+4 ; PSSMIACT Action -- for Lookup=LKUP and Edit=EDIT -- set in ENMI line tag
+5 ; PSSMIEN Medication Instruction file (#51) IEN -- set in ENMI line tag
+6 ; PSSMIENO Old Med Instruction Name(s) multiple (#51.33) IEN -- set in ENOMI line tag
+7 ; Output -- X is killed if duplicate exists
+8 NEW PSSMIDA,PSSMI0
+9 ;
+10 ; -- check for missing variable, exit if not defined
+11 IF $GET(PSSMIFLD)']""
QUIT
+12 ;
+13 ; -- convert input to upper case
+14 SET X=$$UP^XLFSTR(X)
+15 ;
+16 ; -- check if user requested to delete Old Med Instruction subfile entry, delete and exit
+17 IF $GET(PSSMIACT)="LKUP"
IF X="@"
IF +$GET(PSSMIEN)>0
Begin DoDot:1
+18 NEW PSSOMIDF
+19 SET PSSOMIDF=$$OMILE(PSSMIEN,.PSSMIENO)
+20 IF +$GET(PSSMIEN)>0
IF +$GET(PSSMIENO)>0
Begin DoDot:2
+21 DO DELOMI(PSSMIEN,PSSMIENO)
+22 ; -- re-set DIC("A") and PSSMIENO if Old Med Instruction subfile entry is deleted on lookup
+23 SET DIC("A")="Select OLD MED INSTRUCTION NAME(S): "_$$OMILE(PSSDA)
End DoDot:2
+24 IF '$TEST
Begin DoDot:2
+25 DO EN^DDIOL("??","","?2")
End DoDot:2
End DoDot:1
KILL X
QUIT
+26 ;
+27 ; -- check if field value equals X on edit and exit
+28 IF $GET(PSSMIACT)="EDIT"
IF $$GETVAL($GET(PSSMIFLD),+$GET(PSSMIEN),+$GET(PSSMIENO))=X
QUIT
+29 ;
+30 ; -- initialize message variables
+31 KILL PSSMIMSG
+32 ;
+33 ; -- check field length, kill X, setup message array to display and exit
+34 IF $LENGTH(X)>9!($LENGTH(X)<1)!'(X?.ANP)
KILL X
if $GET(PSSMIACT)="LKUP"
Begin DoDot:1
+35 SET PSSMIMSG=1
+36 SET PSSMIMSG(1)=" Answer must be 1 to 9 characters in length, and must be unique among all"
+37 SET PSSMIMSG(2)=" NAME(S), SYNONYM(S), and OLD MED INSTRUCTION NAME(S)."
+38 DO EN^DDIOL(.PSSMIMSG,"","!")
KILL PSSMIMSG
End DoDot:1
QUIT
+39 ;
+40 ; -- check for duplicate Old Med Instruction, kill X, set up message array to display on lookup or executable help and exit
+41 IF $$ISOMIDUP(X,.PSSMIDA)
KILL X
Begin DoDot:1
+42 SET PSSMIMSG=1
+43 SET PSSMIMSG(1)=" Duplicate exists in Old Med Instruction Name multiple for"
+44 SET PSSMIMSG(2)=" "_$SELECT($GET(PSSMIDA)=+$GET(PSSMIEN):"this entry.",$GET(PSSMIDA)>0:"the entry "_$PIECE($GET(^PS(51,PSSMIDA,0)),"^",1)_" ("_PSSMIDA_") in the file.",1:"")_$SELECT($GET(PSSMIACT)="LKUP":" Please enter a new name.",
1:"")
+45 IF $GET(PSSMIACT)="LKUP"
DO EN^DDIOL(.PSSMIMSG,"","!")
KILL PSSMIMSG
End DoDot:1
QUIT
+46 ;
+47 ; -- check for duplicate Name or Synonym, set up message array to display on lookup or executable help, kill X and exit
+48 IF $$ISNSYDUP(X,.PSSMIDA)
IF $GET(PSSMIDA)>0
Begin DoDot:1
+49 ; -- determine which field is the duplicate Name or Synonym
+50 SET PSSMI0=$GET(^PS(51,PSSMIDA,0))
SET PSSMIFLD=$SELECT($PIECE(PSSMI0,"^",1)=X:"NAME",$PIECE(PSSMI0,"^",3)=X:"SYNONYM",1:"UNKNOWN")
+51 SET PSSMIMSG=1
+52 SET PSSMIMSG(1)=" An OLD MED INSTRUCTION NAME(S) entry cannot be the same as an"
+53 SET PSSMIMSG(2)=" existing "_$GET(PSSMIFLD)_" field."
+54 IF $GET(PSSMIACT)="LKUP"
DO EN^DDIOL(.PSSMIMSG,"","!")
KILL PSSMIMSG
End DoDot:1
KILL X
QUIT
+55 QUIT
+56 ;
DELOMI(PSSMIEN,PSSMIENO) ; -- delete entry from OLD MED INSTRUCTION NAME(S) multiple #51.33 **pss_1_201**
+1 ; Input -- PSSMIEN Medication Instruction file (#51) IEN
+2 ; PSSMIENO Old Med Instruction Name(s) multiple (#51.33) IEN
+3 ; Output -- None
+4 NEW DIR,X,Y
+5 ; -- check for missing variables, exit if not defined
+6 IF +$GET(PSSMIEN)'>0!(+$GET(PSSMIENO)'>0)
QUIT
+7 ; -- ask user if sure want to delete
+8 SET DIR("A")=" SURE YOU WANT TO DELETE"
+9 SET DIR(0)="Y"
+10 DO ^DIR
+11 IF '$GET(Y)
Begin DoDot:1
+12 DO EN^DDIOL(" (No) <NOTHING DELETED>","","?2")
End DoDot:1
QUIT
+13 IF '$TEST
Begin DoDot:1
+14 DO EN^DDIOL(" (Yes)","","?2")
+15 NEW DA,DIK,X
+16 ; -- delete entry
+17 SET DA=PSSMIENO
SET DA(1)=PSSMIEN
+18 SET DIK="^PS(51,"_DA(1)_",""6"","
+19 DO ^DIK
End DoDot:1
+20 QUIT
+21 ;
ISNSYDUP(X,PSSMIDA) ; -- Is there a duplicate in the Name or Synonym field of the Medication Instruction file (#51) **pss_1_201**
+1 ; Input -- X Old Med Instruction Name(s) multiple (#51.33) Name (#.01) field
+2 ; Output -- 1=Duplicate Found and 0=Unable to Check or No Duplicate Found
+3 ; PSSMIDA Medication Instruction file (#51) IEN
+4 NEW PSSDUPF,PSSNM
+5 ; -- check for missing variable, exit if not defined
+6 IF $GET(X)']""
QUIT 0
+7 ; -- initialize variables
+8 SET PSSNM=""
SET PSSDUPF=0
+9 ; -- loop throung "B" cross-reference looking for duplicate
+10 FOR
SET PSSNM=$ORDER(^PS(51,"B",PSSNM))
if PSSNM=""!($GET(PSSDUPF))
QUIT
Begin DoDot:1
+11 IF PSSNM=X
Begin DoDot:2
+12 ; -- if duplicate found set flag
+13 SET PSSDUPF=1
+14 ; -- get IEN for duplicate Medication Instruction Name
+15 SET PSSMIDA=+$ORDER(^PS(51,"B",PSSNM,0))
End DoDot:2
End DoDot:1
+16 QUIT +$GET(PSSDUPF)
+17 ;
ENMI ; medication instruction file **enhancements made in pss_1_201**
+1 NEW DD,DIC,DIE,DLAYGO,DA,DO,DR,PSSFINF,PSSMIEN,PSSMINME,PSSMIACT,PSSOTH,Y
+2 SET PSSOTH=$SELECT($PIECE($GET(^PS(59.7,1,40.2)),"^"):1,1:0)
+3 SET DIC="^PS(51,"
SET DIC(0)="EAMIL"
SET DLAYGO=51
SET PSSMIACT="LKUP"
WRITE !
DO ^DIC
KILL DIC
if +Y'>0
GOTO ENMIQ
+4 SET PSSMIEN=+Y
SET PSSMINME=$PIECE(Y,U,2)
SET PSSFINF=0
+5 SET DIE="^PS(51,"
SET DA=PSSMIEN
SET DR=".01;.5;1;S:'$G(PSSOTH) Y=""@1"";1.1;@1;9;30;32;32.1;31;S PSSFINF=1"
SET PSSMIACT="EDIT"
DO ^DIE
IF +$GET(DA)>0
IF $GET(PSSFINF)
DO ENOMI(PSSMINME,PSSMIEN)
+6 ; -- re-prompt until user does not select an entry
+7 GOTO ENMI
ENMIQ QUIT
+1 ;
ENOMI(PSSPMI,PSSDA) ; prompt to display interaction for OLD MED INSTRUCTION NAME(S) multiple **enhancements made in pss_1_201**
+1 if $GET(PSSPMI)']""!($GET(PSSDA)'>0)
QUIT
+2 ;
SELOMI ; -- select Old Med Instruction Name
+1 NEW DD,DIC,DIE,DLAYGO,DA,DO,DR,PSSADDF,PSSMIACT,PSSMIENO,Y
+2 SET DA(1)=PSSDA
SET DIC="^PS(51,"_DA(1)_",6,"
SET PSSMIACT="LKUP"
SET DIC(0)="EAMIL"
SET DIC("A")="Select OLD MED INSTRUCTION NAME(S): "_$$OMILE(PSSDA)
DO ^DIC
KILL DIC
if +Y'>0
GOTO ENOMIQ
+3 SET PSSMIENO=+Y
+4 SET DA(1)=PSSDA
SET DIE="^PS(51,"_DA(1)_",6,"
SET DA=PSSMIENO
SET DR=".01"
SET PSSMIACT="EDIT"
DO ^DIE
+5 ; -- re-prompt until user does not select an entry
+6 GOTO SELOMI
ENOMIQ QUIT
+1 ;
OMILE(PSSDA,PSSLR) ;
+1 NEW PSSLE
SET PSSLE=""
+2 IF $GET(^PS(51,$GET(PSSDA),6,0))'=""
SET PSSLR=999999
FOR
SET PSSLR=$ORDER(^PS(51,$GET(PSSDA),6,PSSLR),-1)
if $GET(^PS(51,$GET(PSSDA),6,PSSLR,0))'=""
SET PSSLE=$GET(^PS(51,$GET(PSSDA),6,PSSLR,0))_"// "
if PSSLR'=""
QUIT
+3 QUIT $GET(PSSLE)
+4 ;
ENOMIX(PSSPMI,PSSDA) ; used by the 'AF' xref for adding an edited NAME (#.01) field's old value in the MEDICATION INSTRUCTION (#51) file to the OLD MED INSTRUCTION NAME(S) multiple **pss_1_201**
+1 if $GET(PSSPMI)']""!($GET(PSSDA)'>0)
QUIT
+2 ;
+3 NEW PSSMCHK,PSSRCHK,PSSMFL1,PSSMFL2,PSSMFL3
+4 SET (PSSRCHK,PSSMCHK,PSSMFL1,PSSMFL2,PSSMFL3)=0
+5 ;
+6 IF $PIECE(^PS(51,$GET(PSSDA),0),U,1)=PSSPMI
SET PSSMFL1=1
+7 FOR
SET PSSMCHK=$ORDER(^PS(51,$GET(PSSDA),6,PSSMCHK))
if '+PSSMCHK!($GET(PSSMFL2))
QUIT
Begin DoDot:1
+8 IF ^PS(51,$GET(PSSDA),6,PSSMCHK,0)=PSSPMI
SET PSSMFL2=1
End DoDot:1
+9 FOR
SET PSSRCHK=$ORDER(^PS(51,"D",PSSRCHK))
if PSSRCHK']""!($GET(PSSMFL3))
QUIT
Begin DoDot:1
+10 IF PSSRCHK=PSSPMI
SET PSSMFL3=1
End DoDot:1
+11 IF '$GET(PSSMFL1)
IF '$GET(PSSMFL2)
IF '$GET(PSSMFL3)
IF $GET(PSSDA)
KILL DO
SET X=PSSPMI
SET DA(1)=$GET(PSSDA)
SET DIC=DIC_DA(1)_",6,"
SET DIC(0)="L"
DO FILE^DICN
SET DIC="^PS(51,"
SET DA=PSSDA
+12 QUIT
+13 ;
ENDRG ; standard drug fields
+1 QUIT
+2 DO NOW^%DTC
SET PSGDT=%
FOR
SET DIC="^PSDRUG("
SET DIC(0)="AEIMOQ"
SET DIC("A")="Select DISPENSE DRUG: "
WRITE !
DO ^DIC
KILL DIC
if +Y'>0
QUIT
DO DE
+3 KILL PSIUA,PSIUDA,PSIUX
GOTO DONE
+4 ;
DE ;
+1 QUIT
+2 IF $DATA(^PSDRUG(+Y,"I"))
IF ^("I")
IF ^("I")<PSGDT
WRITE $CHAR(7),$CHAR(7),!!?3,"*** WARNING, THIS DRUG IS INACTIVE. ***",!
+3 ;W ! S DIE="^PSDRUG(",(DA,PSIUDA)=+Y,DR="[PSJ FILED]"
+4 SET PSIUX="U^UNIT DOSE PHARMACY^1"
DO ^PSSGIU
if PSIUA'["^"
DO ^DIE
KILL DA,DIE,DR
QUIT
+5 ;
ENOSE ; order set enter/edit
+1 QUIT
+2 ;K DIC F S DLAYGO=53.2,DIC="^PS(53.2,",DIC(0)="QEAML",DIC("A")="Select ORDER SET: " W ! D ^DIC K DIC Q:Y'>0 S DA=+Y S DIE="^PS(53.2,",DR="[PSJUOSE]" D ^DIE K D0,D1,DA,DIE,DR,PSGNEDFD,PSGS0XT,PSGS0Y
+3 GOTO DONE
+4 ;
RBCHK ; used to validate room-bed
+1 QUIT
+2 ;F Z0=0:0 S Z0=$O(^PS(57.7,DA(2),1,Z0)) Q:'Z0 I Z0'=DA(1),$D(^(Z0,1,"B",X)) W !?19,X," is already under ",$S('$D(^PS(57.7,DA(2),1,Z0,0)):"another team ("_Z0_")!",$P(^(0),"^")]"":$P(^(0),"^")_"!",1:"another team ("_Z0_")!") Q
+3 IF 'Z0
IF $DATA(^DIC(42,DA(2),2,+$ORDER(^DIC(42,DA(2),2,"B",$PIECE(X,"-"),0)),1,"B",$PIECE(X,"-",2)))
KILL Z0
QUIT
+4 KILL X,Z0
QUIT
+5 ;
RBQ ; show room-beds for a ward
+1 QUIT
+2 WRITE !,"ANSWER WITH A ROOM-BED FROM THIS WARD ",$SELECT('$DATA(^DIC(42,DA(1),0)):"",$PIECE(^(0),"^")]"":" ("_$PIECE(^(0),"^")_")",1:"")
if '$DATA(^(0))
QUIT
WRITE !,"DO YOU WANT THE ENTIRE ROOM-BED LIST"
SET %=0
DO YN^DICN
if %'=1
QUIT
+3 WRITE !
SET (Z0,Z3)=0
FOR Z1=0:0
SET Z1=$ORDER(^DIC(42,DA(1),2,Z1))
if 'Z1
QUIT
IF $DATA(^(Z1,0))
SET Z4=$PIECE(^(0),"^")
IF Z4]""
FOR Z2=0:0
SET Z2=$ORDER(^DIC(42,DA(1),2,Z1,1,Z2))
if 'Z2
QUIT
IF $DATA(^(Z2,0))
IF $PIECE(^(0),"^")]""
SET Z0=Z0+1
if '(Z0#11)
DO RBNP
if Z3["^"
QUIT
WRITE ?1,Z4,"-",$PIECE(^(0),"^"),!
+4 KILL Z0,Z1,Z2,Z3,Z4
QUIT
+5 ;
RBNP ;W """^"" TO STOP: " R Z3:DTIME W:'$T $C(7) S:'$T Z3="^" W *13," ",*13 Q
+1 QUIT
+2 ;
ENPPD ; edit pharmacy patient data
+1 QUIT
+2 ; W !!?3,"...This option is still under development...",! Q
+3 ;D ENCV^PSGSETU I $D(XQUIT) Q
+4 ;S PSGRETF=1 F D ENDPT^PSGP Q:PSGP'>0 D ENHEAD^PSGO S DA=PSGP,DR="[PSJUPDE]",DIE="^PS(55," W ! D ^DIE
+5 ;K PSGRETF G DONE
+6 ;
ENCPDD ; edit patient's default stop date (wall)
+1 QUIT
+2 ;S X="PSGSETU" X ^%ZOSF("TEST") I D ENCV^PSGSETU I $D(XQUIT) Q
+3 ;S X="PSGGAO" X ^%ZOSF("TEST") I F D ENAO^PSGGAO Q:PSGP'>0 D
+4 ;.S WDN=$P($G(^DPT(PSGP,.1)),"^") W:WDN="" !!?2,"The patient is not currently on a ward."
+5 ;.I WDN]"" S WD=$O(^DIC(42,"B",WDN,0)),WD=$O(^PS(59.6,"B",+WD,0)) I $S('WD:1,1:'$P($G(^PS(59.6,WD,0)),"^",4)) S X="PLEASE NOTE: The 'SAME STOP DATE' parameter for the ward ("_WDN_") is not turned on. Any date entered here will be ignored "
+6 ;.I S X=X_"until the parameter is turned on for this ward." W $C(7),!!?2 F Y=1:1:$L(X," ") S X(1)=$P(X," ",Y) W:$L(X(1))+$X>78 ! W X(1)," "
+7 ;.S DA=PSGP,DR="62.01T",DIE="^PS(55," W !! D ^DIE
+8 ;K WD,WDN G DONE
+9 ;
ENSYS ; edit system file
+1 QUIT
+2 SET DIE="^PS(59.7,"
SET DA=1
SET DR="21;26;26.2"
WRITE !
DO ^DIE
KILL DIE,DA,DR
QUIT
+3 ;
ENPLSP ; edit pick list site parameters
+1 QUIT
+2 ;K DIC F Q=0:1 S DIC="^PS(59.4,",DIC(0)="QEAM" S:'Q DIC("B")=PSJSYSW W ! D ^DIC K DIC Q:Y'>0 S DA=+Y,DIE="^PS(59.4,",DR="[PSJUPLSP]" D ^DIE
+3 ;G DONE
+4 ;
ENCS ; change current site & parameters
+1 QUIT
+2 IF $DATA(PSJSYSW0)#2
WRITE !!,"Current site: ",$PIECE(PSJSYSW0,"^")
+3 ;S PSGCSF=1 S X="PSGSET" X ^%ZOSF("TEST") I D ^PSGSET,ENKV^PSGSETU W:$D(XQUIT) !!?5,"(The Inpatient site you are currently working under has not changed.)" K PSGCSF,PSGORSET,XQUIT Q
+4 ;
DF ; Add/edit Med route, instruction... to the Dosage form file.
+1 QUIT
+2 SET DIR("A")="Would you like to update the Dosage Form file"
+3 SET DIR("?")="If your answer is Yes, you will be able to Add/edit the Med routes, Instructions, Verb, Noun and Preposition that associate with this Dosage form."
+4 SET DIR(0)="Y"
SET DIR("B")="Y"
DO ^DIR
if Y'=1
QUIT
+5 NEW Y,DFNO
KILL DIE,DIC,DA,DR
+6 FOR
SET DIC="^PS(50.606,"
SET DIC(0)="QEAMI"
DO ^DIC
if +Y'>0
QUIT
SET DFNO=+Y
Begin DoDot:1
+7 IF $GET(MR)]""
IF '$DATA(^PS(50.606,DFNO,"MR","B",MRNO))
SET DIE="^PS(50.606,"
SET DR="1"
SET DA=DFNO
DO ^DIE
+8 KILL DIE,DIC,DR,MR
SET DIE="^PS(50.606,"
SET DR="1;2;3;5;6"
SET DA=DFNO
DO ^DIE
End DoDot:1
+9 QUIT
ENII ; infusion instruction file
+1 FOR
SET DIC="^PS(53.47,"
SET DIC(0)="QEAMIL"
SET DLAYGO=53.47
WRITE !
DO ^DIC
KILL DIC
if +Y'>0
QUIT
Begin DoDot:1
+2 if ($PIECE(Y,"^",3))
QUIT
+3 SET DIE="^PS(53.47,"
SET DA=+Y
SET DR=".01;1"
DO ^DIE
End DoDot:1
+4 KILL DIC,DIE,DLAYGO,DA,DR,Y
+5 QUIT
