PSOCIDC3.m

PSOCIDC3 ;BIR/LE - continuation of Copay Correction of erroneous billed copays ;29-May-2012 14:42;PLS

 ;;7.0;OUTPATIENT PHARMACY;**226,1015**;DEC 1997;Build 62

 ;

 ;Modified - IHS/MSC/PLS - 06/01/2010 - Lines CHK+1, START+29, START+55

RPT ;

 N JOBN,NAMSP,ZTDESC,ZTRTN

 S NAMSP=$$NAMSP^PSOCIDC1

 S JOBN="Copay Corrections"

 L +^XTMP(NAMSP):0 I '$T D  Q

 .W !,JOBN_" job for PSO*7*226 is still running.  Halting..."

 L -^XTMP(NAMSP)

 W !!,"This report shows the patient name and prescription information for"

 W !,"copay field corrections and copays billed erroneously that were cancelled"

 W !,"by the patch PSO*7*226."

 ;

 W !!,"You may queue the report to print, if you wish.",!

 ;

DVC K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE

QUEUE I $D(IO("Q")) S ZTRTN="START^PSOCIDC3",ZTDESC=JOBN_" copay cancellation report" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE

START ;

 U IO

 N BLDT,RXO,NAMSP,PSOFILL,PSODFN,PSONAM,PSOOUT,PSODV,RXP,SSN,PSODIV,PSODV

 N CANCEL,JOBN,PSOPATID,PSOTOT,PSOTOTC

 S NAMSP=$$NAMSP^PSOCIDC1

 S JOBN="Copay Corrections"

 S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")

 S PSOPGCT=0,PSOPGLN=IOSL-7,PSOPGCT=1

 S BLDT=$P($G(^XTMP(NAMSP,0,"LAST")),"^",2)

 I '$D(DT) S DT=$$NOW^XLFDT

 D TITLE

 S (PSOTOT,PSOTOTC,PSONAM)=""

 F  S PSONAM=$O(^XTMP(NAMSP,"REL",PSONAM)) Q:PSONAM=""  D

 .S PSODFN=""

 .F  S PSODFN=$O(^XTMP(NAMSP,"REL",PSONAM,PSODFN)) Q:PSODFN=""  D

 ..S RXP=""

 ..F  S RXP=$O(^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP)) Q:RXP=""  D

 ...S PSOFILL=""

 ...F  S PSOFILL=$O(^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOFILL)) Q:PSOFILL=""  D

 ....N XX,RXO,Y,PSONAME

 ....S XX=$G(^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOFILL)) D   ;NOTE THIS IS THE RELEASE DATE

 .....D FULL Q:$G(PSOOUT)  S PSONAME=$P($G(^DPT(PSODFN,0)),"^")

 .....S CANCEL="" I $D(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,PSOFILL)) D CHK S:CANCEL PSOTOTC=PSOTOTC+1

 .....W !,$S(CANCEL:"*",1:"") W:CANCEL $E(PSONAME,1,14) W:'CANCEL ?1,$E(PSONAME,1,14)

 .....D PRTSSN

 .....S RXO=$P($G(^PSRX(RXP,0)),"^")

 .....W ?41," ",RXO," (",PSOFILL,")"

 .....S Y=XX I Y>0 X ^DD("DD")

 .....W ?55," ",Y

 .....;IHS/MSC/PLS - 06/01/2010 - Next two lines commented out

 .....;W ?69,$S($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")

 .....;W ?75,$S($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")

 .....S PSOTOT=PSOTOT+1

 W !!,"Total number of released prescriptions modified: ",PSOTOT

 W !,"Total number of Cancelled Copay prescriptions: ",PSOTOTC

 ;

 ;UNRELEASED CORRECTED RX'S

 D TITLE2

 S (PSOTOT,PSONAM)=""

 F  S PSONAM=$O(^XTMP(NAMSP,"IBQ UPD",PSONAM)) Q:PSONAM=""  D

 .S PSODFN=""

 .F  S PSODFN=$O(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN)) Q:PSODFN=""  D

 ..S RXP=""

 ..F  S RXP=$O(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP)) Q:RXP=""  D

 ...S PSOFILL=""

 ...F  S PSOFILL=$O(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOFILL)) Q:PSOFILL=""  D

 ....N XX,RXO,Y,PSONAME

 ....S XX=$G(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOFILL)) D  ;NOTE THIS IS THE FILL DATE

 .....D FULL Q:$G(PSOOUT)  S PSONAME=$P($G(^DPT(PSODFN,0)),"^")

 .....W !,$E(PSONAME,1,14)

 .....D PRTSSN

 .....S RXO=$P($G(^PSRX(RXP,0)),"^")

 .....W ?41," ",RXO," (",PSOFILL,")"

 .....S Y=XX I Y>0 X ^DD("DD")

 .....W ?55," ",Y

 .....;IHS/MSC/PLS - 06/01/2010 - Next two lines commented out

 .....;W ?69,$S($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")

 .....;W ?75,$S($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")

 .....S PSOTOT=PSOTOT+1

 W !!,"Total number of un-released prescriptions modified: ",PSOTOT

 G END

 ;

FULL ;

 I ($Y+7)>IOSL&('$G(PSOOUT)) D TITLE

 Q

 ;

CHK ;VERIFY COPAY WAS CANCELLED

 Q  ;IHS/MSC/PLS - 06/01/2010

 N IBN,PSOREF,PSOIB,XX S PSOREF=PSOFILL

 I PSOREF=0 S XX=$G(^PSRX(RXP,"IB")),IBN=$P(XX,"^",2)

 I PSOREF>0 S XX=$G(^PSRX(RXP,1,PSOREF,"IB")),IBN=$P(XX,"^",1)

 S XX=$$STATUS^IBARX(IBN)

 S:$G(XX)=2 CANCEL=1

 Q

 ;

TITLE ;

 I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q

 ;

 W @IOF D

 . W !,"Patch PSO*7*226 -Corrected Released Prescriptions "

 . W !!,"Note that prescriptions where copay was cancelled are denoted with"

 . W !,"an asterisk (*) in front of the patient name.  Otherwise, only  the"

 . W !,"the IBQ node was updated.",!

 S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!

 F MJT=1:1:79 W "="

 W !,?69,"INS ON DTE"

 W !,"PATIENT NAME     (SSN)       DIV",?42,"RX# (FILL)",?55,"RELEASE DATE",?69,"REL   BILL"

 W !,"---------------  -------  --------------",?42,"------------"

 W ?55,"------------",?69,"---- -----"

 S PSOPGCT=PSOPGCT+1

 Q

TITLE2 ;

 I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q

 ;

 W @IOF D

 . W !,"Patch PSO*7*226 -Corrected Unreleased Prescriptions "

 S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!

 F MJT=1:1:79 W "="

 W !,?69,"INS ON DTE"

 W !,"PATIENT NAME     (SSN)       DIV",?43,"RX# (FILL)",?55,"FILL DATE",?69,"REL   BILL"

 W !,"--------------  -------  ----------------",?42,"------------"

 W ?55,"------------",?69,"---- -----"

 S PSOPGCT=PSOPGCT+1

 Q

END ;

 I '$G(PSOOUT),$G(PSODV)="C" W !!,"** End of Report **" K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR

 I $G(PSODV)="C" W !

 E  W @IOF

DONE ;

 K MJT,PSOPGCT,PSOPGLN,Y,DIR,X,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT

 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"

 Q

 ;

PRTSSN ;

 S SSN=$P(^DPT(PSODFN,0),"^",9),SSN=$E(SSN,$L(SSN)-3,$L(SSN))

 S PSOPATID=$E(PSONAM,1)_SSN

 S PSODIV=$P($G(^PSRX(RXP,2)),"^",9)

 S:PSODIV'="" PSODIV=$P($G(^PS(59,PSODIV,0)),"^",1)

 W ?17,"("_PSOPATID_")"_"  "_$E(PSODIV,1,15)

 Q

 ;

ETIME(SECTIME) ;convert seconds to day:hr:min:sec

 N DAY,HR,MIN,SEC,ETIM

 S (DAY,HR,MIN,SEC)=""

 I SECTIME>86400 S DAY=SECTIME\86400,SECTIME=SECTIME#86400

 I SECTIME>3600 S HR=SECTIME\3600,SECTIME=SECTIME#3600

 I SECTIME>60 S MIN=SECTIME\60,SECTIME=SECTIME#60

 S SEC=SECTIME

 S ETIM=""

 S:$L(HR)=1 HR=0_HR S:$L(MIN)=1 MIN=0_MIN S:$L(SEC)=1 SEC=0_SEC

 S:DAY ETIM=DAY_" Day " S:HR ETIM=ETIM_HR_":" S:MIN ETIM=ETIM_MIN

 S ETIM=ETIM_":"_SEC

 Q ETIM

 ;

MAIL3(MSG) ;management mail message

 S PSOINST=$P($G(^DIC(4,+$P($G(^XMB(1,1,"XUS")),"^",17),99)),"^")

 D NOW^%DTC S Y=% D DD^%DT S PSOEND=Y

 K PSOTEXT

 S XMY(DUZ)=""

 S XMY("ELLZEY.LINDA@FORUM.VA.GOV")=""

 S:$$PROD^XUPROD(1) XMY("ELLZEY.LINDA@FORUM.VA.GOV")=""

 S XMDUZ="PSO*7*226 "_JOBN

 S XMSUB="STATION "_$G(PSOINST)

 S XMSUB=XMSUB_$S($$PROD^XUPROD(1):" (Prod)",1:" (Test)")

 S XMSUB=XMSUB_" CANCELLED COPAYS FOR ERRONEOUSLY BILLED PRESCRIPTION FILLS"

 S PSOTEXT(1)=""

 S PSOTEXT(2)="Started "_PSOSTART

 S PSOTEXT(3)=""

 S PSOTEXT(4)="   "_MSG

 S PSOTEXT(5)=""

 S PSOTEXT(6)="NO FURTHER ACTION REQUIRED."

 S XMTEXT="PSOTEXT(" N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB

 Q

 ;

PSOCIDC3  ;BIR/LE - continuation of Copay Correction of erroneous billed copays ;29-May-2012 14:42;PLS

 +1       ;;7.0;OUTPATIENT PHARMACY;**226,1015**;DEC 1997;Build 62

 +2       ;

 +3       ;Modified - IHS/MSC/PLS - 06/01/2010 - Lines CHK+1, START+29, START+55

RPT       ;

 +1        NEW JOBN,NAMSP,ZTDESC,ZTRTN

 +2        SET NAMSP=$$NAMSP^PSOCIDC1

 +3        SET JOBN="Copay Corrections"

 +4        LOCK +^XTMP(NAMSP):0

           IF '$TEST

               Begin DoDot:1

 +5                WRITE !,JOBN_" job for PSO*7*226 is still running.  Halting..."

               End DoDot:1

               QUIT 

 +6        LOCK -^XTMP(NAMSP)

 +7        WRITE !!,"This report shows the patient name and prescription information for"

 +8        WRITE !,"copay field corrections and copays billed erroneously that were cancelled"

 +9        WRITE !,"by the patch PSO*7*226."

 +10      ;

 +11       WRITE !!,"You may queue the report to print, if you wish.",!

 +12      ;

DVC        KILL %ZIS,POP,IOP

           SET %ZIS="QM"

           DO ^%ZIS

           IF $GET(POP)

               WRITE !!,"Nothing queued to print.",!

               GOTO DONE

QUEUE      IF $DATA(IO("Q"))

               SET ZTRTN="START^PSOCIDC3"

               SET ZTDESC=JOBN_" copay cancellation report"

               DO ^%ZTLOAD

               KILL %ZSI

               WRITE !,"Report queued to print.",!

               GOTO DONE

START     ;

 +1        USE IO

 +2        NEW BLDT,RXO,NAMSP,PSOFILL,PSODFN,PSONAM,PSOOUT,PSODV,RXP,SSN,PSODIV,PSODV

 +3        NEW CANCEL,JOBN,PSOPATID,PSOTOT,PSOTOTC

 +4        SET NAMSP=$$NAMSP^PSOCIDC1

 +5        SET JOBN="Copay Corrections"

 +6        SET PSOOUT=0

           SET PSODV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")

 +7        SET PSOPGCT=0

           SET PSOPGLN=IOSL-7

           SET PSOPGCT=1

 +8        SET BLDT=$PIECE($GET(^XTMP(NAMSP,0,"LAST")),"^",2)

 +9        IF '$DATA(DT)

               SET DT=$$NOW^XLFDT

 +10       DO TITLE

 +11       SET (PSOTOT,PSOTOTC,PSONAM)=""

 +12       FOR 

               SET PSONAM=$ORDER(^XTMP(NAMSP,"REL",PSONAM))

               IF PSONAM=""

                   QUIT 

               Begin DoDot:1

 +13               SET PSODFN=""

 +14               FOR 

                       SET PSODFN=$ORDER(^XTMP(NAMSP,"REL",PSONAM,PSODFN))

                       IF PSODFN=""

                           QUIT 

                       Begin DoDot:2

 +15                       SET RXP=""

 +16                       FOR 

                               SET RXP=$ORDER(^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP))

                               IF RXP=""

                                   QUIT 

                               Begin DoDot:3

 +17                               SET PSOFILL=""

 +18                               FOR 

                                       SET PSOFILL=$ORDER(^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOFILL))

                                       IF PSOFILL=""

                                           QUIT 

                                       Begin DoDot:4

 +19                                       NEW XX,RXO,Y,PSONAME

 +20      ;NOTE THIS IS THE RELEASE DATE

                                           SET XX=$GET(^XTMP(NAMSP,"REL",PSONAM,PSODFN,RXP,PSOFILL))

                                           Begin DoDot:5

 +21                                           DO FULL

                                               IF $GET(PSOOUT)

                                                   QUIT 

                                               SET PSONAME=$PIECE($GET(^DPT(PSODFN,0)),"^")

 +22                                           SET CANCEL=""

                                               IF $DATA(^XTMP(NAMSP,"CANCEL",PSODFN,RXP,PSOFILL))

                                                   DO CHK

                                                   IF CANCEL

                                                       SET PSOTOTC=PSOTOTC+1

 +23                                           WRITE !,$SELECT(CANCEL:"*",1:"")

                                               IF CANCEL

                                                   WRITE $EXTRACT(PSONAME,1,14)

                                               IF 'CANCEL

                                                   WRITE ?1,$EXTRACT(PSONAME,1,14)

 +24                                           DO PRTSSN

 +25                                           SET RXO=$PIECE($GET(^PSRX(RXP,0)),"^")

 +26                                           WRITE ?41," ",RXO," (",PSOFILL,")"

 +27                                           SET Y=XX

                                               IF Y>0

                                                   XECUTE ^DD("DD")

 +28                                           WRITE ?55," ",Y

 +29      ;IHS/MSC/PLS - 06/01/2010 - Next two lines commented out

 +30      ;W ?69,$S($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")

 +31      ;W ?75,$S($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")

 +32                                           SET PSOTOT=PSOTOT+1

                                           End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +33       WRITE !!,"Total number of released prescriptions modified: ",PSOTOT

 +34       WRITE !,"Total number of Cancelled Copay prescriptions: ",PSOTOTC

 +35      ;

 +36      ;UNRELEASED CORRECTED RX'S

 +37       DO TITLE2

 +38       SET (PSOTOT,PSONAM)=""

 +39       FOR 

               SET PSONAM=$ORDER(^XTMP(NAMSP,"IBQ UPD",PSONAM))

               IF PSONAM=""

                   QUIT 

               Begin DoDot:1

 +40               SET PSODFN=""

 +41               FOR 

                       SET PSODFN=$ORDER(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN))

                       IF PSODFN=""

                           QUIT 

                       Begin DoDot:2

 +42                       SET RXP=""

 +43                       FOR 

                               SET RXP=$ORDER(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP))

                               IF RXP=""

                                   QUIT 

                               Begin DoDot:3

 +44                               SET PSOFILL=""

 +45                               FOR 

                                       SET PSOFILL=$ORDER(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOFILL))

                                       IF PSOFILL=""

                                           QUIT 

                                       Begin DoDot:4

 +46                                       NEW XX,RXO,Y,PSONAME

 +47      ;NOTE THIS IS THE FILL DATE

                                           SET XX=$GET(^XTMP(NAMSP,"IBQ UPD",PSONAM,PSODFN,RXP,PSOFILL))

                                           Begin DoDot:5

 +48                                           DO FULL

                                               IF $GET(PSOOUT)

                                                   QUIT 

                                               SET PSONAME=$PIECE($GET(^DPT(PSODFN,0)),"^")

 +49                                           WRITE !,$EXTRACT(PSONAME,1,14)

 +50                                           DO PRTSSN

 +51                                           SET RXO=$PIECE($GET(^PSRX(RXP,0)),"^")

 +52                                           WRITE ?41," ",RXO," (",PSOFILL,")"

 +53                                           SET Y=XX

                                               IF Y>0

                                                   XECUTE ^DD("DD")

 +54                                           WRITE ?55," ",Y

 +55      ;IHS/MSC/PLS - 06/01/2010 - Next two lines commented out

 +56      ;W ?69,$S($$PTCOV^IBCNSU3(PSODFN,XX,"PHARMACY"):"YES",1:" NO")

 +57      ;W ?75,$S($$PTCOV^IBCNSU3(PSODFN,BLDT,"PHARMACY"):"YES",1:" NO")

 +58                                           SET PSOTOT=PSOTOT+1

                                           End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +59       WRITE !!,"Total number of un-released prescriptions modified: ",PSOTOT

 +60       GOTO END

 +61      ;

