PSDNMPR ;DOIFO/CMS - CSM Partial Request ;18 Dec 02
;;3.0; CONTROLLED SUBSTANCES ;*41*;13 Feb 97
;Reference to ^PSDRUG( supported by IA #221
;Reference to ^PS(59 supported by IA #2621
;Reference to ^PSRX( supported by IA #1977
Q
;
ST ;CS Monitoring OPTION ENTRY
N PSDODIV,PSDCII,PSDED,PSDFED,PSDFSD,PSDOUT,PSDDTN,PSDSD,X,Y,%
N DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,ZTIO,ZTSAVE,ZTSK,ZTRTN,ZTDESC,%ZIS
W !!,?5,"This report lists CS Prescriptions with Partial Fill"
W !,?5,"request activity within the fill date range entered.",!!
W ! D DIV^PSDNMU I '$O(PSDODIV(0))!($G(PSDOUT)) G END
S PSDDTN="Fill" D DATE^PSDNMU I '$G(PSDSD)!($G(PSDOUT)) G END
S PSDFSD=PSDSD,PSDFED=PSDED
W ! D CII^PSDNMU I $G(PSDOUT) G END
;
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^PSDNMPR",ZTDESC="CS Monitoring - PSDNMPR"
.S ZTSAVE("PSDODIV(")="",ZTSAVE("PSDCII")="",ZTSAVE("PSDFSD")="",ZTSAVE("PSDFED")=""
.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 - Partial Request 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("Fill Date range: "_$P(PSDFSD,U,2)_" thru "_$P(PSDFED,U,2),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 PSDA,PSDFD,PSDI,PSDIDT,PSDIV,PSDOUT,PSDP,PSDPG,PSDRG,PSDUZ,PSDX,PSDX0,PSDX2,PSDXOR1,PSDY,X,Y,%
K ^TMP("PSDNMPR",$J)
I IOST?1"C-".E W !!,?10,"Compiling report, please wait ..."
S PSDFD=+PSDFSD
F S PSDFD=$O(^PSRX("AD",PSDFD)) Q:('PSDFD)!(PSDFD]+PSDFED) D
. S PSDX=0
. F S PSDX=$O(^PSRX("AD",PSDFD,PSDX)) Q:'PSDX D
. . 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))
. . S PSDP=0
. . F PSDY=1:1:4 S PSDA=+$P(PSDCII,",",PSDY) I PSDA,$P(PSDRG,U,3)[PSDA S PSDP=1 Q
. . I 'PSDP Q
. . S PSDI=0
. . F S PSDI=$O(^PSRX(PSDX,"A",PSDI)) Q:'PSDI D
. . . S PSDA=$G(^PSRX(PSDX,"A",PSDI,0))
. . . I $P(PSDA,U,2)'="P" Q
. . . S Y=+PSDA D D^DIQ S $P(PSDA,U,1)=Y
. . . S PSDUZ=$P($G(^VA(200,+$P(PSDA,U,3),0)),U,1)
. . . S ^TMP("PSDNMPR",$J,$S(+$P(PSDX2,U,9):$P($G(^PS(59,+$P(PSDX2,U,9),0)),U,1),1:"UNKNOWN"),$P(PSDRG,U,1),PSDX,PSDI)=$P(PSDX0,U,1)_U_$P(PSDA,U,1)_U_PSDUZ_U_$P(PSDA,U,5)
;
PRT ;Report print
S PSDPG=0,PSDOUT=0
I '$D(^TMP("PSDNMPR",$J)) D G DQQ
. S PSDIV="" D HD,PHD
. W !!,?10,"<<<< NO DATA FOUND >>>>",!
S PSDIV=""
F S PSDIV=$O(^TMP("PSDNMPR",$J,PSDIV)) Q:(PSDIV="")!(PSDOUT) D
. S PSDPG=0 D HD,PHD
. S PSDRG=""
. F S PSDRG=$O(^TMP("PSDNMPR",$J,PSDIV,PSDRG)) Q:(PSDRG="")!(PSDOUT) D
. . I ($Y+3)>IOSL D PAGE Q:PSDOUT D HD,PHD
. . W !!,PSDRG
. . S PSDX=0
. . F S PSDX=$O(^TMP("PSDNMPR",$J,PSDIV,PSDRG,PSDX)) Q:('PSDX)!(PSDOUT) D
. . . S PSDA=0
. . . F S PSDA=$O(^TMP("PSDNMPR",$J,PSDIV,PSDRG,PSDX,PSDA)) Q:('PSDA)!(PSDOUT) D
. . . . S PSDY=$G(^TMP("PSDNMPR",$J,PSDIV,PSDRG,PSDX,PSDA))
. . . . I ($Y+3)>IOSL D PAGE Q:PSDOUT D HD,PHD
. . . . W !,$P(PSDY,U,1),?15,$P(PSDY,U,2),?40,$P(PSDY,U,3)
. . . . W !,?15,$P(PSDY,U,4)
. I '$G(PSDOUT),$O(^TMP("PSDNMPR",$J,PSDIV))]"" D PAGE
;
DQQ W ! K PSDCII,PSDFED,PSDFSD,PSDODIV,^TMP("PSDNMPR",$J) D ^%ZISC Q
;
PHD ;
W !,"RX#",?15,"Activity Log Date",?40,"Initiator of Activity"
W !,?15,"Activity Log Comment"
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 ;PSDNMPR - CSM Partial Request; 18 DEC 02
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDNMPR 4331 printed Oct 16, 2024@17:47:44 Page 2
PSDNMPR ;DOIFO/CMS - CSM Partial Request ;18 Dec 02
+1 ;;3.0; CONTROLLED SUBSTANCES ;*41*;13 Feb 97
+2 ;Reference to ^PSDRUG( supported by IA #221
+3 ;Reference to ^PS(59 supported by IA #2621
+4 ;Reference to ^PSRX( supported by IA #1977
+5 QUIT
+6 ;
ST ;CS Monitoring OPTION ENTRY
+1 NEW PSDODIV,PSDCII,PSDED,PSDFED,PSDFSD,PSDOUT,PSDDTN,PSDSD,X,Y,%
+2 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,ZTIO,ZTSAVE,ZTSK,ZTRTN,ZTDESC,%ZIS
+3 WRITE !!,?5,"This report lists CS Prescriptions with Partial Fill"
+4 WRITE !,?5,"request activity within the fill date range entered.",!!
+5 WRITE !
DO DIV^PSDNMU
IF '$ORDER(PSDODIV(0))!($GET(PSDOUT))
GOTO END
+6 SET PSDDTN="Fill"
DO DATE^PSDNMU
IF '$GET(PSDSD)!($GET(PSDOUT))
GOTO END
+7 SET PSDFSD=PSDSD
SET PSDFED=PSDED
+8 WRITE !
DO CII^PSDNMU
IF $GET(PSDOUT)
GOTO END
+9 ;
+10 WRITE !
SET DIR("A")="Okay to Continue"
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
+11 IF Y'=1
WRITE " <No report>",!
GOTO END
+12 WRITE !!,?9,"This report should be queued to run during non-peak hours.",!
+13 KILL IO("Q")
SET %ZIS="MQ"
DO ^%ZIS
IF POP
WRITE " <No device selected.>"
GOTO END
+14 IF $DATA(IO("Q"))
Begin DoDot:1
+15 SET ZTRTN="DQ^PSDNMPR"
SET ZTDESC="CS Monitoring - PSDNMPR"
+16 SET ZTSAVE("PSDODIV(")=""
SET ZTSAVE("PSDCII")=""
SET ZTSAVE("PSDFSD")=""
SET ZTSAVE("PSDFED")=""
+17 DO ^%ZTLOAD
WRITE !!?5,"TASK #",$GET(ZTSK)," QUEUED!",!
End DoDot:1
+18 IF '$DATA(IO("Q"))
USE IO
DO DQ
+19 KILL IOP,IO("Q")
END QUIT
+1 ;
HD ;Report heading
+1 NEW PSDD,PSDL,X,Y,%
+2 WRITE @IOF,$$CJ^XLFSTR("CS Monitoring - Partial Request 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("Fill Date range: "_$PIECE(PSDFSD,U,2)_" thru "_$PIECE(PSDFED,U,2),IOM)
+8 SET PSDL="Controlled Substance schedule(s): "
+9 FOR PSDD=1:1:4
IF $PIECE(PSDCII,",",PSDD)
SET PSDL=PSDL_$PIECE(PSDCII,",",PSDD)
IF $PIECE(PSDCII,",",(PSDD+1))
SET PSDL=PSDL_", "
+10 IF +PSDCII
WRITE !,$$CJ^XLFSTR(PSDL,IOM)
+11 WRITE !,"Division: ",$EXTRACT($GET(PSDIV),1,13),?25,"Report Run Date: "
+12 SET PSDPG=PSDPG+1
+13 DO NOW^%DTC
WRITE $$FMTE^XLFDT(%),?70,"PAGE: ",PSDPG
+14 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+15 QUIT
+16 ;
DQ ;Report Run
+1 NEW PSDA,PSDFD,PSDI,PSDIDT,PSDIV,PSDOUT,PSDP,PSDPG,PSDRG,PSDUZ,PSDX,PSDX0,PSDX2,PSDXOR1,PSDY,X,Y,%
+2 KILL ^TMP("PSDNMPR",$JOB)
+3 IF IOST?1"C-".E
WRITE !!,?10,"Compiling report, please wait ..."
+4 SET PSDFD=+PSDFSD
+5 FOR
SET PSDFD=$ORDER(^PSRX("AD",PSDFD))
if ('PSDFD)!(PSDFD]+PSDFED)
QUIT
Begin DoDot:1
+6 SET PSDX=0
+7 FOR
SET PSDX=$ORDER(^PSRX("AD",PSDFD,PSDX))
if 'PSDX
QUIT
Begin DoDot:2
+8 SET PSDX0=$GET(^PSRX(PSDX,0))
IF PSDX0']""
QUIT
+9 SET PSDX2=$GET(^PSRX(PSDX,2))
+10 IF '$DATA(PSDODIV(+$PIECE(PSDX2,U,9)))
QUIT
+11 SET PSDRG=$GET(^PSDRUG(+$PIECE(PSDX0,U,6),0))
+12 SET PSDP=0
+13 FOR PSDY=1:1:4
SET PSDA=+$PIECE(PSDCII,",",PSDY)
IF PSDA
IF $PIECE(PSDRG,U,3)[PSDA
SET PSDP=1
QUIT
+14 IF 'PSDP
QUIT
+15 SET PSDI=0
+16 FOR
SET PSDI=$ORDER(^PSRX(PSDX,"A",PSDI))
if 'PSDI
QUIT
Begin DoDot:3
+17 SET PSDA=$GET(^PSRX(PSDX,"A",PSDI,0))
+18 IF $PIECE(PSDA,U,2)'="P"
QUIT
+19 SET Y=+PSDA
DO D^DIQ
SET $PIECE(PSDA,U,1)=Y
+20 SET PSDUZ=$PIECE($GET(^VA(200,+$PIECE(PSDA,U,3),0)),U,1)
+21 SET ^TMP("PSDNMPR",$JOB,$SELECT(+$PIECE(PSDX2,U,9):$PIECE($GET(^PS(59,+$PIECE(PSDX2,U,9),0)),U,1),1:"UNKNOWN"),$PIECE(PSDRG,U,1),PSDX,PSDI)=$PIECE(PSDX0,U,1)_U_$PIECE(PSDA,U,1)_U_PSDUZ_U_$PIECE(PSDA,U,5)
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
PRT ;Report print
+1 SET PSDPG=0
SET PSDOUT=0
+2 IF '$DATA(^TMP("PSDNMPR",$JOB))
Begin DoDot:1
+3 SET PSDIV=""
DO HD
DO PHD
+4 WRITE !!,?10,"<<<< NO DATA FOUND >>>>",!
End DoDot:1
GOTO DQQ
+5 SET PSDIV=""
+6 FOR
SET PSDIV=$ORDER(^TMP("PSDNMPR",$JOB,PSDIV))
if (PSDIV="")!(PSDOUT)
QUIT
Begin DoDot:1
+7 SET PSDPG=0
DO HD
DO PHD
+8 SET PSDRG=""
+9 FOR
SET PSDRG=$ORDER(^TMP("PSDNMPR",$JOB,PSDIV,PSDRG))
if (PSDRG="")!(PSDOUT)
QUIT
Begin DoDot:2
+10 IF ($Y+3)>IOSL
DO PAGE
if PSDOUT
QUIT
DO HD
DO PHD
+11 WRITE !!,PSDRG
+12 SET PSDX=0
+13 FOR
SET PSDX=$ORDER(^TMP("PSDNMPR",$JOB,PSDIV,PSDRG,PSDX))
if ('PSDX)!(PSDOUT)
QUIT
Begin DoDot:3
+14 SET PSDA=0
+15 FOR
SET PSDA=$ORDER(^TMP("PSDNMPR",$JOB,PSDIV,PSDRG,PSDX,PSDA))
if ('PSDA)!(PSDOUT)
QUIT
Begin DoDot:4
+16 SET PSDY=$GET(^TMP("PSDNMPR",$JOB,PSDIV,PSDRG,PSDX,PSDA))
+17 IF ($Y+3)>IOSL
DO PAGE
if PSDOUT
QUIT
DO HD
DO PHD
+18 WRITE !,$PIECE(PSDY,U,1),?15,$PIECE(PSDY,U,2),?40,$PIECE(PSDY,U,3)
+19 WRITE !,?15,$PIECE(PSDY,U,4)
End DoDot:4
End DoDot:3
End DoDot:2
+20 IF '$GET(PSDOUT)
IF $ORDER(^TMP("PSDNMPR",$JOB,PSDIV))]""
DO PAGE
End DoDot:1
+21 ;
DQQ WRITE !
KILL PSDCII,PSDFED,PSDFSD,PSDODIV,^TMP("PSDNMPR",$JOB)
DO ^%ZISC
QUIT
+1 ;
PHD ;
+1 WRITE !,"RX#",?15,"Activity Log Date",?40,"Initiator of Activity"
+2 WRITE !,?15,"Activity Log Comment"
+3 WRITE !,$$REPEAT^XLFSTR("_",IOM)
+4 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 ;PSDNMPR - CSM Partial Request; 18 DEC 02
