PSDNMBA ;DOIFO/CMS - CSM Balance Adjustments ;18 Dec 02
;;3.0; CONTROLLED SUBSTANCES ;*41*;13 Feb 97
;Reference to ^PSD(58.81 supported by IA #2808
;Reference to ^PSDRUG( supported by IA #221
;Reference to ^PSD(58.84 supported by IA #3485
Q
;
ST ;CS Monitoring OPTION ENTRY
N PSDA,PSDIDIV,PSDPLOC,PSDCII,PSDED,PSDOUT,PSDDTN,PSDSD,PSDSITE,X,Y,%
N DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,ZTIO,ZTSAVE,ZTSK,ZTRTN,ZTDESC,%ZIS
W !!,?5,"This report lists Drug Accountability Balance Adjustments"
W !,?5,"made for the Inpatient Site Pharmacy Location(s) entered.",!!
S PSDA=$O(^PSD(58.84,"B","BALANCE ADJUSTMENT",0))
I 'PSDA W !!,"<< Drug Accountability Transaction Type, Balance Adjustment, not defined! >>" G END
D INPS^PSDNMU I '$G(PSDIDIV)!($G(PSDOUT)) G END
W ! S DIR("A")="Select 'ALL' "_$P(PSDIDIV,U,2)_" Pharmacy locations"
S DIR("B")="Yes",DIR(0)="Y" D ^DIR I X="^"!($D(DTOUT)) G END
I Y'=1 W ! D PLOC^PSDNMU I '$O(PSDPLOC(0))!($G(PSDOUT)) G END
I Y=1 D PLOCA^PSDNMU
;
S PSDDTN="Balance Adjustment" D DATE^PSDNMU I '$G(PSDSD)!($G(PSDOUT)) G END
W ! K DIR 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^PSDNMBA",ZTDESC="CS Monitoring - PSDNMBA"
.S ZTSAVE("PSDSD")="",ZTSAVE("PSDPLOC(")="",ZTSAVE("PSDED")="",ZTSAVE("PSDIDIV")=""
.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 PSDY,X,Y,%
W @IOF,$$CJ^XLFSTR("CS Monitoring - Balance Adjustments Report",IOM)
S PSDY="Inpatient site: "_$P(PSDIDIV,U,2)
I $G(PSDPLOC)="^ALL" S PSDY=PSDY_" all Pharmacy Locations"
W !,$$CJ^XLFSTR(PSDY,IOM)
W !,$$CJ^XLFSTR("Balance Adjustments made: "_$P(PSDSD,U,2)_" thru "_$P(PSDED,U,2),IOM)
S PSDPG=PSDPG+1
D NOW^%DTC W !,"Report Run: "_$E($$FMTE^XLFDT(%),1,18),?70,"PAGE: ",PSDPG
W !,$$REPEAT^XLFSTR("=",IOM)
QUIT
;
DQ ;Report Run
N DFN,PSDA,PSDFD,PSDI,PSDIDT,PSDIV,PSDOUT,PSDP,PSDPG,PSDS,PSDRG,PSDUZ
N PSDX,PSDX0,PSDX2,PSDXOR1,PSDY,X,Y,%
K ^TMP("PSDNMBA",$J)
I IOST?1"C-".E W !!,?10,"Compiling report, please wait ..."
S PSDA=$O(^PSD(58.84,"B","BALANCE ADJUSTMENT",0)) I 'PSDA G DQQ
S PSDP=0
F S PSDP=$O(PSDPLOC(PSDP)) Q:'PSDP S ^TMP("PSDNMBA",$J,PSDPLOC(PSDP))=""
S PSDFD=+PSDSD
F S PSDFD=$O(^PSD(58.81,"AF",PSDFD)) Q:('PSDFD)!(PSDFD]+PSDED) D
. S PSDP=0
. F S PSDP=$O(PSDPLOC(PSDP)) Q:'PSDP D
. . S PSDX=0
. . F S PSDX=$O(^PSD(58.81,"AF",PSDFD,PSDP,PSDA,PSDX)) Q:'PSDX D
. . . S PSDX0=$G(^PSD(58.81,PSDX,0)) I PSDX0']"" Q
. . . S PSDRG=$G(^PSDRUG(+$P(PSDX0,U,5),0))
. . . S PSDUZ=+$P(PSDX0,U,7),PSDUZ=$P($G(^VA(200,+PSDUZ,0)),U,1)
. . . S Y=PSDFD D D^DIQ S PSDS=Y
. . . S ^TMP("PSDNMBA",$J,PSDPLOC(PSDP),PSDUZ,PSDX)=$P(PSDX0,U,1)_U_$E(PSDS,1,18)_U_$P(PSDX0,U,6)_U_$P(PSDRG,U,1)_U_$P(PSDX0,U,16)
;
PRT ;Report print
S PSDPG=0,PSDOUT=0
I '$D(^TMP("PSDNMBA",$J)) D G DQQ
. S PSDIV="",PSDPG=1 D HD,PHD
. W !!,?10,"<<<< NO DATA FOUND >>>>",!
S PSDIV=""
D HD,PHD
F S PSDIV=$O(^TMP("PSDNMBA",$J,PSDIV)) Q:(PSDIV="")!(PSDOUT) D
. I ($Y+3)>IOSL D PAGE Q:PSDOUT D HD,PHD
. W !!,"Pharmacy Location: ",PSDIV
. S PSDS=""
. I $O(^TMP("PSDNMBA",$J,PSDIV,PSDS))']"" W !,?19,"NO DATA FOUND" Q
. F S PSDS=$O(^TMP("PSDNMBA",$J,PSDIV,PSDS)) Q:(PSDS="")!(PSDOUT) D
. . I ($Y+3)>IOSL D PAGE Q:PSDOUT D HD,PHD
. . W !!,"TRANSACTOR: ",PSDS
. . S PSDX=0
. . F S PSDX=$O(^TMP("PSDNMBA",$J,PSDIV,PSDS,PSDX)) Q:('PSDX)!(PSDOUT) D
. . . S PSDY=$G(^TMP("PSDNMBA",$J,PSDIV,PSDS,PSDX))
. . . I ($Y+3)>IOSL D PAGE Q:PSDOUT D HD,PHD
. . . W !,$P(PSDY,U,1),?10,$P(PSDY,U,2),?33,$P(PSDY,U,3),?40,$P(PSDY,U,4)
. . . W !,?10,"Reason: ",$P(PSDY,U,5)
;
DQQ W ! K PSDCII,PSDIDIV,PSDPLOC,PSDSD,PSDED,^TMP("PSDNMBA",$J) D ^%ZISC Q
;
PHD ;
W !,"Trans. #",?10,"Date",?28,"Quantity",?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 ;PSDNMBA - CSM Balance Adjustments; 18 DEC 02
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDNMBA 4264 printed Sep 23, 2025@19:22:54 Page 2
PSDNMBA ;DOIFO/CMS - CSM Balance Adjustments ;18 Dec 02
+1 ;;3.0; CONTROLLED SUBSTANCES ;*41*;13 Feb 97
+2 ;Reference to ^PSD(58.81 supported by IA #2808
+3 ;Reference to ^PSDRUG( supported by IA #221
+4 ;Reference to ^PSD(58.84 supported by IA #3485
+5 QUIT
+6 ;
ST ;CS Monitoring OPTION ENTRY
+1 NEW PSDA,PSDIDIV,PSDPLOC,PSDCII,PSDED,PSDOUT,PSDDTN,PSDSD,PSDSITE,X,Y,%
+2 NEW DIC,DIR,DIRUT,DIROUT,DTOUT,DUOUT,POP,ZTIO,ZTSAVE,ZTSK,ZTRTN,ZTDESC,%ZIS
+3 WRITE !!,?5,"This report lists Drug Accountability Balance Adjustments"
+4 WRITE !,?5,"made for the Inpatient Site Pharmacy Location(s) entered.",!!
+5 SET PSDA=$ORDER(^PSD(58.84,"B","BALANCE ADJUSTMENT",0))
+6 IF 'PSDA
WRITE !!,"<< Drug Accountability Transaction Type, Balance Adjustment, not defined! >>"
GOTO END
+7 DO INPS^PSDNMU
IF '$GET(PSDIDIV)!($GET(PSDOUT))
GOTO END
+8 WRITE !
SET DIR("A")="Select 'ALL' "_$PIECE(PSDIDIV,U,2)_" Pharmacy locations"
+9 SET DIR("B")="Yes"
SET DIR(0)="Y"
DO ^DIR
IF X="^"!($DATA(DTOUT))
GOTO END
+10 IF Y'=1
WRITE !
DO PLOC^PSDNMU
IF '$ORDER(PSDPLOC(0))!($GET(PSDOUT))
GOTO END
+11 IF Y=1
DO PLOCA^PSDNMU
+12 ;
+13 SET PSDDTN="Balance Adjustment"
DO DATE^PSDNMU
IF '$GET(PSDSD)!($GET(PSDOUT))
GOTO END
+14 WRITE !
KILL DIR
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^PSDNMBA"
SET ZTDESC="CS Monitoring - PSDNMBA"
+20 SET ZTSAVE("PSDSD")=""
SET ZTSAVE("PSDPLOC(")=""
SET ZTSAVE("PSDED")=""
SET ZTSAVE("PSDIDIV")=""
+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 PSDY,X,Y,%
+2 WRITE @IOF,$$CJ^XLFSTR("CS Monitoring - Balance Adjustments Report",IOM)
+3 SET PSDY="Inpatient site: "_$PIECE(PSDIDIV,U,2)
+4 IF $GET(PSDPLOC)="^ALL"
SET PSDY=PSDY_" all Pharmacy Locations"
+5 WRITE !,$$CJ^XLFSTR(PSDY,IOM)
+6 WRITE !,$$CJ^XLFSTR("Balance Adjustments made: "_$PIECE(PSDSD,U,2)_" thru "_$PIECE(PSDED,U,2),IOM)
+7 SET PSDPG=PSDPG+1
+8 DO NOW^%DTC
WRITE !,"Report Run: "_$EXTRACT($$FMTE^XLFDT(%),1,18),?70,"PAGE: ",PSDPG
+9 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+10 QUIT
+11 ;
DQ ;Report Run
+1 NEW DFN,PSDA,PSDFD,PSDI,PSDIDT,PSDIV,PSDOUT,PSDP,PSDPG,PSDS,PSDRG,PSDUZ
+2 NEW PSDX,PSDX0,PSDX2,PSDXOR1,PSDY,X,Y,%
+3 KILL ^TMP("PSDNMBA",$JOB)
+4 IF IOST?1"C-".E
WRITE !!,?10,"Compiling report, please wait ..."
+5 SET PSDA=$ORDER(^PSD(58.84,"B","BALANCE ADJUSTMENT",0))
IF 'PSDA
GOTO DQQ
+6 SET PSDP=0
+7 FOR
SET PSDP=$ORDER(PSDPLOC(PSDP))
if 'PSDP
QUIT
SET ^TMP("PSDNMBA",$JOB,PSDPLOC(PSDP))=""
+8 SET PSDFD=+PSDSD
+9 FOR
SET PSDFD=$ORDER(^PSD(58.81,"AF",PSDFD))
if ('PSDFD)!(PSDFD]+PSDED)
QUIT
Begin DoDot:1
+10 SET PSDP=0
+11 FOR
SET PSDP=$ORDER(PSDPLOC(PSDP))
if 'PSDP
QUIT
Begin DoDot:2
+12 SET PSDX=0
+13 FOR
SET PSDX=$ORDER(^PSD(58.81,"AF",PSDFD,PSDP,PSDA,PSDX))
if 'PSDX
QUIT
Begin DoDot:3
+14 SET PSDX0=$GET(^PSD(58.81,PSDX,0))
IF PSDX0']""
QUIT
+15 SET PSDRG=$GET(^PSDRUG(+$PIECE(PSDX0,U,5),0))
+16 SET PSDUZ=+$PIECE(PSDX0,U,7)
SET PSDUZ=$PIECE($GET(^VA(200,+PSDUZ,0)),U,1)
+17 SET Y=PSDFD
DO D^DIQ
SET PSDS=Y
+18 SET ^TMP("PSDNMBA",$JOB,PSDPLOC(PSDP),PSDUZ,PSDX)=$PIECE(PSDX0,U,1)_U_$EXTRACT(PSDS,1,18)_U_$PIECE(PSDX0,U,6)_U_$PIECE(PSDRG,U,1)_U_$PIECE(PSDX0,U,16)
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
PRT ;Report print
+1 SET PSDPG=0
SET PSDOUT=0
+2 IF '$DATA(^TMP("PSDNMBA",$JOB))
Begin DoDot:1
+3 SET PSDIV=""
SET PSDPG=1
DO HD
DO PHD
+4 WRITE !!,?10,"<<<< NO DATA FOUND >>>>",!
End DoDot:1
GOTO DQQ
+5 SET PSDIV=""
+6 DO HD
DO PHD
+7 FOR
SET PSDIV=$ORDER(^TMP("PSDNMBA",$JOB,PSDIV))
if (PSDIV="")!(PSDOUT)
QUIT
Begin DoDot:1
+8 IF ($Y+3)>IOSL
DO PAGE
if PSDOUT
QUIT
DO HD
DO PHD
+9 WRITE !!,"Pharmacy Location: ",PSDIV
+10 SET PSDS=""
+11 IF $ORDER(^TMP("PSDNMBA",$JOB,PSDIV,PSDS))']""
WRITE !,?19,"NO DATA FOUND"
QUIT
+12 FOR
SET PSDS=$ORDER(^TMP("PSDNMBA",$JOB,PSDIV,PSDS))
if (PSDS="")!(PSDOUT)
QUIT
Begin DoDot:2
+13 IF ($Y+3)>IOSL
DO PAGE
if PSDOUT
QUIT
DO HD
DO PHD
+14 WRITE !!,"TRANSACTOR: ",PSDS
+15 SET PSDX=0
+16 FOR
SET PSDX=$ORDER(^TMP("PSDNMBA",$JOB,PSDIV,PSDS,PSDX))
if ('PSDX)!(PSDOUT)
QUIT
Begin DoDot:3
+17 SET PSDY=$GET(^TMP("PSDNMBA",$JOB,PSDIV,PSDS,PSDX))
+18 IF ($Y+3)>IOSL
DO PAGE
if PSDOUT
QUIT
DO HD
DO PHD
+19 WRITE !,$PIECE(PSDY,U,1),?10,$PIECE(PSDY,U,2),?33,$PIECE(PSDY,U,3),?40,$PIECE(PSDY,U,4)
+20 WRITE !,?10,"Reason: ",$PIECE(PSDY,U,5)
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
DQQ WRITE !
KILL PSDCII,PSDIDIV,PSDPLOC,PSDSD,PSDED,^TMP("PSDNMBA",$JOB)
DO ^%ZISC
QUIT
+1 ;
PHD ;
+1 WRITE !,"Trans. #",?10,"Date",?28,"Quantity",?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 ;PSDNMBA - CSM Balance Adjustments; 18 DEC 02