FULL      ;

 +1        IF ($Y+7)>IOSL&('$GET(PSOOUT))

               DO TITLE

 +2        QUIT 

 +3       ;

CHK       ;VERIFY COPAY WAS CANCELLED

 +1       ;IHS/MSC/PLS - 06/01/2010

           QUIT 

 +2        NEW IBN,PSOREF,PSOIB,XX

           SET PSOREF=PSOFILL

 +3        IF PSOREF=0

               SET XX=$GET(^PSRX(RXP,"IB"))

               SET IBN=$PIECE(XX,"^",2)

 +4        IF PSOREF>0

               SET XX=$GET(^PSRX(RXP,1,PSOREF,"IB"))

               SET IBN=$PIECE(XX,"^",1)

 +5        SET XX=$$STATUS^IBARX(IBN)

 +6        IF $GET(XX)=2

               SET CANCEL=1

 +7        QUIT 

 +8       ;

TITLE     ;

 +1        IF $GET(PSODV)="C"

               IF $GET(PSOPGCT)'=1

                   WRITE !

                   KILL DIR

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET PSOOUT=1

                       QUIT 

 +2       ;

 +3        WRITE @IOF

           Begin DoDot:1

 +4            WRITE !,"Patch PSO*7*226 -Corrected Released Prescriptions "

 +5            WRITE !!,"Note that prescriptions where copay was cancelled are denoted with"

 +6            WRITE !,"an asterisk (*) in front of the patient name.  Otherwise, only  the"

 +7            WRITE !,"the IBQ node was updated.",!

           End DoDot:1

 +8        SET Y=DT

           XECUTE ^DD("DD")

           WRITE !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!

 +9        FOR MJT=1:1:79

               WRITE "="

 +10       WRITE !,?69,"INS ON DTE"

 +11       WRITE !,"PATIENT NAME     (SSN)       DIV",?42,"RX# (FILL)",?55,"RELEASE DATE",?69,"REL   BILL"

 +12       WRITE !,"---------------  -------  --------------",?42,"------------"

 +13       WRITE ?55,"------------",?69,"---- -----"

 +14       SET PSOPGCT=PSOPGCT+1

 +15       QUIT 

TITLE2    ;

 +1        IF $GET(PSODV)="C"

               IF $GET(PSOPGCT)'=1

                   WRITE !

                   KILL DIR

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET PSOOUT=1

                       QUIT 

 +2       ;

 +3        WRITE @IOF

           Begin DoDot:1

 +4            WRITE !,"Patch PSO*7*226 -Corrected Unreleased Prescriptions "

           End DoDot:1

 +5        SET Y=DT

           XECUTE ^DD("DD")

           WRITE !,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!

 +6        FOR MJT=1:1:79

               WRITE "="

 +7        WRITE !,?69,"INS ON DTE"

 +8        WRITE !,"PATIENT NAME     (SSN)       DIV",?43,"RX# (FILL)",?55,"FILL DATE",?69,"REL   BILL"

 +9        WRITE !,"--------------  -------  ----------------",?42,"------------"

 +10       WRITE ?55,"------------",?69,"---- -----"

 +11       SET PSOPGCT=PSOPGCT+1

 +12       QUIT 

END       ;

 +1        IF '$GET(PSOOUT)

               IF $GET(PSODV)="C"

                   WRITE !!,"** End of Report **"

                   KILL DIR

                   SET DIR(0)="E"

                   SET DIR("A")="Press Return to continue"

                   DO ^DIR

                   KILL DIR

 +2        IF $GET(PSODV)="C"

               WRITE !

 +3       IF '$TEST

               WRITE @IOF

DONE      ;

 +1        KILL MJT,PSOPGCT,PSOPGLN,Y,DIR,X,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT

 +2        DO ^%ZISC

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        QUIT 

 +4       ;

PRTSSN    ;

 +1        SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)

           SET SSN=$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))

 +2        SET PSOPATID=$EXTRACT(PSONAM,1)_SSN

 +3        SET PSODIV=$PIECE($GET(^PSRX(RXP,2)),"^",9)

 +4        IF PSODIV'=""

               SET PSODIV=$PIECE($GET(^PS(59,PSODIV,0)),"^",1)

 +5        WRITE ?17,"("_PSOPATID_")"_"  "_$EXTRACT(PSODIV,1,15)

 +6        QUIT 

 +7       ;

