PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;29-May-2012 14:58;PLS
;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,1005,1006,177,222,225,1015**;DEC 1997;Build 62
;External reference ^YSCL(603.01 supported by DBIA 2697
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
; Modified - IHS/MSC/PLS - 05/16/06 - Line RF+18
; 09/25/06 - Line SIG+5
; 10/24/07 - Line RF+19
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
;
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),"^")
;S:$G(PSOREQFD)]"" PSORX("FILL DATE")=PSOREQFD
D FILLDT^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
;S:$G(PSORX("FILL DATE"))]"" PSOREQFD=PSORX("FILL DATE")
;
;S:$G(PSOREQMP)]"" PSORX(" METHOD OF PICK-UP")=PSOREQMP
S PSORX("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"MAIL",1:"WINDOW") D MW^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
;S:$G(PSORX("METHOD OF PICK-UP"))]"" PSOREQMP=PSORX("METHOD OF PICK-UP")
S:'$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0
S PSOREF("CLINIC")=$P(OR0,U,13) ;IHS/MSC/PLS - 05/16/06 - Refill Clinic
S PSOREF("REQ PROVIDER")=$P(OR0,U,5) ;IHS/MSC/PLS - 10/24/07
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 Q
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.",!
S PSOCNT=$$CNT(PSOPINST)
W !," <There ",$S(PSOCNT=1:"is ",1:"are "),$S(PSOCNT>0:PSOCNT,1:"no")," flagged order",$S(PSOCNT=1:"",1:"s")," for ",PSODINST,">",!
K PSODINST
Q
;
CNT(SITE) ; - Counter for flagged pending orders by Site
N CNT,ORD
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
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
S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0))
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))
D EN^PSOFSIG(.PSONEW) ;IHS/MSC/PLS - 09/25/06 - Added to included numerical representation of text value in SIG
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)
;I PSONEW("INS")]"" S X=PSONEW("INS") D SIG^PSOHELP I $G(INS1)]"" S PSONEW("SIG")=$E(INS1,2,9999999)
Q
PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;29-May-2012 14:58;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,1005,1006,177,222,225,1015**;DEC 1997;Build 62
+2 ;External reference ^YSCL(603.01 supported by DBIA 2697
+3 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+4 ; Modified - IHS/MSC/PLS - 05/16/06 - Line RF+18
+5 ; 09/25/06 - Line SIG+5
+6 ; 10/24/07 - Line RF+19
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 KILL PSOMSG
SET (PSOREF("DFLG"),PSOREF("FIELD"),PSOREF1)=0
SET X="T-6M"
SET %DT="X"
DO ^%DT
+25 SET (PSOID,PSOREF("ISSUE DATE"))=$SELECT($PIECE(^PSRX(PSOREF("IRXN"),0),"^",13)<Y:Y,1:$PIECE(^PSRX(PSOREF("IRXN"),0),"^",13))
+26 IF $GET(PSORX("BAR CODE"))&($GET(PSOBBC1("FROM"))="NEW")
SET PSOREF("ISSUE DATE")=DT
KILL X,X1,X2
+27 ;
+28 SET PSONEW("DAYS SUPPLY")=$PIECE(^PSRX(PSOREF("IRXN"),0),"^",8)
SET PSONEW("# OF REFILLS")=$PIECE(^(0),"^",9)
+29 WRITE !!,"Processing Refill Request for Rx "_$PIECE(^PSRX(PSOREF("IRXN"),0),"^")
+30 ;S:$G(PSOREQFD)]"" PSORX("FILL DATE")=PSOREQFD
+31 DO FILLDT^PSODIR2(.PSOREF)
IF PSOREF("DFLG")
SET VALMBCK="R"
GOTO END
+32 ;S:$G(PSORX("FILL DATE"))]"" PSOREQFD=PSORX("FILL DATE")
+33 ;
+34 ;S:$G(PSOREQMP)]"" PSORX(" METHOD OF PICK-UP")=PSOREQMP
+35 SET PSORX("MAIL/WINDOW")=$SELECT($PIECE(OR0,"^",17)="M":"MAIL",1:"WINDOW")
DO MW^PSODIR2(.PSOREF)
IF PSOREF("DFLG")
SET VALMBCK="R"
GOTO END
+36 ;S:$G(PSORX("METHOD OF PICK-UP"))]"" PSOREQMP=PSORX("METHOD OF PICK-UP")
+37 IF '$GET(PSOFROM)'="NEW"
SET PSOFROM="REFILL"
SET PSOREF("DFLG")=0
+38 ;IHS/MSC/PLS - 05/16/06 - Refill Clinic
SET PSOREF("CLINIC")=$PIECE(OR0,U,13)
+39 ;IHS/MSC/PLS - 10/24/07
SET PSOREF("REQ PROVIDER")=$PIECE(OR0,U,5)
+40 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
QUIT
+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.",!
+13 SET PSOCNT=$$CNT(PSOPINST)
+14 WRITE !," <There ",$SELECT(PSOCNT=1:"is ",1:"are "),$SELECT(PSOCNT>0:PSOCNT,1:"no")," flagged order",$SELECT(PSOCNT=1:"",1:"s")," for ",PSODINST,">",!
+15 KILL PSODINST
+16 QUIT
+17 ;
CNT(SITE) ; - Counter for flagged pending orders by Site
+1 NEW CNT,ORD
+2 SET (CNT,LOGIN,ORD)=0
+3 FOR
SET LOGIN=$ORDER(^PS(52.41,"AD",LOGIN))
IF 'LOGIN
QUIT
Begin DoDot:1
+4 FOR
SET ORD=$ORDER(^PS(52.41,"AD",LOGIN,SITE,ORD))
IF 'ORD
QUIT
Begin DoDot:2
+5 IF $PIECE(^PS(52.41,ORD,0),"^",3)="DC"!($PIECE(^PS(52.41,ORD,0),"^",3)="DE")
QUIT
+6 IF $PIECE($GET(^PS(52.41,ORD,0)),"^",23)
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+7 QUIT CNT
+8 ;
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 SET CLOZPAT=$ORDER(^YSCL(603.01,"C",PSODFN,0))
+2 SET CLOZPAT=$PIECE($GET(^YSCL(603.01,+CLOZPAT,0)),"^",3)
+3 SET CLOZPAT=$SELECT(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
+4 IF '$DATA(PSONEW("# OF REFILLS"))
SET (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0
+5 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 ;IHS/MSC/PLS - 09/25/06 - Added to included numerical representation of text value in SIG
DO EN^PSOFSIG(.PSONEW)
+6 IF $ORDER(SIG(0))
SET SIGOK=1
KILL MIG
+7 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)
+8 ;I PSONEW("INS")]"" S X=PSONEW("INS") D SIG^PSOHELP I $G(INS1)]"" S PSONEW("SIG")=$E(INS1,2,9999999)
+9 QUIT
