PSA81PI ;PER/ME-Post-install routine for Patch PSA*3.0*81 ; 04 Jul 2020 2:00 PM
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**81**;Oct 24,1997;Build 10
Q
POST ; Entry point
K ^TMP("PSA81PI"),^XTMP("PSA81PI")
S $P(SETTXT,"=",80)="",$P(SETTXT1,"-",80)=""
D BMES^XPDUTL(" Starting post-install for PSA*3*81")
S PSOLINE=0
D SETTXT(SETTXT)
D SETTXT(" This report displays drugs with a negative balance in the")
D SETTXT(" Controlled Substance master vault(s).")
D SETTXT(SETTXT1)
D SETTXT(" If any negative balances are found that require assistance")
D SETTXT(" to correct, please log a ticket and request it be sent to")
D SETTXT(" SPM.Health.PCS.Sub_1.")
D SETTXT(SETTXT)
;
REPORT ;
S VAULT=0
F S VAULT=$O(^PSD(58.8,VAULT)) Q:+VAULT=0 D
.I $P(^PSD(58.8,VAULT,0),U,2)="M" S PSDS=VAULT,PSDSN=$P(^PSD(58.8,VAULT,0),U) D START
D MAIL
D BMES^XPDUTL(" Mailman message sent.")
D BMES^XPDUTL(" Finished post-install for PSA*3*81.")
D BMES^XPDUTL("")
Q
;
START ;entry for compile report data
K ^TMP("PSDBALI"),CNT
F PSD=0:0 S PSD=$O(^PSD(58.8,+PSDS,1,PSD)) Q:'PSD I $D(^PSD(58.8,+PSDS,1,PSD,0)) D
.S DEA=+$P($G(^PSDRUG(PSD,0)),"^",3)
.S PSDR(+PSD)=""
F PSD=0:0 S PSD=$O(PSDR(PSD)) Q:'PSD I $D(^PSD(58.8,+PSDS,1,PSD,0)) S NODE=^(0) D
.S PSDOK="" I +$P(NODE,"^",14),+$P(NODE,"^",14)'>DT Q:'+$P(NODE,"^",4) S PSDOK="*"
.S BAL=+$P(NODE,"^",4),DRUGN=$S($P($G(^PSDRUG(+PSD,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSD_" NAME MISSING"),SLVL=+$P(NODE,"^",3),EXP=$S(+$P(NODE,"^",12):+$P(NODE,"^",12),1:"")
.I EXP S Y=EXP X ^DD("DD") S EXP=Y
.S ^TMP("PSDBALI",$J,DRUGN,PSD)=BAL_"^"_PSDOK_"^"_SLVL_"^"_EXP_"^"_$P($G(^PSDRUG(+PSD,0)),"^",3)
PRINT ;set each drug line in the report
S (PSDOUT)=0 D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
D HDR
I '$D(^TMP("PSDBALI",$J)) W !!,?15,"**** NO STOCK BALANCE DATA AVAILABLE ****",!!
S PSDR="" F S PSDR=$O(^TMP("PSDBALI",$J,PSDR)) Q:PSDR=""!(PSDOUT) F PSD=0:0 S PSD=$O(^TMP("PSDBALI",$J,PSDR,PSD)) Q:'PSD D Q:PSDOUT
.S NODE=^TMP("PSDBALI",$J,PSDR,PSD),BAL=+NODE,PSDOK=$P(NODE,"^",2),SLVL=$P(NODE,"^",3),EXP=$P(NODE,"^",4)
.S PSD=PSD_$J("",15-$L(PSD))
.S PSDR=PSDR_$J("",41-$L(PSDR))
.S BAL=BAL_$J("",10-$L(BAL))
.I BAL<0 S RPLINE=PSD_PSDR_" "_BAL D SETTXT(RPLINE) S CNT=1
I '$D(CNT) D SETTXT("NO NEGATIVE BALANCES FOUND")
D SETTXT("")
;D SETTXT("END OF REPORT FOR THE "_PSDSN_" ("_VAULT_")")
D SETTXT("End of report for the "_PSDSN_" ("_VAULT_")")
D SETTXT(""),SETTXT("")
Q
;
END ;
K %,BAL,DRUGN,EXP,NODE,PSD,PSDOK,PSDOUT,PSDR,PSDRN,PSDS,PSDSN,PSOLINE,SETTXT,SETTXT1,SLVL,RPDT,RPLINE,VAULT,Y
K ^TMP("PSDBALI",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,DEA,SCH
K ^TMP("PSA81PI",$J),^XTMP("PSA81PI",$J)
Q
;
HDR ;header
D SETTXT("")
D SETTXT($J("",12)_"Negative balance report for the "_PSDSN_" ("_VAULT_")")
D SETTXT($J("",29)_RPDT)
D SETTXT("")
D SETTXT("DRUG IEN"_$J("",14)_"DRUG"_$J("",34)_"CURRENT BALANCE")
D SETTXT(SETTXT1)
D SETTXT("")
Q
;
SETTXT(TXT) ; Setting Plain Text
S PSOLINE=$G(PSOLINE)+1,^XTMP("PSA81PI",$J,PSOLINE)=TXT
Q
;
MAIL ; Sends Mailman message
N II,XMX,XMSUB,XMDUZ,XMTEXT,XMY
S II=0 F S II=$O(^XUSEC("PSNMGR",II)) Q:'II S XMY(II)=""
S XMY(DUZ)="",XMSUB="PSA*3*81 - Negative balances in Controlled Substance Vault Report"
S XMDUZ=.5,XMTEXT="^XTMP(""PSA81PI"",$J," N DIFROM D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSA81PI 3436 printed Sep 23, 2025@19:24:53 Page 2
PSA81PI ;PER/ME-Post-install routine for Patch PSA*3.0*81 ; 04 Jul 2020 2:00 PM
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**81**;Oct 24,1997;Build 10
+2 QUIT
POST ; Entry point
+1 KILL ^TMP("PSA81PI"),^XTMP("PSA81PI")
+2 SET $PIECE(SETTXT,"=",80)=""
SET $PIECE(SETTXT1,"-",80)=""
+3 DO BMES^XPDUTL(" Starting post-install for PSA*3*81")
+4 SET PSOLINE=0
+5 DO SETTXT(SETTXT)
+6 DO SETTXT(" This report displays drugs with a negative balance in the")
+7 DO SETTXT(" Controlled Substance master vault(s).")
+8 DO SETTXT(SETTXT1)
+9 DO SETTXT(" If any negative balances are found that require assistance")
+10 DO SETTXT(" to correct, please log a ticket and request it be sent to")
+11 DO SETTXT(" SPM.Health.PCS.Sub_1.")
+12 DO SETTXT(SETTXT)
+13 ;
REPORT ;
+1 SET VAULT=0
+2 FOR
SET VAULT=$ORDER(^PSD(58.8,VAULT))
if +VAULT=0
QUIT
Begin DoDot:1
+3 IF $PIECE(^PSD(58.8,VAULT,0),U,2)="M"
SET PSDS=VAULT
SET PSDSN=$PIECE(^PSD(58.8,VAULT,0),U)
DO START
End DoDot:1
+4 DO MAIL
+5 DO BMES^XPDUTL(" Mailman message sent.")
+6 DO BMES^XPDUTL(" Finished post-install for PSA*3*81.")
+7 DO BMES^XPDUTL("")
+8 QUIT
+9 ;
START ;entry for compile report data
+1 KILL ^TMP("PSDBALI"),CNT
+2 FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,+PSDS,1,PSD))
if 'PSD
QUIT
IF $DATA(^PSD(58.8,+PSDS,1,PSD,0))
Begin DoDot:1
+3 SET DEA=+$PIECE($GET(^PSDRUG(PSD,0)),"^",3)
+4 SET PSDR(+PSD)=""
End DoDot:1
+5 FOR PSD=0:0
SET PSD=$ORDER(PSDR(PSD))
if 'PSD
QUIT
IF $DATA(^PSD(58.8,+PSDS,1,PSD,0))
SET NODE=^(0)
Begin DoDot:1
+6 SET PSDOK=""
IF +$PIECE(NODE,"^",14)
IF +$PIECE(NODE,"^",14)'>DT
if '+$PIECE(NODE,"^",4)
QUIT
SET PSDOK="*"
+7 SET BAL=+$PIECE(NODE,"^",4)
SET DRUGN=$SELECT($PIECE($GET(^PSDRUG(+PSD,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSD_" NAME MISSING")
SET SLVL=+$PIECE(NODE,"^",3)
SET EXP=$SELECT(+$PIECE(NODE,"^",12):+$PIECE(NODE,"^",12),1:"")
+8 IF EXP
SET Y=EXP
XECUTE ^DD("DD")
SET EXP=Y
+9 SET ^TMP("PSDBALI",$JOB,DRUGN,PSD)=BAL_"^"_PSDOK_"^"_SLVL_"^"_EXP_"^"_$PIECE($GET(^PSDRUG(+PSD,0)),"^",3)
End DoDot:1
PRINT ;set each drug line in the report
+1 SET (PSDOUT)=0
DO NOW^%DTC
SET Y=+$EXTRACT(%,1,12)
XECUTE ^DD("DD")
SET RPDT=Y
+2 DO HDR
+3 IF '$DATA(^TMP("PSDBALI",$JOB))
WRITE !!,?15,"**** NO STOCK BALANCE DATA AVAILABLE ****",!!
+4 SET PSDR=""
FOR
SET PSDR=$ORDER(^TMP("PSDBALI",$JOB,PSDR))
if PSDR=""!(PSDOUT)
QUIT
FOR PSD=0:0
SET PSD=$ORDER(^TMP("PSDBALI",$JOB,PSDR,PSD))
if 'PSD
QUIT
Begin DoDot:1
+5 SET NODE=^TMP("PSDBALI",$JOB,PSDR,PSD)
SET BAL=+NODE
SET PSDOK=$PIECE(NODE,"^",2)
SET SLVL=$PIECE(NODE,"^",3)
SET EXP=$PIECE(NODE,"^",4)
+6 SET PSD=PSD_$JUSTIFY("",15-$LENGTH(PSD))
+7 SET PSDR=PSDR_$JUSTIFY("",41-$LENGTH(PSDR))
+8 SET BAL=BAL_$JUSTIFY("",10-$LENGTH(BAL))
+9 IF BAL<0
SET RPLINE=PSD_PSDR_" "_BAL
DO SETTXT(RPLINE)
SET CNT=1
End DoDot:1
if PSDOUT
QUIT
+10 IF '$DATA(CNT)
DO SETTXT("NO NEGATIVE BALANCES FOUND")
+11 DO SETTXT("")
+12 ;D SETTXT("END OF REPORT FOR THE "_PSDSN_" ("_VAULT_")")
+13 DO SETTXT("End of report for the "_PSDSN_" ("_VAULT_")")
+14 DO SETTXT("")
DO SETTXT("")
+15 QUIT
+16 ;
END ;
+1 KILL %,BAL,DRUGN,EXP,NODE,PSD,PSDOK,PSDOUT,PSDR,PSDRN,PSDS,PSDSN,PSOLINE,SETTXT,SETTXT1,SLVL,RPDT,RPLINE,VAULT,Y
+2 KILL ^TMP("PSDBALI",$JOB),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,DEA,SCH
+3 KILL ^TMP("PSA81PI",$JOB),^XTMP("PSA81PI",$JOB)
+4 QUIT
+5 ;
HDR ;header
+1 DO SETTXT("")
+2 DO SETTXT($JUSTIFY("",12)_"Negative balance report for the "_PSDSN_" ("_VAULT_")")
+3 DO SETTXT($JUSTIFY("",29)_RPDT)
+4 DO SETTXT("")
+5 DO SETTXT("DRUG IEN"_$JUSTIFY("",14)_"DRUG"_$JUSTIFY("",34)_"CURRENT BALANCE")
+6 DO SETTXT(SETTXT1)
+7 DO SETTXT("")
+8 QUIT
+9 ;
SETTXT(TXT) ; Setting Plain Text
+1 SET PSOLINE=$GET(PSOLINE)+1
SET ^XTMP("PSA81PI",$JOB,PSOLINE)=TXT
+2 QUIT
+3 ;
MAIL ; Sends Mailman message
+1 NEW II,XMX,XMSUB,XMDUZ,XMTEXT,XMY
+2 SET II=0
FOR
SET II=$ORDER(^XUSEC("PSNMGR",II))
if 'II
QUIT
SET XMY(II)=""
+3 SET XMY(DUZ)=""
SET XMSUB="PSA*3*81 - Negative balances in Controlled Substance Vault Report"
+4 SET XMDUZ=.5
SET XMTEXT="^XTMP(""PSA81PI"",$J,"
NEW DIFROM
DO ^XMD
+5 QUIT