ETIME(SECTIME) ;convert seconds to day:hr:min:sec

 +1        NEW DAY,HR,MIN,SEC,ETIM

 +2        SET (DAY,HR,MIN,SEC)=""

 +3        IF SECTIME>86400

               SET DAY=SECTIME\86400

               SET SECTIME=SECTIME#86400

 +4        IF SECTIME>3600

               SET HR=SECTIME\3600

               SET SECTIME=SECTIME#3600

 +5        IF SECTIME>60

               SET MIN=SECTIME\60

               SET SECTIME=SECTIME#60

 +6        SET SEC=SECTIME

 +7        SET ETIM=""

 +8        IF $LENGTH(HR)=1

               SET HR=0_HR

           IF $LENGTH(MIN)=1

               SET MIN=0_MIN

           IF $LENGTH(SEC)=1

               SET SEC=0_SEC

 +9        IF DAY

               SET ETIM=DAY_" Day "

           IF HR

               SET ETIM=ETIM_HR_":"

           IF MIN

               SET ETIM=ETIM_MIN

 +10       SET ETIM=ETIM_":"_SEC

 +11       QUIT ETIM

 +12      ;

MAIL3(MSG) ;management mail message

 +1        SET PSOINST=$PIECE($GET(^DIC(4,+$PIECE($GET(^XMB(1,1,"XUS")),"^",17),99)),"^")

 +2        DO NOW^%DTC

           SET Y=%

           DO DD^%DT

           SET PSOEND=Y

 +3        KILL PSOTEXT

 +4        SET XMY(DUZ)=""

 +5        SET XMY("ELLZEY.LINDA@FORUM.VA.GOV")=""

 +6        IF $$PROD^XUPROD(1)

               SET XMY("ELLZEY.LINDA@FORUM.VA.GOV")=""

 +7        SET XMDUZ="PSO*7*226 "_JOBN

 +8        SET XMSUB="STATION "_$GET(PSOINST)

 +9        SET XMSUB=XMSUB_$SELECT($$PROD^XUPROD(1):" (Prod)",1:" (Test)")

 +10       SET XMSUB=XMSUB_" CANCELLED COPAYS FOR ERRONEOUSLY BILLED PRESCRIPTION FILLS"

 +11       SET PSOTEXT(1)=""

 +12       SET PSOTEXT(2)="Started "_PSOSTART

 +13       SET PSOTEXT(3)=""

 +14       SET PSOTEXT(4)="   "_MSG

 +15       SET PSOTEXT(5)=""

 +16       SET PSOTEXT(6)="NO FURTHER ACTION REQUIRED."

 +17       SET XMTEXT="PSOTEXT("

           NEW DIFROM

           DO ^XMD

           KILL XMDUZ,XMTEXT,XMSUB

 +18       QUIT 

 +19      ;