Routine: PSOORFI2

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

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

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

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

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")

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

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

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

KPRI K PSOSTATZ,PSOROUTZ,PSOEMERZ

KPRIZ K PSOQUIT,POERR("QFLG")

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

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)),"^")

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

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"

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

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

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

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)

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

PSOORFI2.m