PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;07/29/96
;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,225,338,313,408,612**;DEC 1997;Build 23
;External reference ^YSCL(603.01 supported by DBIA 2697
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
;External reference to EN1^ORCFLAG is supported by DBIA 3620
HLP W !,"Enter 'S' to process orders with a priority of STAT",!," 'E' to process orders with an Emergency priority,",!," 'R' to process Routine orders.",! Q
HELP ;
W !,"Please enter a minimum of two (2) characters.",!,"Enter Patient's name whose med orders are to be completed.",!
S (PATN,DPT)=0 F S DPT=$O(^PS(52.41,"AOR",DPT)) Q:'DPT I $D(^PS(52.41,"AOR",DPT,PSOPINST)) W !,$P(^DPT(DPT,0),"^") S PATN=PATN+1 I PATN=20 D I $D(DUOUT)!($D(DTOUT)) G HELPX
.K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E" D ^DIR S PATN=0 K DIR
HELPX K DTOUT,DUOUT,DIRUT,PAINST S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFIN"
K PATN,DPT Q
RTE ;
S PSZFIN=1
F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AC",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN) D
.I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0
Q
PRI ;
S PSZFIN=1
F PSZFZZ=0:0 S PSZFZZ=$O(^PS(52.41,"AP",PAT,$E(PSRT),PSZFZZ)) Q:'PSZFZZ!('PSZFIN) D
.I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0
Q
PROFILE ;display med profile
S MEDA=3 ;3=question asked already
W !!! K MEDP,DIR,DUOUT,DIRUT,DTOUT S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to see Medication Profile" D ^DIR K DIR Q:$D(DIRUT)!('Y)
I Y S MEDP=1
K DIR,DUOUT,DIRUT,DTOUT
Q
DC I '$G(PSOORRNW),$G(PSOOPT)=3 S PSORENW("DFLG")=1 S:'$D(PSOBBC1("FROM")) VALMBCK="Q",VALMSG="Renew Rx Request Canceled.",Y=-1 Q
G DC^PSOORFI6
Q
DE Q:'$D(^PS(52.41,ORD,0))
K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
S POERR("COMM")=$S($G(POERR("DEAD")):"Patient died on "_$G(PSOPTPST(2,PSODFN,.351))_".",1:ACOM),$P(^PS(52.41,ORD,4),"^")=POERR("COMM")
D EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR)
I '$G(POERR("DEAD")) S DIR("A")="Press Return to Continue" D PAUSE^VALM1
K PSONOOR,PDORUG,ACOM,CMOP,DEA,DEF,DREN,FDR,HDR,PHI,PRC,SIGOK,DIR,DTOUT,DUOUT,DIRUT
S Y=-1 Q
;
RF ;process refill request from CPRS
S PSOREF("IRXN")=$P(OR0,"^",19) D PSOL^PSSLOCK($P(OR0,"^",19)) I '$G(PSOMSG) D D PAUSE^VALM1 K PSOREF,PSOMSG Q
.I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2),! Q
.W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(OR0,"^",19),0),"^"),!
;
D FULL^VALM1
I '$P($G(^PS(52.41,ORD,0)),"^",23),+$G(^PS(52.41,ORD,"FLG")) D I $D(DIRUT)!'Y S VALMBCK="B" Q
. K DIRUT,DUOUT,DTOUT,DIR
. S DIR("A",1)="Flagged by "_$$GET1^DIQ(52.41,ORD,34)_" on "_$$GET1^DIQ(52.41,ORD,33)_": "_$$GET1^DIQ(52.41,ORD,35)
. S DIR("A",2)=""
. S DIR("A",3)="Unflagged by "_$$GET1^DIQ(52.41,ORD,37)_" on "_$$GET1^DIQ(52.41,ORD,36)_": "_$$GET1^DIQ(52.41,ORD,38)
. S DIR("A",4)=""
. S DIR(0)="Y",DIR("B")="YES",DIR("A")="Continue"
. W ! D ^DIR
;
I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 D Q:$D(DIRUT)!'Y D EN1^ORCFLAG(+$P($G(^PS(52.41,ORD,0)),"^")) H 1
. K DIRUT,DUOUT,DTOUT,DIR
. S DIR("A",1)="This Refill Request is flagged. In order to process it"
. S DIR("A",2)="you must unflag it first."
. S DIR("A",3)=""
. S DIR(0)="Y",DIR("A")="Unflag Refill Request",DIR("B")="NO"
. W ! D ^DIR I $D(DIRUT)!'Y S VALMBCK="B"
I $G(ORD),+$P($G(^PS(52.41,+ORD,0)),"^",23)=1 Q
;
I $$TITRX^PSOUTL(PSOREF("IRXN"))="t" D D PAUSE^VALM1 K PSOREF Q
. W !!,$C(7),"Rx# "_$P(^PSRX($P(OR0,"^",19),0),"^")_" is marked as 'Titration Rx' and cannot be refilled."
;
K PSOMSG S (PSOREF("DFLG"),PSOREF("FIELD"),PSOREF1)=0,X="T-6M",%DT="X" D ^%DT
S (PSOID,PSOREF("ISSUE DATE"))=$S($P(^PSRX(PSOREF("IRXN"),0),"^",13)<Y:Y,1:$P(^PSRX(PSOREF("IRXN"),0),"^",13))
S:$G(PSORX("BAR CODE"))&($G(PSOBBC1("FROM"))="NEW") PSOREF("ISSUE DATE")=DT K X,X1,X2
;
S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSOREF("IRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9)
W !!,"Processing Refill Request for Rx "_$P(^PSRX(PSOREF("IRXN"),0),"^")
D FILLDT^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
;
S PSORX("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"MAIL",1:"WINDOW")
D MW^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
K PSORX("ADMINCLINIC") S:$P(OR0,"^",17)="C" PSORX("ADMINCLINIC")=1
S:'$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0
D ^PSOREF0
END D PSOUL^PSSLOCK(PSOREF("IRXN")) K PSOREF,NODE,PSOREF1,PSL,PSOERR,PSORX("QFLG")
Q
S D KPRI,KPRIZ F S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOSTATZ=1
D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG")) I $G(PSOSTATZ) S ORD=0 D
.D KPRIZ F S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
.Q:$G(POERR("QFLG"))
.D KPRIZ S ORD=0 F S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
D KPRI
Q
E D KPRI,KPRIZ F S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOEMERZ=1
D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG")) I $G(PSOEMERZ) S ORD=0 D
.D KPRIZ F S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
.Q:$G(POERR("QFLG"))
.D KPRIZ S ORD=0 F S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
D KPRI
Q
R D KPRI,KPRIZ F S ORD=$O(^PS(52.41,"AP",PAT,"R",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN S PSOROUTZ=1
D:$G(POERR("QFLG")) KPRI Q:$G(POERR("QFLG")) I $G(PSOROUTZ) S ORD=0 D
.D KPRIZ F S ORD=$O(^PS(52.41,"AP",PAT,"E",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
.Q:$G(POERR("QFLG"))
.D KPRIZ S ORD=0 F S ORD=$O(^PS(52.41,"AP",PAT,"S",ORD)) Q:'ORD!($G(POERR("QFLG"))) I $P(^PS(52.41,ORD,0),"^",3)'="DC",$P(^(0),"^",3)'="DE" D LOCK1^PSOORFI1,ORD^PSOORFIN
D KPRI
Q
KPRI K PSOSTATZ,PSOROUTZ,PSOEMERZ
Q
KPRIZ K PSOQUIT,POERR("QFLG")
Q
INST ;Select Institution
N PSOCNT
I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) S PSOIQUIT=1 Q
N PSIR,PSCT,PSINST K PSOPINST
S PSCT=0 F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSCT=PSCT+1 I PSCT=1 S PSOPINST=$P($G(^(0)),"^")
I PSCT=0 W !!,"There are no CPRS Ordering Institutions associated with this Outpatient site!",!,"Use the Site Parameter enter/edit option to enter CPRS Ordering Institutions!",! S PSOIQUIT=1 Q
I PSCT=1 D INSTNM G INSTA
W !!!,"There are multiple Institutions associated with this Outpatient Site for",!,"finishing orders entered through CPRS. Select the Institution for which to",!,"finish orders from. Enter '?' to see all choices.",!
K PSOPNAME D:$G(PSOPINST) K DIC S DIC(0)="AEQMZ",DIC="^PS(59,"_PSOSITE_",""INI1""," S:$G(PSOPNAME)'="" DIC("B")=$G(PSOPNAME) D ^DIC K DIC,PSOPNAME I Y<1 W !!,"No Institution selected",! S PSOIQUIT=1 Q
.K ^UTILITY("DIQ1",$J),DIQ S DA=$G(PSOPINST),DIC=4,DIQ(0)="E",DR=".01" D EN^DIQ1 S PSOPNAME=$G(^UTILITY("DIQ1",$J,4,DA,.01,"E")) K ^UTILITY("DIQ1",$J),DA,DR,DIC,DIQ
W ! S PSOPINST=$P(Y,"^",2) K Y
D INSTNM W !,"You have selected "_$G(PSODINST)_"."
W !,"After completing these orders, you may re-enter this option and select again."
INSTA ;
S PSOCNT=$$CNT(PSOPINST)
I '$D(IOINORM)!('$D(IOINHI)) S X="IORVOFF;IORVON;IOINHI;IOINORM" D ENDR^%ZISS
W !!?7,IORVON_IOINHI,"<There ",$S(PSOCNT=1:"is ",1:"are "),$S(PSOCNT>0:PSOCNT,1:"no")," flagged order",$S(PSOCNT=1:"",1:"s")," for ",PSODINST,">",IOINORM_IORVOFF,!
K PSODINST
Q
;
CNT(SITE) ; - Counter for flagged pending orders by Site
N CNT,ORD
K ^TMP($J,"PSOFLPO")
S (CNT,LOGIN,ORD)=0
F S LOGIN=$O(^PS(52.41,"AD",LOGIN)) Q:'LOGIN D
. F S ORD=$O(^PS(52.41,"AD",LOGIN,SITE,ORD)) Q:'ORD D
. . I $P(^PS(52.41,ORD,0),"^",3)="DC"!($P(^PS(52.41,ORD,0),"^",3)="DE") Q
. . I $P($G(^PS(52.41,ORD,0)),"^",23) S CNT=CNT+1 S:$P(^(0),"^",2) ^TMP($J,"PSOFLPO",$P(^(0),"^",2))=""
Q CNT
;
INST1 ;
K PSOPINST N PSIR
F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR!($G(PSOPINST)) I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSOPINST=$P($G(^(0)),"^")
Q
CLOZ ;checks clozapine status of patient
; BEGIN - JCH: PSO*7*612
;S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0))
S CLOZPAT=$$GETREGYS^PSOCLUTL(PSODFN)
; END - JCH: PSO*7*612
S CLOZPAT=$P($G(^YSCL(603.01,+CLOZPAT,0)),"^",3)
S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
S:'$D(PSONEW("# OF REFILLS")) (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0
Q
ELIG I $G(CLOZPAT)=1 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Patient Eligible for 14 Day Supply or 7 Day Supply with 1 refill"
I $G(CLOZPAT)=2 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)=" Patient Eligible for 28 Day Supply or 14 Day Supply with 1 refill or 7 Day Supply with 3 refill"
Q
USER(USER) ;returns .01 of 200
K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_USER D ^DIC S USER1=$S(+Y:$P(Y,"^",2),1:"Unknown") K DIC,X,Y
Q
INSTNM ;
K PSOFINDA,PSODINST I $G(DA) S PSOFINDA=$G(DA)
K PSODNM S DA=$G(PSOPINST) I DA S DIC=4,DIQ(0)="E",DR=".01",DIQ="PSODNM" D EN^DIQ1 S PSODINST=$G(PSODNM(4,DA,.01,"E")) K PSODNM,DIC,DR,DA
I $G(PSOFINDA) S DA=$G(PSOFINDA) K PSOFINDA
Q
POST S PSOFINY=$G(Y) D ^PSOBUILD S Y=$G(PSOFINY) K PSOFINY D OERR^PSORX1 I $G(PSOQUIT) Q
K PSOQFLG F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN K PSOXFLG Q:$G(POERR("DEAD"))!($G(PSOQFLG))
I $G(POERR("DEAD")) S POERR("QFLG")=1 Q
K PSOERR("DEAD") I $G(PSOQFLG) Q
D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
Q
SIG ;
S SIG=0,PSOFINFL=1 F S SIG=$O(^PS(52.41,ORD,"SIG",SIG)) Q:'SIG D
.S (MIG,SIG(SIG))=^PS(52.41,ORD,"SIG",SIG,0)
.F SG=1:1:$L(MIG," ") S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " S ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P(MIG," ",SG) D
..I $E(^TMP("PSOPO",$J,IEN,0),$L(^TMP("PSOPO",$J,IEN,0)))=" " S ^TMP("PSOPO",$J,IEN,0)=$E(^TMP("PSOPO",$J,IEN,0),1,($L(^TMP("PSOPO",$J,IEN,0))-1))
S:$O(SIG(0)) SIGOK=1 K MIG
F D=0:0 S D=$O(^PS(52.41,ORD,"INS1",D)) Q:'D S PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORFI2 11034 printed Dec 13, 2024@02:32 Page 2
PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;07/29/96
+1 ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,225,338,313,408,612**;DEC 1997;Build 23
+2 ;External reference ^YSCL(603.01 supported by DBIA 2697
+3 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+4 ;External reference to EN1^ORCFLAG is supported by DBIA 3620
HLP WRITE !,"Enter 'S' to process orders with a priority of STAT",!," 'E' to process orders with an Emergency priority,",!," 'R' to process Routine orders.",!
QUIT
HELP ;
+1 WRITE !,"Please enter a minimum of two (2) characters.",!,"Enter Patient's name whose med orders are to be completed.",!
+2 SET (PATN,DPT)=0
FOR
SET DPT=$ORDER(^PS(52.41,"AOR",DPT))
if 'DPT
QUIT
IF $DATA(^PS(52.41,"AOR",DPT,PSOPINST))
WRITE !,$PIECE(^DPT(DPT,0),"^")
SET PATN=PATN+1
IF PATN=20
Begin DoDot:1
+3 KILL DIR,DUOUT,DTOUT,DIRUT
SET DIR(0)="E"
DO ^DIR
SET PATN=0
KILL DIR
End DoDot:1
IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO HELPX
HELPX KILL DTOUT,DUOUT,DIRUT,PAINST
SET DIR(0)="FO^2:30"
SET DIR("A")="Select Patient"
SET DIR("?")="^D HELP^PSOORFIN"
+1 KILL PATN,DPT
QUIT
RTE ;
+1 SET PSZFIN=1
+2 FOR PSZFZZ=0:0
SET PSZFZZ=$ORDER(^PS(52.41,"AC",PAT,$EXTRACT(PSRT),PSZFZZ))
if 'PSZFZZ!('PSZFIN)
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($PIECE($GET(^(0)),"^",3)="RNW")!($PIECE($GET(^(0)),"^",3)="RF")
IF $PIECE($GET(^PS(52.41,PSZFZZ,"INI")),"^")=$GET(PSOPINST)
SET PSZFIN=0
End DoDot:1
+4 QUIT
PRI ;
+1 SET PSZFIN=1
+2 FOR PSZFZZ=0:0
SET PSZFZZ=$ORDER(^PS(52.41,"AP",PAT,$EXTRACT(PSRT),PSZFZZ))
if 'PSZFZZ!('PSZFIN)
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($PIECE($GET(^(0)),"^",3)="RNW")!($PIECE($GET(^(0)),"^",3)="RF")
IF $PIECE($GET(^PS(52.41,PSZFZZ,"INI")),"^")=$GET(PSOPINST)
SET PSZFIN=0
End DoDot:1
+4 QUIT
PROFILE ;display med profile
+1 ;3=question asked already
SET MEDA=3
+2 WRITE !!!
KILL MEDP,DIR,DUOUT,DIRUT,DTOUT
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Do you want to see Medication Profile"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
QUIT
+3 IF Y
SET MEDP=1
+4 KILL DIR,DUOUT,DIRUT,DTOUT
+5 QUIT
DC IF '$GET(PSOORRNW)
IF $GET(PSOOPT)=3
SET PSORENW("DFLG")=1
if '$DATA(PSOBBC1("FROM"))
SET VALMBCK="Q"
SET VALMSG="Renew Rx Request Canceled."
SET Y=-1
QUIT
+1 GOTO DC^PSOORFI6
+2 QUIT
DE if '$DATA(^PS(52.41,ORD,0))
QUIT
+1 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,ORD,0),"^",2),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$PIECE(^PS(52.41,ORD,0),"^",12),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
+2 SET $PIECE(^PS(52.41,ORD,0),"^",3)="DC"
SET POERR("PLACER")=$PIECE(^(0),"^")
SET POERR("STAT")="OC"
+3 SET POERR("COMM")=$SELECT($GET(POERR("DEAD")):"Patient died on "_$GET(PSOPTPST(2,PSODFN,.351))_".",1:ACOM)
SET $PIECE(^PS(52.41,ORD,4),"^")=POERR("COMM")
+4 DO EN^PSOHLSN(POERR("PLACER"),POERR("STAT"),POERR("COMM"),PSONOOR)
+5 IF '$GET(POERR("DEAD"))
SET DIR("A")="Press Return to Continue"
DO PAUSE^VALM1
+6 KILL PSONOOR,PDORUG,ACOM,CMOP,DEA,DEF,DREN,FDR,HDR,PHI,PRC,SIGOK,DIR,DTOUT,DUOUT,DIRUT
+7 SET Y=-1
QUIT
+8 ;
RF ;process refill request from CPRS
+1 SET PSOREF("IRXN")=$PIECE(OR0,"^",19)
DO PSOL^PSSLOCK($PIECE(OR0,"^",19))
IF '$GET(PSOMSG)
Begin DoDot:1
+2 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE $CHAR(7),!!,$PIECE(PSOMSG,"^",2),!
QUIT
+3 WRITE $CHAR(7),!!,"Another person is editing Rx "_$PIECE(^PSRX($PIECE(OR0,"^",19),0),"^"),!
End DoDot:1
DO PAUSE^VALM1
KILL PSOREF,PSOMSG
QUIT
+4 ;
+5 DO FULL^VALM1
+6 IF '$PIECE($GET(^PS(52.41,ORD,0)),"^",23)
IF +$GET(^PS(52.41,ORD,"FLG"))
Begin DoDot:1
+7 KILL DIRUT,DUOUT,DTOUT,DIR
+8 SET DIR("A",1)="Flagged by "_$$GET1^DIQ(52.41,ORD,34)_" on "_$$GET1^DIQ(52.41,ORD,33)_": "_$$GET1^DIQ(52.41,ORD,35)
+9 SET DIR("A",2)=""
+10 SET DIR("A",3)="Unflagged by "_$$GET1^DIQ(52.41,ORD,37)_" on "_$$GET1^DIQ(52.41,ORD,36)_": "_$$GET1^DIQ(52.41,ORD,38)
+11 SET DIR("A",4)=""
+12 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Continue"
+13 WRITE !
DO ^DIR
End DoDot:1
IF $DATA(DIRUT)!'Y
SET VALMBCK="B"
QUIT
+14 ;
+15 IF $GET(ORD)
IF +$PIECE($GET(^PS(52.41,+ORD,0)),"^",23)=1
Begin DoDot:1
+16 KILL DIRUT,DUOUT,DTOUT,DIR
+17 SET DIR("A",1)="This Refill Request is flagged. In order to process it"
+18 SET DIR("A",2)="you must unflag it first."
+19 SET DIR("A",3)=""
+20 SET DIR(0)="Y"
SET DIR("A")="Unflag Refill Request"
SET DIR("B")="NO"
+21 WRITE !
DO ^DIR
IF $DATA(DIRUT)!'Y
SET VALMBCK="B"
End DoDot:1
if $DATA(DIRUT)!'Y
QUIT
DO EN1^ORCFLAG(+$PIECE($GET(^PS(52.41,ORD,0)),"^"))
HANG 1
+22 IF $GET(ORD)
IF +$PIECE($GET(^PS(52.41,+ORD,0)),"^",23)=1
QUIT
+23 ;
+24 IF $$TITRX^PSOUTL(PSOREF("IRXN"))="t"
Begin DoDot:1
+25 WRITE !!,$CHAR(7),"Rx# "_$PIECE(^PSRX($PIECE(OR0,"^",19),0),"^")_" is marked as 'Titration Rx' and cannot be refilled."
End DoDot:1
DO PAUSE^VALM1
KILL PSOREF
QUIT
+26 ;
+27 KILL PSOMSG
SET (PSOREF("DFLG"),PSOREF("FIELD"),PSOREF1)=0
SET X="T-6M"
SET %DT="X"
DO ^%DT
+28 SET (PSOID,PSOREF("ISSUE DATE"))=$SELECT($PIECE(^PSRX(PSOREF("IRXN"),0),"^",13)<Y:Y,1:$PIECE(^PSRX(PSOREF("IRXN"),0),"^",13))
+29 if $GET(PSORX("BAR CODE"))&($GET(PSOBBC1("FROM"))="NEW")
SET PSOREF("ISSUE DATE")=DT
KILL X,X1,X2
+30 ;
+31 SET PSONEW("DAYS SUPPLY")=$PIECE(^PSRX(PSOREF("IRXN"),0),"^",8)
SET PSONEW("# OF REFILLS")=$PIECE(^(0),"^",9)
+32 WRITE !!,"Processing Refill Request for Rx "_$PIECE(^PSRX(PSOREF("IRXN"),0),"^")
+33 DO FILLDT^PSODIR2(.PSOREF)
IF PSOREF("DFLG")
SET VALMBCK="R"
GOTO END
+34 ;
+35 SET PSORX("MAIL/WINDOW")=$SELECT($PIECE(OR0,"^",17)="M":"MAIL",1:"WINDOW")
+36 DO MW^PSODIR2(.PSOREF)
IF PSOREF("DFLG")
SET VALMBCK="R"
GOTO END
+37 KILL PSORX("ADMINCLINIC")
if $PIECE(OR0,"^",17)="C"
SET PSORX("ADMINCLINIC")=1
+38 if '$GET(PSOFROM)'="NEW"
SET PSOFROM="REFILL"
SET PSOREF("DFLG")=0
+39 DO ^PSOREF0
END DO PSOUL^PSSLOCK(PSOREF("IRXN"))
KILL PSOREF,NODE,PSOREF1,PSL,PSOERR,PSORX("QFLG")
+1 QUIT
S DO KPRI
DO KPRIZ
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"S",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
SET PSOSTATZ=1
+1 if $GET(POERR("QFLG"))
DO KPRI
if $GET(POERR("QFLG"))
QUIT
IF $GET(PSOSTATZ)
SET ORD=0
Begin DoDot:1
+2 DO KPRIZ
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"E",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
+3 if $GET(POERR("QFLG"))
QUIT
+4 DO KPRIZ
SET ORD=0
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"R",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
End DoDot:1
+5 DO KPRI
+6 QUIT
E DO KPRI
DO KPRIZ
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"E",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
SET PSOEMERZ=1
+1 if $GET(POERR("QFLG"))
DO KPRI
if $GET(POERR("QFLG"))
QUIT
IF $GET(PSOEMERZ)
SET ORD=0
Begin DoDot:1
+2 DO KPRIZ
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"S",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
+3 if $GET(POERR("QFLG"))
QUIT
+4 DO KPRIZ
SET ORD=0
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"R",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
End DoDot:1
+5 DO KPRI
+6 QUIT
R DO KPRI
DO KPRIZ
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"R",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
SET PSOROUTZ=1
+1 if $GET(POERR("QFLG"))
DO KPRI
if $GET(POERR("QFLG"))
QUIT
IF $GET(PSOROUTZ)
SET ORD=0
Begin DoDot:1
+2 DO KPRIZ
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"E",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
+3 if $GET(POERR("QFLG"))
QUIT
+4 DO KPRIZ
SET ORD=0
FOR
SET ORD=$ORDER(^PS(52.41,"AP",PAT,"S",ORD))
if 'ORD!($GET(POERR("QFLG")))
QUIT
IF $PIECE(^PS(52.41,ORD,0),"^",3)'="DC"
IF $PIECE(^(0),"^",3)'="DE"
DO LOCK1^PSOORFI1
DO ORD^PSOORFIN
End DoDot:1
+5 DO KPRI
+6 QUIT
KPRI KILL PSOSTATZ,PSOROUTZ,PSOEMERZ
+1 QUIT
KPRIZ KILL PSOQUIT,POERR("QFLG")
+1 QUIT
INST ;Select Institution
+1 NEW PSOCNT
+2 IF '$GET(PSOSITE)
DO ^PSOLSET
IF '$GET(PSOSITE)
SET PSOIQUIT=1
QUIT
+3 NEW PSIR,PSCT,PSINST
KILL PSOPINST
+4 SET PSCT=0
FOR PSIR=0:0
SET PSIR=$ORDER(^PS(59,PSOSITE,"INI1",PSIR))
if 'PSIR
QUIT
IF $PIECE($GET(^PS(59,PSOSITE,"INI1",PSIR,0)),"^")
SET PSCT=PSCT+1
IF PSCT=1
SET PSOPINST=$PIECE($GET(^(0)),"^")
+5 IF PSCT=0
WRITE !!,"There are no CPRS Ordering Institutions associated with this Outpatient site!",!,"Use the Site Parameter enter/edit option to enter CPRS Ordering Institutions!",!
SET PSOIQUIT=1
QUIT
+6 IF PSCT=1
DO INSTNM
GOTO INSTA
+7 WRITE !!!,"There are multiple Institutions associated with this Outpatient Site for",!,"finishing orders entered through CPRS. Select the Institution for which to",!,"finish orders from. Enter '?' to see all choices.",!
+8 KILL PSOPNAME
if $GET(PSOPINST)
Begin DoDot:1
+9 KILL ^UTILITY("DIQ1",$JOB),DIQ
SET DA=$GET(PSOPINST)
SET DIC=4
SET DIQ(0)="E"
SET DR=".01"
DO EN^DIQ1
SET PSOPNAME=$GET(^UTILITY("DIQ1",$JOB,4,DA,.01,"E"))
KILL ^UTILITY("DIQ1",$JOB),DA,DR,DIC,DIQ
End DoDot:1
KILL DIC
SET DIC(0)="AEQMZ"
SET DIC="^PS(59,"_PSOSITE_",""INI1"","
if $GET(PSOPNAME)'=""
SET DIC("B")=$GET(PSOPNAME)
DO ^DIC
KILL DIC,PSOPNAME
IF Y<1
WRITE !!,"No Institution selected",!
SET PSOIQUIT=1
QUIT
+10 WRITE !
SET PSOPINST=$PIECE(Y,"^",2)
KILL Y
+11 DO INSTNM
WRITE !,"You have selected "_$GET(PSODINST)_"."
+12 WRITE !,"After completing these orders, you may re-enter this option and select again."
INSTA ;
+1 SET PSOCNT=$$CNT(PSOPINST)
+2 IF '$DATA(IOINORM)!('$DATA(IOINHI))
SET X="IORVOFF;IORVON;IOINHI;IOINORM"
DO ENDR^%ZISS
+3 WRITE !!?7,IORVON_IOINHI,"<There ",$SELECT(PSOCNT=1:"is ",1:"are "),$SELECT(PSOCNT>0:PSOCNT,1:"no")," flagged order",$SELECT(PSOCNT=1:"",1:"s")," for ",PSODINST,">",IOINORM_IORVOFF,!
+4 KILL PSODINST
+5 QUIT
+6 ;
CNT(SITE) ; - Counter for flagged pending orders by Site
+1 NEW CNT,ORD
+2 KILL ^TMP($JOB,"PSOFLPO")
+3 SET (CNT,LOGIN,ORD)=0
+4 FOR
SET LOGIN=$ORDER(^PS(52.41,"AD",LOGIN))
if 'LOGIN
QUIT
Begin DoDot:1
+5 FOR
SET ORD=$ORDER(^PS(52.41,"AD",LOGIN,SITE,ORD))
if 'ORD
QUIT
Begin DoDot:2
+6 IF $PIECE(^PS(52.41,ORD,0),"^",3)="DC"!($PIECE(^PS(52.41,ORD,0),"^",3)="DE")
QUIT
+7 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
SET CNT=CNT+1
if $PIECE(^(0),"^",2)
SET ^TMP($JOB,"PSOFLPO",$PIECE(^(0),"^",2))=""
End DoDot:2
End DoDot:1
+8 QUIT CNT
+9 ;
INST1 ;
+1 KILL PSOPINST
NEW PSIR
+2 FOR PSIR=0:0
SET PSIR=$ORDER(^PS(59,PSOSITE,"INI1",PSIR))
if 'PSIR!($GET(PSOPINST))
QUIT
IF $PIECE($GET(^PS(59,PSOSITE,"INI1",PSIR,0)),"^")
SET PSOPINST=$PIECE($GET(^(0)),"^")
+3 QUIT
CLOZ ;checks clozapine status of patient
+1 ; BEGIN - JCH: PSO*7*612
+2 ;S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0))
+3 SET CLOZPAT=$$GETREGYS^PSOCLUTL(PSODFN)
+4 ; END - JCH: PSO*7*612
+5 SET CLOZPAT=$PIECE($GET(^YSCL(603.01,+CLOZPAT,0)),"^",3)
+6 SET CLOZPAT=$SELECT(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
+7 if '$DATA(PSONEW("# OF REFILLS"))
SET (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0
+8 QUIT
ELIG IF $GET(CLOZPAT)=1
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Patient Eligible for 14 Day Supply or 7 Day Supply with 1 refill"
+1 IF $GET(CLOZPAT)=2
SET IEN=IEN+1
SET ^TMP("PSOPO",$JOB,IEN,0)=" Patient Eligible for 28 Day Supply or 14 Day Supply with 1 refill or 7 Day Supply with 3 refill"
+2 QUIT
USER(USER) ;returns .01 of 200
+1 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="M"
SET X="`"_USER
DO ^DIC
SET USER1=$SELECT(+Y:$PIECE(Y,"^",2),1:"Unknown")
KILL DIC,X,Y
+2 QUIT
INSTNM ;
+1 KILL PSOFINDA,PSODINST
IF $GET(DA)
SET PSOFINDA=$GET(DA)
+2 KILL PSODNM
SET DA=$GET(PSOPINST)
IF DA
SET DIC=4
SET DIQ(0)="E"
SET DR=".01"
SET DIQ="PSODNM"
DO EN^DIQ1
SET PSODINST=$GET(PSODNM(4,DA,.01,"E"))
KILL PSODNM,DIC,DR,DA
+3 IF $GET(PSOFINDA)
SET DA=$GET(PSOFINDA)
KILL PSOFINDA
+4 QUIT
POST SET PSOFINY=$GET(Y)
DO ^PSOBUILD
SET Y=$GET(PSOFINY)
KILL PSOFINY
DO OERR^PSORX1
IF $GET(PSOQUIT)
QUIT
+1 KILL PSOQFLG
FOR PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY"
SET RTN=PT_"^PSOPTPST"
DO @RTN
KILL PSOXFLG
if $GET(POERR("DEAD"))!($GET(PSOQFLG))
QUIT
+2 IF $GET(POERR("DEAD"))
SET POERR("QFLG")=1
QUIT
+3 KILL PSOERR("DEAD")
IF $GET(PSOQFLG)
QUIT
+4 DO ^PSOORUT2
DO BLD^PSOORUT1
DO EN^PSOLMUTL
+5 QUIT
SIG ;
+1 SET SIG=0
SET PSOFINFL=1
FOR
SET SIG=$ORDER(^PS(52.41,ORD,"SIG",SIG))
if 'SIG
QUIT
Begin DoDot:1
+2 SET (MIG,SIG(SIG))=^PS(52.41,ORD,"SIG",SIG,0)
+3 FOR SG=1:1:$LENGTH(MIG," ")
if $LENGTH(^TMP("PSOPO",$JOB,IEN,0)_" "_$PIECE(MIG," ",SG))>80
SET IEN=IEN+1
SET $PIECE(^TMP("PSOPO",$JOB,IEN,0)," ",20)=" "
SET ^TMP("PSOPO",$JOB,IEN,0)=$GET(^TMP("PSOPO",$JOB,IEN,0))_" "_$PIECE(MIG," ",SG)
Begin DoDot:2
+4 IF $EXTRACT(^TMP("PSOPO",$JOB,IEN,0),$LENGTH(^TMP("PSOPO",$JOB,IEN,0)))=" "
SET ^TMP("PSOPO",$JOB,IEN,0)=$EXTRACT(^TMP("PSOPO",$JOB,IEN,0),1,($LENGTH(^TMP("PSOPO",$JOB,IEN,0))-1))
End DoDot:2
End DoDot:1
+5 if $ORDER(SIG(0))
SET SIGOK=1
KILL MIG
+6 FOR D=0:0
SET D=$ORDER(^PS(52.41,ORD,"INS1",D))
if 'D
QUIT
SET PSONEW("INS",D)=^PS(52.41,ORD,"INS1",D,0)
+7 QUIT
