PSOHELP ;BHAM ISC/SAB-outpatient utility routine ;06-Dec-2012 20:35;PLS
;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268,206,1015**;DEC 1997;Build 62
;External reference ^PS(51 supported by DBIA 2224
;External reference ^PSDRUG( supported by DBIA 221
;External reference ^PS(56 supported by DBIA 2229
;External reference ^PSNPPIP supported by DBIA 2261
;
; Modified - IHS/MSC/PLS - 12/06/2012 - Line MAX+10
;
XREF D XREF^PSOHELP3
Q
SIG ;checks PI for RXs
K VALMSG
I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!"
SIGONE K INS1 Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" EN S Z1=$P(X," ",Z0) D G:'$D(X) EN
.I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
.D:$D(X)&($G(Z1)]"") S INS1=$G(INS1)_" "_Z1
..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2)
..I $G(^PS(51,+Y,9))]"" S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
EN K Z1,Z0
Q
SSIG ;other lang. mods
K VALMSG
I $E(X)=" " D EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!") S VALMSG="There are leading spaces in Patient Instructions!"
K SINS1 Q:$L(X)<1 F Z0=1:1:$L(X," ") G:Z0="" EX S Z1=$P(X," ",Z0) D G:'$D(X) EX
.I $L(Z1)>32 W $C(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",! K X Q
.D:$D(X)&($G(Z1)]"") S SINS1=$G(SINS1)_" "_Z1
..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y S Z1=$P(^PS(51,Y,0),"^",2)
..I $G(^PS(51,+Y,4))]"" S Z1=^PS(51,+Y,4) ;,Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
EX K Z1,Z0
Q
QTY ;Check quantity dispensed against inventory
Q:'$G(PSODRUG("IEN"))
S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):+$P(^(0),"^",6),1:0)
I $D(^PSDRUG("AQ",Z0)),(+X'=X) K X,Z0 Q
S Z1=$S($D(^PSDRUG(Z0,660.1)):^(660.1),1:0)+(+X) D:X>Z1 EN^DDIOL(" Greater Than Current Inventory!","","$C(7)") K Z1
S ZX=X,ZZ0=$G(D0),D0=Z0
S Y(18,2)=$S($D(^PSDRUG(D0,660)):^(660),1:""),Y(18,1)=$S($D(^(660.1)):^(660.1),1:"")
S X=$P(Y(18,1),"^",1),X=$S($P(Y(18,2),"^",5):X/$P(Y(18,2),"^",5),1:"*******")
S X=$J(X,0,2)
D:X<$S($D(^PSDRUG(Z0,660)):+^(660),1:1) EN^DDIOL(" Below Reorder Level.","","$C(7)") S X=ZX,D0=$G(ZZ0) K ZZ0,Z0,ZX
Q
HELP ;qty help
G:$G(PSOFDR) HLP
S Z0=$S($G(PSODRUG("IEN"))]"":PSODRUG("IEN"),$G(PSXYES):$P(^PSRX(ZRX,0),"^",6),$D(^PSRX(DA,0)):$P(^PSRX(DA,0),"^",6),1:0)
HLP S Z0=+$G(PSODRUG("IEN")) I $D(^PSDRUG("AQ",Z0)) D EN^DDIOL("This is a CMOP drug. The quantity may not contain alpha characters (i.e.; ML)","","!!") D EN^DDIOL("or more than two fractional decimal places (i.e.; .01).","","!") D K Z0 Q
.D EN^DDIOL("Enter a number between 0 and 99999999 inclusive. The total entry cannot","","!") D EN^DDIOL("exceed 11 characters.","","!")
D EN^DDIOL("Enter a whole number between 0 and 99999999 inclusive. Alpha characters are","","!!")
D EN^DDIOL("not allowed, and the entry cannot exceed 11 characters, or contain more than","","!") D EN^DDIOL("two fractional decimal places (i.e.; .01).","","!")
K Z0
Q
ADD ;add/edited local drug/drug interactions
W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEMQL",DLAYGO=56
S (DIC,DIE)="^PS(56,",DIC("S")="I '$P(^(0),""^"",5)" D ^DIC G:"^"[X QU G:Y<0 ADD S DA=+Y,DR="[PSO INTERACT]" L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G ADD
D ^DIE L:$G(DA) -^PS(56,DA) K DA G ADD
QU L -^PS(56,DA) K X,DIC,DIE,DA
Q
CRI ;change drug interaction severity to critical from significant
W ! S DIC("A")="Select Drug Interaction: ",DIC(0)="AEQM",(DIC,DIE)="^PS(56,",DIC("S")="I $P(^(0),""^"",4)=2" D ^DIC G:"^"[X QU G:Y<0 CRI S DA=+Y,DR=3
L +^PS(56,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!",! G CRI
D ^DIE L -^PS(56,DA) K DA G CRI
G QU
Q
MAX S:$G(EXH) P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)),PTDY=$P($G(^(0)),"^",3),PTRF=$P($G(^(0)),"^",4)
S PSODEA=$P(^PSDRUG(P(5),0),"^",3),CS=0
I $D(CLOZPAT) S MAX=$S(CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=14):1,CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=7):3,CLOZPAT=1&($P(^PSRX(DA,0),"^",8)=7):1,1:0),MIN=0 Q
I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) D EN^DDIOL("No refills allowed on "_$S(PSODEA["A":"this narcotic drug.",1:"this drug."),"","!") D EN^DDIOL(" ","","!") S $P(^PSRX(DA,0),"^",9)=0 K X,Y,PSODEA,CS,PTST Q
F DEA=1:1 Q:$E(PSODEA,DEA)="" I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
S PSOELSE=CS I PSOELSE D
.S PSOX1=$S(PTRF>5:5,1:PTRF),PSOT=$S(PSOX1=5:5,1:PSOX1)
.S PSOT=$S('PSOT:0,P(7)=90:1,1:PSOT),PSDY1=$S(P(7)<60:5,P(7)'<60&(P(7)'>89):2,P(7)=90:1,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
I 'PSOELSE D
.S PSOX1=PTRF,PSOT=$S(PSOX1=11:11,1:PSOX1),PSOT=$S('PSOT:0,P(7)=90:3,1:PSOT)
.;IHS/MSC/PLS - 12/06/2012
.;S PSDY1=$S(P(7)<60:11,P(7)'<60&(P(7)'>89):5,P(7)=90:3,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
.S PSDY1=$S(P(7)<60:15,P(7)<90:5,P(7)=90:3,P(7)<168:2,P(7)<365:1,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
K PSODEA,PSOELSE,PSOT,PSOX1,PSDY,PSDY1,DEA,CS
I $D(X) S MIN=0 I $D(DA) F REF=0:0 S REF=$O(^PSRX(DA,1,REF)) Q:'REF I $D(^(REF,0)) S MIN=MIN+1
I $G(EXH) D EN^DDIOL("Enter a number Between "_MIN_" AND "_MAX_".","","!?10") K P(2),P(5),P(7),MAX,MAX1,MIN,REF
Q
;
REF S PSRF=X,P(7)=$P(^PSRX(DA,0),"^",8),P(5)=$P(^(0),"^",6),P(2)=+$P(^(0),"^",3) S:P(2) PTST=$G(^PS(53,P(2),0)) S PTDY=$P(^(0),"^",3),PTRF=$P(^(0),"^",4)
D MAX Q:'$D(X) I (+X'=X)!(X<0)!(X>MAX)!(X?.E1"."1N.N) D EN^DDIOL(" ** MAX REFILLS ALLOWED ARE "_MAX_" ** ","","$C(7)") K X
I $D(X),X<MIN D EN^DDIOL(" ** PATIENT HAS ALREADY RECEIVED "_MIN_" REFILLS ** ","","$C(7)") K X
D DAYS^PSOUTLA
K PTDY,PTRF,MAX,DAYS,PSDAYS,PSODEA,PSOX,PSOX1,PSDY,PSDY1,DEA,CS,PTST,PSRF,MIN,REF,P(2),P(7),P(5),MAX1
Q
PAT ;patient field screen in file 52
N DIC,DIE S DFN=X D INP^VADPT,DEM^VADPT
I $P(VADM(6),"^") D EN^DDIOL("PATIENT DIED "_$P(VADM(6),"^",2),"","$C(7),!?10") D EN^DDIOL(" ","","!") K X,DFN Q
I $P(VAIN(4),"^") D EN^DDIOL("PATIENT IS AN INPATIENT ON WARD "_$P(VAIN(4),"^",2)_" !!","","$C(7),!?10") K DIR D DIR K VA,VADN,VAIN Q
E S X=DFN K DFN,DIRUT,DTOUT,DUOUT
Q
DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="DO YOU WISH TO CONTINUE" D ^DIR K DIR
K:'Y X S:Y X=DFN K DFN,DIRUT,DTOUT,DUOUT,VA,VADM,VAIN
Q
BG ;prevents editing of display groups with patients from name to ticket
S $P(^PS(59.3,DA,0),"^",2)=PDP W !,$C(7),"The display cannot be changed from NAME to TICKET when patients are",!,"already in the Display Group. All patients must be purged and re-entered.",!,"Ticket numbers must be issued !!",! K Y,PDP
Q
CLNAP ;quits action profile
Q
PRMI ;prints medication instruction sheets. select drug.
S X="PSNPPIP" X ^%ZOSF("TEST") I '$T S VALMBCK="",VALMSG="Medication Instruction Sheets Not Installed!" Q
I $G(PSODFN) N PSNDFN S PSNDFN=PSODFN
W !! K PSNPPI("MESSAGE") D FULL^VALM1,^PSNPPIP S VALMBCK="R"
I $G(PSNPPI("MESSAGE"))]"" D
.K DIR W PSNPPI("MESSAGE"),! S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
Q
PRMID ;prints medication instruction sheets. pass in drug.
I $T(ENOP^PSNPPIP)']"" S VALMBCK="",VALMSG="Medication Instruction Sheets Not Installed!" Q
K PSNPPI("MESSAGE") D FULL^VALM1
W !! D ENOP^PSNPPIP($P(RX0,"^",6),$G(^PSRX(RXN,"TN")),$P(RX0,"^"),PSODFN)
S VALMBCK="R" I $G(PSNPPI("MESSAGE"))]"" D
.K DIR W PSNPPI("MESSAGE"),! S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
Q
PSOHELP ;BHAM ISC/SAB-outpatient utility routine ;06-Dec-2012 20:35;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268,206,1015**;DEC 1997;Build 62
+2 ;External reference ^PS(51 supported by DBIA 2224
+3 ;External reference ^PSDRUG( supported by DBIA 221
+4 ;External reference ^PS(56 supported by DBIA 2229
+5 ;External reference ^PSNPPIP supported by DBIA 2261
+6 ;
+7 ; Modified - IHS/MSC/PLS - 12/06/2012 - Line MAX+10
+8 ;
XREF DO XREF^PSOHELP3
+1 QUIT
SIG ;checks PI for RXs
+1 KILL VALMSG
+2 IF $EXTRACT(X)=" "
DO EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!")
SET VALMSG="There are leading spaces in Patient Instructions!"
SIGONE KILL INS1
IF $LENGTH(X)<1
QUIT
FOR Z0=1:1:$LENGTH(X," ")
IF Z0=""
GOTO EN
SET Z1=$PIECE(X," ",Z0)
Begin DoDot:1
+1 IF $LENGTH(Z1)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",!
KILL X
QUIT
+2 IF $DATA(X)&($GET(Z1)]"")
Begin DoDot:2
+3 SET Y=$ORDER(^PS(51,"B",Z1,0))
IF 'Y!($PIECE($GET(^PS(51,+Y,0)),"^",4)>1)
QUIT
SET Z1=$PIECE(^PS(51,Y,0),"^",2)
+4 IF $GET(^PS(51,+Y,9))]""
SET Y=$PIECE(X," ",Z0-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
IF Y>1
SET Z1=^(9)
End DoDot:2
SET INS1=$GET(INS1)_" "_Z1
End DoDot:1
IF '$DATA(X)
GOTO EN
EN KILL Z1,Z0
+1 QUIT
SSIG ;other lang. mods
+1 KILL VALMSG
+2 IF $EXTRACT(X)=" "
DO EN^DDIOL("Leading spaces should not entered in the Patient Instructions! ","","$C(7),!")
SET VALMSG="There are leading spaces in Patient Instructions!"
+3 KILL SINS1
IF $LENGTH(X)<1
QUIT
FOR Z0=1:1:$LENGTH(X," ")
IF Z0=""
GOTO EX
SET Z1=$PIECE(X," ",Z0)
Begin DoDot:1
+4 IF $LENGTH(Z1)>32
WRITE $CHAR(7),!?5,"MAX OF 32 CHARACTERS ALLOWED BETWEEN SPACES.",!
KILL X
QUIT
+5 IF $DATA(X)&($GET(Z1)]"")
Begin DoDot:2
+6 SET Y=$ORDER(^PS(51,"B",Z1,0))
IF 'Y
QUIT
SET Z1=$PIECE(^PS(51,Y,0),"^",2)
+7 ;,Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
IF $GET(^PS(51,+Y,4))]""
SET Z1=^PS(51,+Y,4)
End DoDot:2
SET SINS1=$GET(SINS1)_" "_Z1
End DoDot:1
IF '$DATA(X)
GOTO EX
EX KILL Z1,Z0
+1 QUIT
QTY ;Check quantity dispensed against inventory
+1 IF '$GET(PSODRUG("IEN"))
QUIT
+2 SET Z0=$SELECT($GET(PSODRUG("IEN"))]"":PSODRUG("IEN"),$GET(PSXYES):$PIECE(^PSRX(ZRX,0),"^",6),$DATA(^PSRX(DA,0)):+$PIECE(^(0),"^",6),1:0)
+3 IF $DATA(^PSDRUG("AQ",Z0))
IF (+X'=X)
KILL X,Z0
QUIT
+4 SET Z1=$SELECT($DATA(^PSDRUG(Z0,660.1)):^(660.1),1:0)+(+X)
IF X>Z1
DO EN^DDIOL(" Greater Than Current Inventory!","","$C(7)")
KILL Z1
+5 SET ZX=X
SET ZZ0=$GET(D0)
SET D0=Z0
+6 SET Y(18,2)=$SELECT($DATA(^PSDRUG(D0,660)):^(660),1:"")
SET Y(18,1)=$SELECT($DATA(^(660.1)):^(660.1),1:"")
+7 SET X=$PIECE(Y(18,1),"^",1)
SET X=$SELECT($PIECE(Y(18,2),"^",5):X/$PIECE(Y(18,2),"^",5),1:"*******")
+8 SET X=$JUSTIFY(X,0,2)
+9 IF X<$SELECT($DATA(^PSDRUG(Z0,660))
DO EN^DDIOL(" Below Reorder Level.","","$C(7)")
SET X=ZX
SET D0=$GET(ZZ0)
KILL ZZ0,Z0,ZX
+10 QUIT
HELP ;qty help
+1 IF $GET(PSOFDR)
GOTO HLP
+2 SET Z0=$SELECT($GET(PSODRUG("IEN"))]"":PSODRUG("IEN"),$GET(PSXYES):$PIECE(^PSRX(ZRX,0),"^",6),$DATA(^PSRX(DA,0)):$PIECE(^PSRX(DA,0),"^",6),1:0)
HLP SET Z0=+$GET(PSODRUG("IEN"))
IF $DATA(^PSDRUG("AQ",Z0))
DO EN^DDIOL("This is a CMOP drug. The quantity may not contain alpha characters (i.e.; ML)","","!!")
DO EN^DDIOL("or more than two fractional decimal places (i.e.; .01).","","!")
Begin DoDot:1
+1 DO EN^DDIOL("Enter a number between 0 and 99999999 inclusive. The total entry cannot","","!")
DO EN^DDIOL("exceed 11 characters.","","!")
End DoDot:1
KILL Z0
QUIT
+2 DO EN^DDIOL("Enter a whole number between 0 and 99999999 inclusive. Alpha characters are","","!!")
+3 DO EN^DDIOL("not allowed, and the entry cannot exceed 11 characters, or contain more than","","!")
DO EN^DDIOL("two fractional decimal places (i.e.; .01).","","!")
+4 KILL Z0
+5 QUIT
ADD ;add/edited local drug/drug interactions
+1 WRITE !
SET DIC("A")="Select Drug Interaction: "
SET DIC(0)="AEMQL"
SET DLAYGO=56
+2 SET (DIC,DIE)="^PS(56,"
SET DIC("S")="I '$P(^(0),""^"",5)"
DO ^DIC
IF "^"[X
GOTO QU
IF Y<0
GOTO ADD
SET DA=+Y
SET DR="[PSO INTERACT]"
LOCK +^PS(56,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !,"Entry is being edited by another user. Try Later!",!
GOTO ADD
+3 DO ^DIE
IF $GET(DA)
LOCK -^PS(56,DA)
KILL DA
GOTO ADD
QU LOCK -^PS(56,DA)
KILL X,DIC,DIE,DA
+1 QUIT
CRI ;change drug interaction severity to critical from significant
+1 WRITE !
SET DIC("A")="Select Drug Interaction: "
SET DIC(0)="AEQM"
SET (DIC,DIE)="^PS(56,"
SET DIC("S")="I $P(^(0),""^"",4)=2"
DO ^DIC
IF "^"[X
GOTO QU
IF Y<0
GOTO CRI
SET DA=+Y
SET DR=3
+2 LOCK +^PS(56,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !,"Entry is being edited by another user. Try Later!",!
GOTO CRI
+3 DO ^DIE
LOCK -^PS(56,DA)
KILL DA
GOTO CRI
+4 GOTO QU
+5 QUIT
MAX IF $GET(EXH)
SET P(7)=$PIECE(^PSRX(DA,0),"^",8)
SET P(5)=$PIECE(^(0),"^",6)
SET P(2)=+$PIECE(^(0),"^",3)
IF P(2)
SET PTST=$GET(^PS(53,P(2),0))
SET PTDY=$PIECE($GET(^(0)),"^",3)
SET PTRF=$PIECE($GET(^(0)),"^",4)
+1 SET PSODEA=$PIECE(^PSDRUG(P(5),0),"^",3)
SET CS=0
+2 IF $DATA(CLOZPAT)
SET MAX=$SELECT(CLOZPAT=2&($PIECE(^PSRX(DA,0),"^",8)=14):1,CLOZPAT=2&($PIECE(^PSRX(DA,0),"^",8)=7):3,CLOZPAT=1&($PIECE(^PSRX(DA,0),"^",8)=7):1,1:0)
SET MIN=0
QUIT
+3 IF PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2)
DO EN^DDIOL("No refills allowed on "_$SELECT(PSODEA["A":"this narcotic drug.",1:"this drug."),"","!")
DO EN^DDIOL(" ","","!")
SET $PIECE(^PSRX(DA,0),"^",9)=0
KILL X,Y,PSODEA,CS,PTST
QUIT
+4 FOR DEA=1:1
IF $EXTRACT(PSODEA,DEA)=""
QUIT
IF $EXTRACT(+PSODEA,DEA)>1
IF $EXTRACT(+PSODEA,DEA)<6
SET CS=1
+5 SET PSOELSE=CS
IF PSOELSE
Begin DoDot:1
+6 SET PSOX1=$SELECT(PTRF>5:5,1:PTRF)
SET PSOT=$SELECT(PSOX1=5:5,1:PSOX1)
+7 SET PSOT=$SELECT('PSOT:0,P(7)=90:1,1:PSOT)
SET PSDY1=$SELECT(P(7)<60:5,P(7)'<60&(P(7)'>89):2,P(7)=90:1,1:0)
SET MAX=$SELECT(PSOT'>PSDY1:PSOT,1:PSDY1)
End DoDot:1
+8 IF 'PSOELSE
Begin DoDot:1
+9 SET PSOX1=PTRF
SET PSOT=$SELECT(PSOX1=11:11,1:PSOX1)
SET PSOT=$SELECT('PSOT:0,P(7)=90:3,1:PSOT)
+10 ;IHS/MSC/PLS - 12/06/2012
+11 ;S PSDY1=$S(P(7)<60:11,P(7)'<60&(P(7)'>89):5,P(7)=90:3,1:0) S MAX=$S(PSOT'>PSDY1:PSOT,1:PSDY1)
+12 SET PSDY1=$SELECT(P(7)<60:15,P(7)<90:5,P(7)=90:3,P(7)<168:2,P(7)<365:1,1:0)
SET MAX=$SELECT(PSOT'>PSDY1:PSOT,1:PSDY1)
End DoDot:1
+13 KILL PSODEA,PSOELSE,PSOT,PSOX1,PSDY,PSDY1,DEA,CS
+14 IF $DATA(X)
SET MIN=0
IF $DATA(DA)
FOR REF=0:0
SET REF=$ORDER(^PSRX(DA,1,REF))
IF 'REF
QUIT
IF $DATA(^(REF,0))
SET MIN=MIN+1
+15 IF $GET(EXH)
DO EN^DDIOL("Enter a number Between "_MIN_" AND "_MAX_".","","!?10")
KILL P(2),P(5),P(7),MAX,MAX1,MIN,REF
+16 QUIT
+17 ;
REF SET PSRF=X
SET P(7)=$PIECE(^PSRX(DA,0),"^",8)
SET P(5)=$PIECE(^(0),"^",6)
SET P(2)=+$PIECE(^(0),"^",3)
IF P(2)
SET PTST=$GET(^PS(53,P(2),0))
SET PTDY=$PIECE(^(0),"^",3)
SET PTRF=$PIECE(^(0),"^",4)
+1 DO MAX
IF '$DATA(X)
QUIT
IF (+X'=X)!(X<0)!(X>MAX)!(X?.E1"."1N.N)
DO EN^DDIOL(" ** MAX REFILLS ALLOWED ARE "_MAX_" ** ","","$C(7)")
KILL X
+2 IF $DATA(X)
IF X<MIN
DO EN^DDIOL(" ** PATIENT HAS ALREADY RECEIVED "_MIN_" REFILLS ** ","","$C(7)")
KILL X
+3 DO DAYS^PSOUTLA
+4 KILL PTDY,PTRF,MAX,DAYS,PSDAYS,PSODEA,PSOX,PSOX1,PSDY,PSDY1,DEA,CS,PTST,PSRF,MIN,REF,P(2),P(7),P(5),MAX1
+5 QUIT
PAT ;patient field screen in file 52
+1 NEW DIC,DIE
SET DFN=X
DO INP^VADPT
DO DEM^VADPT
+2 IF $PIECE(VADM(6),"^")
DO EN^DDIOL("PATIENT DIED "_$PIECE(VADM(6),"^",2),"","$C(7),!?10")
DO EN^DDIOL(" ","","!")
KILL X,DFN
QUIT
+3 IF $PIECE(VAIN(4),"^")
DO EN^DDIOL("PATIENT IS AN INPATIENT ON WARD "_$PIECE(VAIN(4),"^",2)_" !!","","$C(7),!?10")
KILL DIR
DO DIR
KILL VA,VADN,VAIN
QUIT
+4 IF '$TEST
SET X=DFN
KILL DFN,DIRUT,DTOUT,DUOUT
+5 QUIT
DIR SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="DO YOU WISH TO CONTINUE"
DO ^DIR
KILL DIR
+1 IF 'Y
KILL X
IF Y
SET X=DFN
KILL DFN,DIRUT,DTOUT,DUOUT,VA,VADM,VAIN
+2 QUIT
BG ;prevents editing of display groups with patients from name to ticket
+1 SET $PIECE(^PS(59.3,DA,0),"^",2)=PDP
WRITE !,$CHAR(7),"The display cannot be changed from NAME to TICKET when patients are",!,"already in the Display Group. All patients must be purged and re-entered.",!,"Ticket numbers must be issued !!",!
KILL Y,PDP
+2 QUIT
CLNAP ;quits action profile
+1 QUIT
PRMI ;prints medication instruction sheets. select drug.
+1 SET X="PSNPPIP"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET VALMBCK=""
SET VALMSG="Medication Instruction Sheets Not Installed!"
QUIT
+2 IF $GET(PSODFN)
NEW PSNDFN
SET PSNDFN=PSODFN
+3 WRITE !!
KILL PSNPPI("MESSAGE")
DO FULL^VALM1
DO ^PSNPPIP
SET VALMBCK="R"
+4 IF $GET(PSNPPI("MESSAGE"))]""
Begin DoDot:1
+5 KILL DIR
WRITE PSNPPI("MESSAGE"),!
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
End DoDot:1
+6 QUIT
PRMID ;prints medication instruction sheets. pass in drug.
+1 IF $TEXT(ENOP^PSNPPIP)']""
SET VALMBCK=""
SET VALMSG="Medication Instruction Sheets Not Installed!"
QUIT
+2 KILL PSNPPI("MESSAGE")
DO FULL^VALM1
+3 WRITE !!
DO ENOP^PSNPPIP($PIECE(RX0,"^",6),$GET(^PSRX(RXN,"TN")),$PIECE(RX0,"^"),PSODFN)
+4 SET VALMBCK="R"
IF $GET(PSNPPI("MESSAGE"))]""
Begin DoDot:1
+5 KILL DIR
WRITE PSNPPI("MESSAGE"),!
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DIRUT,DIRUT,PSNPPI("MESSGAE")
End DoDot:1
+6 QUIT
