PSDNMWE ;DOIFO/CMS - CSM No Visits within 12 Months ;18 Dec 02
 ;;3.0; CONTROLLED SUBSTANCES;**41,42**;13 Feb 97
 ;Reference to ^DPT( supported by IA #10035
 ;Reference to ^PSDRUG( supported by IA #2621
 ;Reference to ^PSRX( supported by IA #1977
 Q
 ;
ST ;CS Monitoring OPTION ENTRY
 N PSDODIV,PSDCII,PSDDTN,PSDED,PSDISA,PSDISB,PSDOUT,PSDSD,X,Y,%,%ZIS
 N DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,ZTIO,ZTSAVE,ZTSK,ZTRTN,ZTDESC
 W !!,?5,"This report lists released RXs without a visit within 12 months of the"
 W !,?5,"RX Release date.  Excluding RXs released on the same day as a discharge"
 W !,?5,"and within a user defined discharge date range.",!!
 W ! D DIV^PSDNMU I '$O(PSDODIV(0))!($G(PSDOUT)) G END
 S PSDDTN="RX Release" D DATE^PSDNMU I '$G(PSDSD)!($G(PSDOUT)) G END
 W ! D DISD^PSDNMU I $G(PSDOUT) G END
 W ! S DIR("A")="Screen for controlled substance RXs"
 S DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR I X="^"!($D(DTOUT)) G END
 I Y=1 W ! D CII^PSDNMU I '+$G(PSDCII)!($G(PSDOUT)) G END
 I Y'=1 S PSDCII=""
 ;
 W ! S DIR("A")="Okay to Continue",DIR("B")="No",DIR(0)="Y" D ^DIR
 I Y'=1 W "     <No report>",! G END
 W !!,?9,"This report should be queued to run during non-peak hours.",!
 K IO("Q") S %ZIS="MQ" D ^%ZIS I POP W "  <No device selected.>" G END
 I $D(IO("Q")) D
 .S ZTRTN="DQ^PSDNMWE",ZTDESC="CS Monitoring - PSDNMWE"
 .S ZTSAVE("PSDSD")="",ZTSAVE("PSDODIV(")="",ZTSAVE("PSDCII")="",ZTSAVE("PSDED")="",ZTSAVE("PSDISA")="",ZTSAVE("PSDISB")=""
 .D ^%ZTLOAD W !!?5,"TASK #",$G(ZTSK)," QUEUED!",!
 I '$D(IO("Q")) U IO D DQ
 K IOP,IO("Q")
END Q
 ;
HD ;Report heading
 N PSDD,PSDL,X,Y,%
 W @IOF,$$CJ^XLFSTR("CS Monitoring - No Visits within 12 months of RX Release Report",IOM)
 S PSDL="Outpatient Division(s): "
 S PSDD=0
 F  S PSDD=$O(PSDODIV(PSDD)) Q:'PSDD  S PSDL=PSDL_$P($G(PSDODIV(PSDD)),U,2) I $O(PSDODIV(PSDD)) S PSDL=PSDL_", "
 W !,$$CJ^XLFSTR(PSDL,IOM)
 W !,$$CJ^XLFSTR("Prescriptions released: "_$P(PSDSD,U,2)_" thru "_$P(PSDED,U,2),IOM)
 I $G(PSDISA)!($G(PSDISB)) D
 . S PSDL="Exclude RXs released: "
 . I $G(PSDISB) S PSDL=PSDL_+PSDISB_" day(s) before "
 . I $G(PSDISA) S PSDL=PSDL_+PSDISA_" day(s) after "
 . S PSDL=PSDL_"a discharge date"
 . W !,$$CJ^XLFSTR(PSDL,IOM)
 S PSDL="Controlled Substance schedule(s): "
 F PSDD=1:1:4 I $P(PSDCII,",",PSDD) S PSDL=PSDL_$P(PSDCII,",",PSDD) I $P(PSDCII,",",(PSDD+1)) S PSDL=PSDL_", "
 I +PSDCII W !,$$CJ^XLFSTR(PSDL,IOM)
 W !,"Division: ",$E($G(PSDIV),1,13),?25,"Report Run Date: "
 S PSDPG=PSDPG+1
 D NOW^%DTC W $$FMTE^XLFDT(%),?70,"PAGE: ",PSDPG
 W !,$$REPEAT^XLFSTR("=",IOM)
 QUIT
 ;
DQ ;Report Run
 N D0,DA,DFN,DIC,DIQ,DR
 N PSDA,PSDD,PSDFD,PSDI,PSDIDT,PSDIV,PSDO,PSDOUT,PSDP,PSDPG,PSDS,PSDRG
 N PSDUZ,PSDY,PSDX,PSDX0,PSDX2,PSDXOR1,PSDY,X,X1,X2,Y,%,%DT
 K ^TMP("PSDNMWE",$J)
 I IOST?1"C-".E W !!,?10,"Compiling report, please wait ..."
 S PSDFD=+PSDSD
 F  S PSDFD=$O(^PSRX("AL",PSDFD)) Q:('PSDFD)!(PSDFD]+PSDED)  D
 . S PSDX=0
 . F  S PSDX=$O(^PSRX("AL",PSDFD,PSDX)) Q:'PSDX  D
 . . D KVA^VADPT
 . . S PSDX0=$G(^PSRX(PSDX,0)) I PSDX0']"" Q
 . . S PSDX2=$G(^PSRX(PSDX,2))
 . . I '$D(PSDODIV(+$P(PSDX2,U,9))) Q
 . . S PSDRG=$G(^PSDRUG(+$P(PSDX0,U,6),0))
 . . I +$G(PSDCII) S PSDP=0 D  I 'PSDP Q
 . . . F PSDY=1:1:4 S PSDA=$P(PSDCII,",",PSDY) I PSDA,$P(PSDRG,U,3)[PSDA S PSDP=1 Q
 . . I +$G(PSDCII),'PSDP Q
 . . ;Check Discharge Date
 . . S DFN=+$P(PSDX0,U,2) D DEM^VADPT
 . . S VAIP("D")=+$P(PSDFD,".",1),PSDP=0
 . . I $D(^TMP("PSDNMWE",$J,1,DFN,VAIP("D"))) Q
 . . D IN5^VADPT D  I $G(PSDP) Q
 . . . I +$G(VAIP(17,2))[VAIP("D") S ^TMP("PSDNMWE",$J,1,DFN,VAIP("D"))="" S PSDP=1 Q
 . . . I +$G(VAIP(17,2)),$G(PSDISA) D  I $G(PSDP) Q
 . . . . S X1=+$G(VAIP(17,2)),X2=+PSDISA D C^%DTC S PSDD=X
 . . . . I VAIP("D")'>PSDD S PSDP=1 Q
 . . . I +$G(VAIP(17,2)),$G(PSDISB) D  I $G(PSDP) Q
 . . . . S X1=+$G(VAIP(17,2)),X2=-PSDISB D C^%DTC S PSDD=X
 . . . . I VAIP("D")'<PSDD S PSDP=1 Q
 . . ;
 . . ;Check Visits within 12 months
 . . S PSDD="",X1=+PSDFD,X2=-365 D C^%DTC S PSDY=X
 . . K VASD S VASD("W")=1,VASD("F")=PSDY,VASD("T")=PSDFD
 . . D SDA^VADPT
 . . S PSDY=0
 . . F  S PSDY=$O(^UTILITY("VASD",$J,PSDY)) Q:'PSDY  D
 . . . S PSDI=$G(^UTILITY("VASD",$J,PSDY,"I"))
 . . . I $P(PSDI,U,3)="" K PSDP Q
 . . . S PSDP=1
 . . I $G(PSDP)=1!('$O(^UTILITY("VASD",$J,0))) D
 . . . I +$G(VADM(6)),+$G(VADM(6))']VAIP("D") S PSDD=$P($G(VADM(6)),U,2)
 . . . S Y=+PSDFD D D^DIQ S PSDA=Y
 . . . S PSDUZ=$P($G(^DPT(DFN,0)),U,1)_"  ("_$E(VA("PID"),5,12)_")"
 . . . S DIC="^PSRX(",DA=PSDX,DR="3;20",DIQ(0)="E",DIQ="PSDO"
 . . . K PSDO D EN^DIQ1
 . . . S ^TMP("PSDNMWE",$J,$S($G(PSDO(52,PSDX,20,"E"))]"":$G(PSDO(52,PSDX,20,"E")),1:"UNKNOWN"),$S($G(PSDO(52,PSDX,3,"E"))]"":$G(PSDO(52,PSDX,3,"E")),1:"UNKNOWN"),PSDUZ,PSDX)=$P(PSDX0,U,1)_U_PSDA_U_$P(PSDRG,U,1)_U_$G(PSDD)
 D KVA^VADPT
 ;
PRT ;Report print
 S PSDPG=0,PSDOUT=0
 I '$D(^TMP("PSDNMWE",$J)) D  G DQQ
 . S PSDIV="",PSDPG=0 D HD,PHD
 . W !!,?10,"<<<< NO DATA FOUND >>>>",!
 S PSDIV=""
 F  S PSDIV=$O(^TMP("PSDNMWE",$J,PSDIV)) Q:(PSDIV="")!(PSDOUT)  D
 .  S PSDPG=0 D HD,PHD
 .  S PSDS=""
 .  F  S PSDS=$O(^TMP("PSDNMWE",$J,PSDIV,PSDS)) Q:(PSDS="")!(PSDOUT)  D
 .  .  I ($Y+3)>IOSL D PAGE Q:PSDOUT  D HD,PHD
 .  .  W !!,?12,"RX PATIENT STATUS: ",PSDS
 .  .  S PSDRG=""
 .  .  F  S PSDRG=$O(^TMP("PSDNMWE",$J,PSDIV,PSDS,PSDRG)) Q:(PSDRG="")!(PSDOUT)  D
 .  .  .  I ($Y+3)>IOSL D PAGE Q:PSDOUT  D HD,PHD
 .  .  .  W !!,"PATIENT NAME: ",PSDRG
 .  .  .  S PSDX=0
 .  .  .  F  S PSDX=$O(^TMP("PSDNMWE",$J,PSDIV,PSDS,PSDRG,PSDX)) Q:('PSDX)!(PSDOUT)  D
 .  .  .  .  S PSDY=$G(^TMP("PSDNMWE",$J,PSDIV,PSDS,PSDRG,PSDX))
 .  .  .  .  I ($Y+3)>IOSL D PAGE Q:PSDOUT  D HD,PHD
 .  .  .  .  W !,$P(PSDY,U,1),?12,$P(PSDY,U,2),?40,$P(PSDY,U,3)
 .  .  .  .  I $P(PSDY,U,4)]"" W !,?12,"*Date of Death "_$P(PSDY,U,4)_" before RX Release Date!"
 .  I '$G(PSDOUT),$O(^TMP("PSDNMWE",$J,PSDIV))]"" D PAGE
 ;
DQQ W ! K PSDCII,PSDODIV,PSDSD,PSDED,PSDISA,PSDISB,^TMP("PSDNMWE",$J) D ^%ZISC Q
 ;
PHD ;
 W !,"RX#",?12,"Release Date",?40,"Drug"
 W !,$$REPEAT^XLFSTR("_",IOM)
 Q
PAGE ;
 N DIR,DIRUT,DTOUT,DUOUT,X,Y
 I IOST?1"C-".E S DIR(0)="E" D ^DIR W !
 I ($D(DTOUT))!($D(DIRUT)) S PSDOUT=1 Q:$G(PSDOUT)=1
 Q
 ;
EOR ;PSDNMWE - CSM No Visits in 12 Months; 18 DEC 02
 
--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDNMWE   6277     printed  Sep 23, 2025@19:22:59                                                                                                                                                                                                     Page 2
PSDNMWE   ;DOIFO/CMS - CSM No Visits within 12 Months ;18 Dec 02
 +1       ;;3.0; CONTROLLED SUBSTANCES;**41,42**;13 Feb 97
 +2       ;Reference to ^DPT( supported by IA #10035
 +3       ;Reference to ^PSDRUG( supported by IA #2621
 +4       ;Reference to ^PSRX( supported by IA #1977
 +5        QUIT 
 +6       ;
ST        ;CS Monitoring OPTION ENTRY
 +1        NEW PSDODIV,PSDCII,PSDDTN,PSDED,PSDISA,PSDISB,PSDOUT,PSDSD,X,Y,%,%ZIS
 +2        NEW DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,ZTIO,ZTSAVE,ZTSK,ZTRTN,ZTDESC
 +3        WRITE !!,?5,"This report lists released RXs without a visit within 12 months of the"
 +4        WRITE !,?5,"RX Release date.  Excluding RXs released on the same day as a discharge"
 +5        WRITE !,?5,"and within a user defined discharge date range.",!!
 +6        WRITE !
           DO DIV^PSDNMU
           IF '$ORDER(PSDODIV(0))!($GET(PSDOUT))
               GOTO END
 +7        SET PSDDTN="RX Release"
           DO DATE^PSDNMU
           IF '$GET(PSDSD)!($GET(PSDOUT))
               GOTO END
 +8        WRITE !
           DO DISD^PSDNMU
           IF $GET(PSDOUT)
               GOTO END
 +9        WRITE !
           SET DIR("A")="Screen for controlled substance RXs"
 +10       SET DIR("B")="Yes"
           SET DIR(0)="Y"
           DO ^DIR
           KILL DIR
           IF X="^"!($DATA(DTOUT))
               GOTO END
 +11       IF Y=1
               WRITE !
               DO CII^PSDNMU
               IF '+$GET(PSDCII)!($GET(PSDOUT))
                   GOTO END
 +12       IF Y'=1
               SET PSDCII=""
 +13      ;
 +14       WRITE !
           SET DIR("A")="Okay to Continue"
           SET DIR("B")="No"
           SET DIR(0)="Y"
           DO ^DIR
 +15       IF Y'=1
               WRITE "     <No report>",!
               GOTO END
 +16       WRITE !!,?9,"This report should be queued to run during non-peak hours.",!
 +17       KILL IO("Q")
           SET %ZIS="MQ"
           DO ^%ZIS
           IF POP
               WRITE "  <No device selected.>"
               GOTO END
 +18       IF $DATA(IO("Q"))
               Begin DoDot:1
 +19               SET ZTRTN="DQ^PSDNMWE"
                   SET ZTDESC="CS Monitoring - PSDNMWE"
 +20               SET ZTSAVE("PSDSD")=""
                   SET ZTSAVE("PSDODIV(")=""
                   SET ZTSAVE("PSDCII")=""
                   SET ZTSAVE("PSDED")=""
                   SET ZTSAVE("PSDISA")=""
                   SET ZTSAVE("PSDISB")=""
 +21               DO ^%ZTLOAD
                   WRITE !!?5,"TASK #",$GET(ZTSK)," QUEUED!",!
               End DoDot:1
 +22       IF '$DATA(IO("Q"))
               USE IO
               DO DQ
 +23       KILL IOP,IO("Q")
END        QUIT 
 +1       ;
HD        ;Report heading
 +1        NEW PSDD,PSDL,X,Y,%
 +2        WRITE @IOF,$$CJ^XLFSTR("CS Monitoring - No Visits within 12 months of RX Release Report",IOM)
 +3        SET PSDL="Outpatient Division(s): "
 +4        SET PSDD=0
 +5        FOR 
               SET PSDD=$ORDER(PSDODIV(PSDD))
               if 'PSDD
                   QUIT 
               SET PSDL=PSDL_$PIECE($GET(PSDODIV(PSDD)),U,2)
               IF $ORDER(PSDODIV(PSDD))
                   SET PSDL=PSDL_", "
 +6        WRITE !,$$CJ^XLFSTR(PSDL,IOM)
 +7        WRITE !,$$CJ^XLFSTR("Prescriptions released: "_$PIECE(PSDSD,U,2)_" thru "_$PIECE(PSDED,U,2),IOM)
 +8        IF $GET(PSDISA)!($GET(PSDISB))
               Begin DoDot:1
 +9                SET PSDL="Exclude RXs released: "
 +10               IF $GET(PSDISB)
                       SET PSDL=PSDL_+PSDISB_" day(s) before "
 +11               IF $GET(PSDISA)
                       SET PSDL=PSDL_+PSDISA_" day(s) after "
 +12               SET PSDL=PSDL_"a discharge date"
 +13               WRITE !,$$CJ^XLFSTR(PSDL,IOM)
               End DoDot:1
 +14       SET PSDL="Controlled Substance schedule(s): "
 +15       FOR PSDD=1:1:4
               IF $PIECE(PSDCII,",",PSDD)
                   SET PSDL=PSDL_$PIECE(PSDCII,",",PSDD)
                   IF $PIECE(PSDCII,",",(PSDD+1))
                       SET PSDL=PSDL_", "
 +16       IF +PSDCII
               WRITE !,$$CJ^XLFSTR(PSDL,IOM)
 +17       WRITE !,"Division: ",$EXTRACT($GET(PSDIV),1,13),?25,"Report Run Date: "
 +18       SET PSDPG=PSDPG+1
 +19       DO NOW^%DTC
           WRITE $$FMTE^XLFDT(%),?70,"PAGE: ",PSDPG
 +20       WRITE !,$$REPEAT^XLFSTR("=",IOM)
 +21       QUIT 
 +22      ;
DQ        ;Report Run
 +1        NEW D0,DA,DFN,DIC,DIQ,DR
 +2        NEW PSDA,PSDD,PSDFD,PSDI,PSDIDT,PSDIV,PSDO,PSDOUT,PSDP,PSDPG,PSDS,PSDRG
 +3        NEW PSDUZ,PSDY,PSDX,PSDX0,PSDX2,PSDXOR1,PSDY,X,X1,X2,Y,%,%DT
 +4        KILL ^TMP("PSDNMWE",$JOB)
 +5        IF IOST?1"C-".E
               WRITE !!,?10,"Compiling report, please wait ..."
 +6        SET PSDFD=+PSDSD
 +7        FOR 
               SET PSDFD=$ORDER(^PSRX("AL",PSDFD))
               if ('PSDFD)!(PSDFD]+PSDED)
                   QUIT 
               Begin DoDot:1
 +8                SET PSDX=0
 +9                FOR 
                       SET PSDX=$ORDER(^PSRX("AL",PSDFD,PSDX))
                       if 'PSDX
                           QUIT 
                       Begin DoDot:2
 +10                       DO KVA^VADPT
 +11                       SET PSDX0=$GET(^PSRX(PSDX,0))
                           IF PSDX0']""
                               QUIT 
 +12                       SET PSDX2=$GET(^PSRX(PSDX,2))
 +13                       IF '$DATA(PSDODIV(+$PIECE(PSDX2,U,9)))
                               QUIT 
 +14                       SET PSDRG=$GET(^PSDRUG(+$PIECE(PSDX0,U,6),0))
 +15                       IF +$GET(PSDCII)
                               SET PSDP=0
                               Begin DoDot:3
 +16                               FOR PSDY=1:1:4
                                       SET PSDA=$PIECE(PSDCII,",",PSDY)
                                       IF PSDA
                                           IF $PIECE(PSDRG,U,3)[PSDA
                                               SET PSDP=1
                                               QUIT 
                               End DoDot:3
                               IF 'PSDP
                                   QUIT 
 +17                       IF +$GET(PSDCII)
                               IF 'PSDP
                                   QUIT 
 +18      ;Check Discharge Date
 +19                       SET DFN=+$PIECE(PSDX0,U,2)
                           DO DEM^VADPT
 +20                       SET VAIP("D")=+$PIECE(PSDFD,".",1)
                           SET PSDP=0
 +21                       IF $DATA(^TMP("PSDNMWE",$JOB,1,DFN,VAIP("D")))
                               QUIT 
 +22                       DO IN5^VADPT
                           Begin DoDot:3
 +23                           IF +$GET(VAIP(17,2))[VAIP("D")
                                   SET ^TMP("PSDNMWE",$JOB,1,DFN,VAIP("D"))=""
                                   SET PSDP=1
                                   QUIT 
 +24                           IF +$GET(VAIP(17,2))
                                   IF $GET(PSDISA)
                                       Begin DoDot:4
 +25                                       SET X1=+$GET(VAIP(17,2))
                                           SET X2=+PSDISA
                                           DO C^%DTC
                                           SET PSDD=X
 +26                                       IF VAIP("D")'>PSDD
                                               SET PSDP=1
                                               QUIT 
                                       End DoDot:4
                                       IF $GET(PSDP)
                                           QUIT 
 +27                           IF +$GET(VAIP(17,2))
                                   IF $GET(PSDISB)
                                       Begin DoDot:4
 +28                                       SET X1=+$GET(VAIP(17,2))
                                           SET X2=-PSDISB
                                           DO C^%DTC
                                           SET PSDD=X
 +29                                       IF VAIP("D")'<PSDD
                                               SET PSDP=1
                                               QUIT 
                                       End DoDot:4
                                       IF $GET(PSDP)
                                           QUIT 
                           End DoDot:3
                           IF $GET(PSDP)
                               QUIT 
 +30      ;
 +31      ;Check Visits within 12 months
 +32                       SET PSDD=""
                           SET X1=+PSDFD
                           SET X2=-365
                           DO C^%DTC
                           SET PSDY=X
 +33                       KILL VASD
                           SET VASD("W")=1
                           SET VASD("F")=PSDY
                           SET VASD("T")=PSDFD
 +34                       DO SDA^VADPT
 +35                       SET PSDY=0
 +36                       FOR 
                               SET PSDY=$ORDER(^UTILITY("VASD",$JOB,PSDY))
                               if 'PSDY
                                   QUIT 
                               Begin DoDot:3
 +37                               SET PSDI=$GET(^UTILITY("VASD",$JOB,PSDY,"I"))
 +38                               IF $PIECE(PSDI,U,3)=""
                                       KILL PSDP
                                       QUIT 
 +39                               SET PSDP=1
                               End DoDot:3
 +40                       IF $GET(PSDP)=1!('$ORDER(^UTILITY("VASD",$JOB,0)))
                               Begin DoDot:3
 +41                               IF +$GET(VADM(6))
                                       IF +$GET(VADM(6))']VAIP("D")
                                           SET PSDD=$PIECE($GET(VADM(6)),U,2)
 +42                               SET Y=+PSDFD
                                   DO D^DIQ
                                   SET PSDA=Y
 +43                               SET PSDUZ=$PIECE($GET(^DPT(DFN,0)),U,1)_"  ("_$EXTRACT(VA("PID"),5,12)_")"
 +44                               SET DIC="^PSRX("
                                   SET DA=PSDX
                                   SET DR="3;20"
                                   SET DIQ(0)="E"
                                   SET DIQ="PSDO"
 +45                               KILL PSDO
                                   DO EN^DIQ1
 +46                               SET ^TMP("PSDNMWE",$JOB,$SELECT($GET(PSDO(52,PSDX,20,"E"))]"":$GET(PSDO(52,PSDX,20,"E")),1:"UNKNOWN"),$SELECT($GET(PSDO(52,PSDX,3,"E"))]"":$GET(PSDO(52,PSDX,3,"E")),1:"UNKNOWN"),PSDUZ,PSDX)=$PIECE(PSDX0,U,1)_U_PSDA_U_$PI
ECE(PSDRG,U,1)_U_$GET(PSDD)
                               End DoDot:3
                       End DoDot:2
               End DoDot:1
 +47       DO KVA^VADPT
 +48      ;
PRT       ;Report print
 +1        SET PSDPG=0
           SET PSDOUT=0
 +2        IF '$DATA(^TMP("PSDNMWE",$JOB))
               Begin DoDot:1
 +3                SET PSDIV=""
                   SET PSDPG=0
                   DO HD
                   DO PHD
 +4                WRITE !!,?10,"<<<< NO DATA FOUND >>>>",!
               End DoDot:1
               GOTO DQQ
 +5        SET PSDIV=""
 +6        FOR 
               SET PSDIV=$ORDER(^TMP("PSDNMWE",$JOB,PSDIV))
               if (PSDIV="")!(PSDOUT)
                   QUIT 
               Begin DoDot:1
 +7                SET PSDPG=0
                   DO HD
                   DO PHD
 +8                SET PSDS=""
 +9                FOR 
                       SET PSDS=$ORDER(^TMP("PSDNMWE",$JOB,PSDIV,PSDS))
                       if (PSDS="")!(PSDOUT)
                           QUIT 
                       Begin DoDot:2
 +10                       IF ($Y+3)>IOSL
                               DO PAGE
                               if PSDOUT
                                   QUIT 
                               DO HD
                               DO PHD
 +11                       WRITE !!,?12,"RX PATIENT STATUS: ",PSDS
 +12                       SET PSDRG=""
 +13                       FOR 
                               SET PSDRG=$ORDER(^TMP("PSDNMWE",$JOB,PSDIV,PSDS,PSDRG))
                               if (PSDRG="")!(PSDOUT)
                                   QUIT 
                               Begin DoDot:3
 +14                               IF ($Y+3)>IOSL
                                       DO PAGE
                                       if PSDOUT
                                           QUIT 
                                       DO HD
                                       DO PHD
 +15                               WRITE !!,"PATIENT NAME: ",PSDRG
 +16                               SET PSDX=0
 +17                               FOR 
                                       SET PSDX=$ORDER(^TMP("PSDNMWE",$JOB,PSDIV,PSDS,PSDRG,PSDX))
                                       if ('PSDX)!(PSDOUT)
                                           QUIT 
                                       Begin DoDot:4
 +18                                       SET PSDY=$GET(^TMP("PSDNMWE",$JOB,PSDIV,PSDS,PSDRG,PSDX))
 +19                                       IF ($Y+3)>IOSL
                                               DO PAGE
                                               if PSDOUT
                                                   QUIT 
                                               DO HD
                                               DO PHD
 +20                                       WRITE !,$PIECE(PSDY,U,1),?12,$PIECE(PSDY,U,2),?40,$PIECE(PSDY,U,3)
 +21                                       IF $PIECE(PSDY,U,4)]""
                                               WRITE !,?12,"*Date of Death "_$PIECE(PSDY,U,4)_" before RX Release Date!"
                                       End DoDot:4
                               End DoDot:3
                       End DoDot:2
 +22               IF '$GET(PSDOUT)
                       IF $ORDER(^TMP("PSDNMWE",$JOB,PSDIV))]""
                           DO PAGE
               End DoDot:1
 +23      ;
DQQ        WRITE !
           KILL PSDCII,PSDODIV,PSDSD,PSDED,PSDISA,PSDISB,^TMP("PSDNMWE",$JOB)
           DO ^%ZISC
           QUIT 
 +1       ;
PHD       ;
 +1        WRITE !,"RX#",?12,"Release Date",?40,"Drug"
 +2        WRITE !,$$REPEAT^XLFSTR("_",IOM)
 +3        QUIT 
PAGE      ;
 +1        NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
 +2        IF IOST?1"C-".E
               SET DIR(0)="E"
               DO ^DIR
               WRITE !
 +3        IF ($DATA(DTOUT))!($DATA(DIRUT))
               SET PSDOUT=1
               if $GET(PSDOUT)=1
                   QUIT 
 +4        QUIT 
 +5       ;
EOR       ;PSDNMWE - CSM No Visits in 12 Months; 18 DEC 02