- 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 Feb 18, 2025@23:13:18 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
