PSOTPPOS ;BIR/RTR-Patch 145 Post Install routine ;07/27/03
;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
;Reference to SDPHARM supported by DBIA 4193
;Reference to SDPBE supported by DBIA 4194
;Reference to DIC(19 supported by DBIA 2246
;Reference to DIC(4 supported by DBIA 2251
;
G FILE
N PSOTPLLZ,PSOTPFLG
S PSOTPFLG=0
S PSOTPLLZ="" F S PSOTPLLZ=$O(^PS(53,"B","NON-VA",PSOTPLLZ)) Q:PSOTPLLZ="" D
.I $P($G(^PS(53,PSOTPLLZ,0)),"^")="NON-VA" S $P(^(0),"^",6)=5,PSOTPFLG=PSOTPFLG+1
I '$G(PSOTPFLG) D BMES^XPDUTL("Could not find a NON-VA entry in the RX PATIENT STATUS file.") D MES^XPDUTL("Please contact National Vista Support!")
I $G(PSOTPFLG)>1 D BMES^XPDUTL("Found multiple entries of NON-VA in the RX PATIENT STATUS file.") D MES^XPDUTL("Please contact National Vista Support!")
;
FILE ;Populate TPB file
;N VARIABLE
;S ZTDTH=""
;I $D(ZTQUEUED) S ZTDTH=$H
L +^XTMP("SDPSO145"):0 I '$T D Q
.D BMES^XPDUTL("Post-Init for patch PSO*7*145 is already running. Halting..")
;I ZTDTH="" D
;.D BMES^XPDUTL("Auto-Populate TPB ELIGIBILITY (#52.91) File.")
;.D BMES^XPDUTL("If no start date/time is entered when prompted, the background job will ")
;.D MES^XPDUTL("be queued to run NOW.")
;.D GETDATE
;.D BMES^XPDUTL("Queuing background job to populate TPB ELIGIBILITY (#52.91) File.")
;S ZTDTH=@XPDGREF@("PSOPINIT")
I '$G(^XTMP("SDPSO145","PSOTINIT")) D BMES^XPDUTL("Install aborted, cannot determine post-install task time..") Q
S ZTDTH=$G(^XTMP("SDPSO145","PSOTINIT")) L -^XTMP("SDPSO145")
S ZTRTN="START^PSOTPPOS",ZTIO="",ZTDESC="Populate TPB ELIGIBILITY FILE" D ^%ZTLOAD K ZTDTH,ZTRTN,ZTIO,ZTDESC
I $D(ZTSK)&('$D(ZTQUEUED)) D BMES^XPDUTL("Task Queued!")
Q
START ;Build TPC Eligibility file
I '$G(DT) S DT=$$DT^XLFDT
S U="^"
N PSOACTRX,PSOENRLD,PSOLPQT,PSONODAD,PSOTG1,PSOTG2,PSOTG3,PSOETOT,PSOITOT,PSOTLOCK,PSOTPSNM,PSOSTATI
S (PSOETOT,PSOITOT)=0
S PSOTLOCK=0
L +^XTMP("SDPSO145"):0 I '$T S PSOTLOCK=1 D MAIL S:$D(ZTQUEUED) ZTREQ="@" Q
K ^XTMP("SDPSO145")
S X1=DT,X2=+60 D C^%DTC S ^XTMP("SDPSO145",0)=$G(X)_"^"_DT K X1,X2
D NOW^%DTC S Y=% D DD^%DT S ^XTMP("SDPSO145","START")=$G(Y)
D ^SDPHARM
D ^SDPBE
I '$D(^XTMP("SDPSO145","PAT")) G PASS
S PSOTG1="" F S PSOTG1=$O(^XTMP("SDPSO145","PAT","E",PSOTG1)) Q:PSOTG1="" D
.I $D(^PS(52.91,PSOTG1,0)) Q ;Multiple Installs check
.S PSOLPQT=0
.S PSOTG2="" F S PSOTG2=$O(^XTMP("SDPSO145","PAT","E",PSOTG1,PSOTG2)) Q:PSOTG2=""!(PSOLPQT) S PSOTG3="" F S PSOTG3=$O(^XTMP("SDPSO145","PAT","E",PSOTG1,PSOTG2,PSOTG3)) Q:PSOTG3=""!(PSOLPQT) D
..S PSONODAD=$G(^XTMP("SDPSO145","PAT","E",PSOTG1,PSOTG2,PSOTG3))
..I $P($G(^PS(52.91,PSOTG1,0)),"^",5),'PSONODAD D Q ;Entry exists, if this date is sooner, replace, if you get a Station Number
...I PSOTG3'<$P($G(^PS(52.91,PSOTG1,0)),"^",5) Q
...I PSOTG2=$P($G(^PS(52.91,PSOTG1,0)),"^",8) K DIE,DA,DR S DIE="^PS(52.91,",DA=PSOTG1,DR="4////"_PSOTG3 D ^DIE K DIE,DA,DR Q
...K PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+PSOTG2,DIQ(0)="I",DIQ="PSOSTATI" D EN^DIQ1 S PSOTPSNM=$G(PSOSTATI(4,+PSOTG2,99,"I")) K DIC,DIQ,DR,DA,PSOSTATI
...I $G(PSOTPSNM)="" K PSOTPSNM Q
...K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTG1,DR="4////"_PSOTG3_";6////"_PSOTPSNM_";7////"_PSOTG2 D ^DIE K DA,DIE,DR
...K PSOTPSNM
..I $D(^PS(52.91,PSOTG1,0)),'PSONODAD D Q
...I PSOTG2=$P($G(^PS(52.91,PSOTG1,0)),"^",8) K DIE,DA,DR S DIE="^PS(52.91,",DA=PSOTG1,DR="4////"_PSOTG3 D ^DIE K DIE,DA,DR Q
...K PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+PSOTG2,DIQ(0)="I",DIQ="PSOSTATI" D EN^DIQ1 S PSOTPSNM=$G(PSOSTATI(4,+PSOTG2,99,"I")) K DIC,DIQ,DR,DA,PSOSTATI
...I $G(PSOTPSNM)="" K PSOTPSNM Q
...K DA,DIE,DR S DIE="^PS(52.91,",DA=PSOTG1,DR="4////"_PSOTG3_";6////"_PSOTPSNM_";7////"_PSOTG2 D ^DIE K DA,DIE,DR
...K PSOTPSNM
..I $D(^PS(52.91,PSOTG1,0)) Q
..K PSOENRLD S PSOENRLD=$$ENR^PSOTPCRX(PSOTG1,3030725) I '$G(PSOENRLD) S ^XTMP("SDPSO145","NOTEN",PSOTG1)="",PSOLPQT=1 Q
..K PSOACTRX S PSOACTRX=$$RX^PSOTPCRX(PSOTG1) I $G(PSOACTRX) D EWL^PSOTPCRX S PSOLPQT=1 Q
..K PSOTPSNM
..K PSOSTATI,DIC,DIQ,DD,DR S DIC=4,DR="99",DA=+PSOTG2,DIQ(0)="I",DIQ="PSOSTATI" D EN^DIQ1 S PSOTPSNM=$G(PSOSTATI(4,+PSOTG2,99,"I")) K DIC,DIQ,DR,DA,PSOSTATI
..I $G(PSOTPSNM)="" S ^XTMP("SDPSO145","PROB1",PSOTG1)="" K PSOTPSNM Q
..I '$D(^PS(52.91,PSOTG1,0)) K DIC S DIC="^PS(52.91,",DIC(0)="L",(X,DINUM)=PSOTG1,DIC("DR")="1////"_DT_";5////"_"E"_";6////"_PSOTPSNM_";7////"_PSOTG2 S:'$G(PSONODAD) DIC("DR")=DIC("DR")_";4////"_PSOTG3 D
...K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM
...I Y'>0 S ^XTMP("SDPSO145","PROB",PSOTG1)="" Q
...S PSOETOT=PSOETOT+1
...K ^XTMP("SDPSO145","PROB",PSOTG1)
...K ^XTMP("SDPSO145","PROB1",PSOTG1)
;LOOP THROUGH SCHEDULING XTMP HERE
D SCH^PSOTPCRX
PASS ;
S ^XTMP("SDPSO145","ELIG")=+$G(PSOETOT)
S ^XTMP("SDPSO145","INEL")=+$G(PSOITOT)
D EN^PSO145PS
D NOW^%DTC S Y=% D DD^%DT S ^XTMP("SDPSO145","STOP")=$G(Y) K Y
;***need HL7 routine name (moved to phase 2)
;I '$$PATCH^XPDUTL("PSO*7.0*145") S ZTRTN="NAME^EXTRACT",ZTIO="",ZTDESC="TPB EIGIBILITY FILE EXTRACT",ZTDTH=$H D ^%ZTLOAD K ZTRTN,ZTIO,ZTDESC,ZTDTH
D MAIL
L -^XTMP("SDPSO145")
K DA,DIE,DR S DA=$O(^DIC(19,"B","PSO TPB PATIENT ENTER/EDIT",0)) I DA S DIE="^DIC(19,",DR="2////"_"@" D ^DIE K DIE,DA,DR
S:$D(ZTQUEUED) ZTREQ="@"
Q
MAIL ;
N PSOTUCI,PSOTUCI1,XMTEXT,XMSUB,XMDUZ,XMY,PSOMLIN,PSOMLINN,PSOTDEL,PSOMNAME,PSOMLLP,PSOMLCT,PSOSTEXT,PSOQTIME,X,Y,%
S PSOMLINN="" S PSOMLIN=$P($G(^XMB(1,1,"XUS")),"^",17) I PSOMLIN'>0 S PSOMLIN=$G(DUZ(2))
I PSOMLIN S PSOMLINN=$P($G(^DIC(4,PSOMLIN,0)),"^")
S XMSUB=$S($G(PSOMLINN)="":"Unknown Institution",1:$G(PSOMLINN)_" ("_$G(PSOMLIN)_")")_" TPB FILE BUILD"
S XMDUZ="Patch PSO*7*145 Post Install" I $G(DUZ) S XMY(DUZ)=""
X ^%ZOSF("UCI") S PSOTUCI=$P($G(Y),",") S PSOTUCI1=$P($G(^%ZOSF("PROD")),",") I PSOTUCI=PSOTUCI1 D
.S XMY("TEMPLETON,SHANNON@DOMAIN.EXT")=""
.S XMY("BROCKERT,JUDITH@DOMAIN.EXT")=""
.S XMY("CHOW,ANGELA@DOMAIN.EXT")=""
.S XMY("RUZBACKI,RON@DOMAIN.EXT")=""
.S XMY("BARRON,LUANNE@DOMAIN.EXT")=""
.S XMY("WASHINGTON,JANET P@DOMAIN.EXT")=""
I $G(PSOTLOCK) D G MAILX
.D NOW^%DTC S Y=% X ^DD("DD") S PSOQTIME=Y
.K PSOSTEXT S PSOSTEXT(1)="The TPB ELIGIBILITY file building, and other post-install functions of",PSOSTEXT(2)="patch PSO*7*145, queued to run at "_$G(PSOQTIME)_",",PSOSTEXT(3)="was NOT run, because the XTMP patient global was locked."
.S PSOSTEXT(4)="This Post-Install may have been queued by another user. Please contact",PSOSTEXT(5)="Customer Support."
S PSOSTEXT(1)="The Post-Init from Patch PSO*7.0*145 is complete. The TPB ELIGIBILITY",PSOSTEXT(2)="File (#52.91) has been populated.",PSOSTEXT(3)=" "
S PSOSTEXT(4)="The job started at "_$G(^XTMP("SDPSO145","START")),PSOSTEXT(5)="The job ended at "_$G(^XTMP("SDPSO145","STOP")),PSOSTEXT(6)=" "
S PSOSTEXT(7)="Total number of eligible patients added to file = "_$G(^XTMP("SDPSO145","ELIG")),PSOSTEXT(8)="Total number of ineligible patients added to file = "_$G(^XTMP("SDPSO145","INEL")),PSOSTEXT(9)=" "
S PSOMLCT=10
S PSOTDEL="" F S PSOTDEL=$O(^XTMP("SDPSO145","PROB",PSOTDEL)) Q:PSOTDEL="" I $D(^PS(52.91,PSOTDEL,0)) K ^XTMP("SDPSO145","PROB",PSOTDEL)
S PSOTDEL="" F S PSOTDEL=$O(^XTMP("SDPDO145","PROB1",PSOTDEL)) Q:PSOTDEL="" I $D(^PS(52.91,PSOTDEL,0)) K ^XTMP("SDPSO145","PROB1",PSOTDEL)
I $O(^XTMP("SDPSO145","PROB",0)) D
.S PSOSTEXT(PSOMLCT)="The following patients qualify for the Transitional Pharmacy",PSOMLCT=PSOMLCT+1,PSOSTEXT(PSOMLCT)="Benefit, but were unable to be added to the file for unknown reasons:",PSOMLCT=PSOMLCT+1
.S PSOMLLP="" F S PSOMLLP=$O(^XTMP("SDPSO145","PROB",PSOMLLP)) Q:PSOMLLP="" D
..D PNM
..S PSOSTEXT(PSOMLCT)=$G(PSOMNAME)_$G(^XTMP("SDPSO145","PROB",PSOMLLP)),PSOMLCT=PSOMLCT+1
I PSOMLCT>10 S PSOSTEXT(PSOMLCT)=" ",PSOMLCT=PSOMLCT+1
I $O(^XTMP("SDPSO145","PROB1",0)) D
.S PSOSTEXT(PSOMLCT)="The following patients qualify for the Transitional Pharmacy",PSOMLCT=PSOMLCT+1,PSOSTEXT(PSOMLCT)="Benefit, but were unable to be added to the file because a Station Number",PSOMLCT=PSOMLCT+1
.S PSOSTEXT(PSOMLCT)="could not be found for the Institution associated with the patient:",PSOMLCT=PSOMLCT+1
.S PSOMLLP="" F S PSOMLLP=$O(^XTMP("SDPSO145","PROB1",PSOMLLP)) Q:PSOMLLP="" D
..D PNM
..S PSOSTEXT(PSOMLCT)=$G(PSOMNAME)_$G(^XTMP("SDPSO145","PROB1",PSOMLLP)),PSOMLCT=PSOMLCT+1
MAILX ;
I $O(XMY(""))'="" S XMTEXT="PSOSTEXT(" N DIFROM D ^XMD
K PSOSTEXT,XMTEXT,XMSUB,XMDUZ,XMY
Q
GETDATE ;
N PSONOW,PSOTODAY,X,Y,PSOSAVEY,PSOSAVEX,PSOXXX
S ZTDTH="",PSONOW=0
D NOW^%DTC S (Y,PSOTODAY)=% D DD^%DT
D BMES^XPDUTL("At the following prompt, enter a starting date@time")
D MES^XPDUTL("or enter NOW to queue the job immediately.")
D BMES^XPDUTL("If this prompting is during patch installation, you may not see what you type.")
W ! K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Queue TPB Eligibility File building job for what Date@Time: "
D ^%DT K %DT I $D(DTOUT)!(Y<0) W "Task will be queued to run NOW" S ZTDTH=$H,PSONOW=1
S PSOSAVEY=Y
I 'PSONOW,PSOSAVEY>0 D
.S Y=PSOSAVEY D DD^%DT
.S PSOSAVEX=Y
I 'PSONOW,$G(PSOSAVEY)<0 K PSOXXX,PSOSAVEX,PSOSAVEY,X,Y,PSONOW,PSOTODAY G GETDATE
ASK ;
D BMES^XPDUTL("Task will be queued to run "_$S(PSONOW:"NOW",1:PSOSAVEX)_". Is that correct? ")
R PSOXXX:300 S:'$T!($G(PSOXXX)="") PSOXXX="Y" S PSOXXX=$$UP^XLFSTR(PSOXXX) I PSOXXX'="Y",PSOXXX'="YES",PSOXXX'="N",PSOXXX'="NO" W "Enter Y or N" G ASK
I PSOXXX'="Y",PSOXXX'="YES" K PSOXXX,PSOSAVEX,PSOSAVEY,X,Y,PSONOW,PSOTODAY G GETDATE
I PSOSAVEY>0,ZTDTH="" S ZTDTH=PSOSAVEY
I ZTDTH="" S ZTDTH=$H
Q
PNM ;
N DFN,VADM,VA,VAERR
K PSOMNANE,VADM
S DFN=+$G(PSOMLLP) I 'DFN Q
D DEM^VADPT I $G(VADM(1))="" K VADM Q
S PSOMNAME=$G(VADM(1))
K VADM
K VA,VAERR S DFN=+$G(PSOMLLP) D PID^VADPT6
S PSOMNAME=PSOMNAME_" "_"("_$G(VA("BID"))_")"
K VA,VAERR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPPOS 9888 printed Sep 23, 2025@20:12:23 Page 2
PSOTPPOS ;BIR/RTR-Patch 145 Post Install routine ;07/27/03
+1 ;;7.0;OUTPATIENT PHARMACY;**145**;DEC 1997
+2 ;Reference to SDPHARM supported by DBIA 4193
+3 ;Reference to SDPBE supported by DBIA 4194
+4 ;Reference to DIC(19 supported by DBIA 2246
+5 ;Reference to DIC(4 supported by DBIA 2251
+6 ;
+7 GOTO FILE
+8 NEW PSOTPLLZ,PSOTPFLG
+9 SET PSOTPFLG=0
+10 SET PSOTPLLZ=""
FOR
SET PSOTPLLZ=$ORDER(^PS(53,"B","NON-VA",PSOTPLLZ))
if PSOTPLLZ=""
QUIT
Begin DoDot:1
+11 IF $PIECE($GET(^PS(53,PSOTPLLZ,0)),"^")="NON-VA"
SET $PIECE(^(0),"^",6)=5
SET PSOTPFLG=PSOTPFLG+1
End DoDot:1
+12 IF '$GET(PSOTPFLG)
DO BMES^XPDUTL("Could not find a NON-VA entry in the RX PATIENT STATUS file.")
DO MES^XPDUTL("Please contact National Vista Support!")
+13 IF $GET(PSOTPFLG)>1
DO BMES^XPDUTL("Found multiple entries of NON-VA in the RX PATIENT STATUS file.")
DO MES^XPDUTL("Please contact National Vista Support!")
+14 ;
FILE ;Populate TPB file
+1 ;N VARIABLE
+2 ;S ZTDTH=""
+3 ;I $D(ZTQUEUED) S ZTDTH=$H
+4 LOCK +^XTMP("SDPSO145"):0
IF '$TEST
Begin DoDot:1
+5 DO BMES^XPDUTL("Post-Init for patch PSO*7*145 is already running. Halting..")
End DoDot:1
QUIT
+6 ;I ZTDTH="" D
+7 ;.D BMES^XPDUTL("Auto-Populate TPB ELIGIBILITY (#52.91) File.")
+8 ;.D BMES^XPDUTL("If no start date/time is entered when prompted, the background job will ")
+9 ;.D MES^XPDUTL("be queued to run NOW.")
+10 ;.D GETDATE
+11 ;.D BMES^XPDUTL("Queuing background job to populate TPB ELIGIBILITY (#52.91) File.")
+12 ;S ZTDTH=@XPDGREF@("PSOPINIT")
+13 IF '$GET(^XTMP("SDPSO145","PSOTINIT"))
DO BMES^XPDUTL("Install aborted, cannot determine post-install task time..")
QUIT
+14 SET ZTDTH=$GET(^XTMP("SDPSO145","PSOTINIT"))
LOCK -^XTMP("SDPSO145")
+15 SET ZTRTN="START^PSOTPPOS"
SET ZTIO=""
SET ZTDESC="Populate TPB ELIGIBILITY FILE"
DO ^%ZTLOAD
KILL ZTDTH,ZTRTN,ZTIO,ZTDESC
+16 IF $DATA(ZTSK)&('$DATA(ZTQUEUED))
DO BMES^XPDUTL("Task Queued!")
+17 QUIT
START ;Build TPC Eligibility file
+1 IF '$GET(DT)
SET DT=$$DT^XLFDT
+2 SET U="^"
+3 NEW PSOACTRX,PSOENRLD,PSOLPQT,PSONODAD,PSOTG1,PSOTG2,PSOTG3,PSOETOT,PSOITOT,PSOTLOCK,PSOTPSNM,PSOSTATI
+4 SET (PSOETOT,PSOITOT)=0
+5 SET PSOTLOCK=0
+6 LOCK +^XTMP("SDPSO145"):0
IF '$TEST
SET PSOTLOCK=1
DO MAIL
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+7 KILL ^XTMP("SDPSO145")
+8 SET X1=DT
SET X2=+60
DO C^%DTC
SET ^XTMP("SDPSO145",0)=$GET(X)_"^"_DT
KILL X1,X2
+9 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET ^XTMP("SDPSO145","START")=$GET(Y)
+10 DO ^SDPHARM
+11 DO ^SDPBE
+12 IF '$DATA(^XTMP("SDPSO145","PAT"))
GOTO PASS
+13 SET PSOTG1=""
FOR
SET PSOTG1=$ORDER(^XTMP("SDPSO145","PAT","E",PSOTG1))
if PSOTG1=""
QUIT
Begin DoDot:1
+14 ;Multiple Installs check
IF $DATA(^PS(52.91,PSOTG1,0))
QUIT
+15 SET PSOLPQT=0
+16 SET PSOTG2=""
FOR
SET PSOTG2=$ORDER(^XTMP("SDPSO145","PAT","E",PSOTG1,PSOTG2))
if PSOTG2=""!(PSOLPQT)
QUIT
SET PSOTG3=""
FOR
SET PSOTG3=$ORDER(^XTMP("SDPSO145","PAT","E",PSOTG1,PSOTG2,PSOTG3))
if PSOTG3=""!(PSOLPQT)
QUIT
Begin DoDot:2
+17 SET PSONODAD=$GET(^XTMP("SDPSO145","PAT","E",PSOTG1,PSOTG2,PSOTG3))
+18 ;Entry exists, if this date is sooner, replace, if you get a Station Number
IF $PIECE($GET(^PS(52.91,PSOTG1,0)),"^",5)
IF 'PSONODAD
Begin DoDot:3
+19 IF PSOTG3'<$PIECE($GET(^PS(52.91,PSOTG1,0)),"^",5)
QUIT
+20 IF PSOTG2=$PIECE($GET(^PS(52.91,PSOTG1,0)),"^",8)
KILL DIE,DA,DR
SET DIE="^PS(52.91,"
SET DA=PSOTG1
SET DR="4////"_PSOTG3
DO ^DIE
KILL DIE,DA,DR
QUIT
+21 KILL PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR
SET DIC=4
SET DR="99"
SET DA=+PSOTG2
SET DIQ(0)="I"
SET DIQ="PSOSTATI"
DO EN^DIQ1
SET PSOTPSNM=$GET(PSOSTATI(4,+PSOTG2,99,"I"))
KILL DIC,DIQ,DR,DA,PSOSTATI
+22 IF $GET(PSOTPSNM)=""
KILL PSOTPSNM
QUIT
+23 KILL DA,DIE,DR
SET DIE="^PS(52.91,"
SET DA=PSOTG1
SET DR="4////"_PSOTG3_";6////"_PSOTPSNM_";7////"_PSOTG2
DO ^DIE
KILL DA,DIE,DR
+24 KILL PSOTPSNM
End DoDot:3
QUIT
+25 IF $DATA(^PS(52.91,PSOTG1,0))
IF 'PSONODAD
Begin DoDot:3
+26 IF PSOTG2=$PIECE($GET(^PS(52.91,PSOTG1,0)),"^",8)
KILL DIE,DA,DR
SET DIE="^PS(52.91,"
SET DA=PSOTG1
SET DR="4////"_PSOTG3
DO ^DIE
KILL DIE,DA,DR
QUIT
+27 KILL PSOTPSNM,PSOSTATI,DIC,DIQ,DD,DR
SET DIC=4
SET DR="99"
SET DA=+PSOTG2
SET DIQ(0)="I"
SET DIQ="PSOSTATI"
DO EN^DIQ1
SET PSOTPSNM=$GET(PSOSTATI(4,+PSOTG2,99,"I"))
KILL DIC,DIQ,DR,DA,PSOSTATI
+28 IF $GET(PSOTPSNM)=""
KILL PSOTPSNM
QUIT
+29 KILL DA,DIE,DR
SET DIE="^PS(52.91,"
SET DA=PSOTG1
SET DR="4////"_PSOTG3_";6////"_PSOTPSNM_";7////"_PSOTG2
DO ^DIE
KILL DA,DIE,DR
+30 KILL PSOTPSNM
End DoDot:3
QUIT
+31 IF $DATA(^PS(52.91,PSOTG1,0))
QUIT
+32 KILL PSOENRLD
SET PSOENRLD=$$ENR^PSOTPCRX(PSOTG1,3030725)
IF '$GET(PSOENRLD)
SET ^XTMP("SDPSO145","NOTEN",PSOTG1)=""
SET PSOLPQT=1
QUIT
+33 KILL PSOACTRX
SET PSOACTRX=$$RX^PSOTPCRX(PSOTG1)
IF $GET(PSOACTRX)
DO EWL^PSOTPCRX
SET PSOLPQT=1
QUIT
+34 KILL PSOTPSNM
+35 KILL PSOSTATI,DIC,DIQ,DD,DR
SET DIC=4
SET DR="99"
SET DA=+PSOTG2
SET DIQ(0)="I"
SET DIQ="PSOSTATI"
DO EN^DIQ1
SET PSOTPSNM=$GET(PSOSTATI(4,+PSOTG2,99,"I"))
KILL DIC,DIQ,DR,DA,PSOSTATI
+36 IF $GET(PSOTPSNM)=""
SET ^XTMP("SDPSO145","PROB1",PSOTG1)=""
KILL PSOTPSNM
QUIT
+37 IF '$DATA(^PS(52.91,PSOTG1,0))
KILL DIC
SET DIC="^PS(52.91,"
SET DIC(0)="L"
SET (X,DINUM)=PSOTG1
SET DIC("DR")="1////"_DT_";5////"_"E"_";6////"_PSOTPSNM_";7////"_PSOTG2
if '$GET(PSONODAD)
SET DIC("DR")=DIC("DR")_";4////"_PSOTG3
Begin DoDot:3
+38 KILL DD,DO
DO FILE^DICN
KILL DD,DO,DIE,X,DINUM
+39 IF Y'>0
SET ^XTMP("SDPSO145","PROB",PSOTG1)=""
QUIT
+40 SET PSOETOT=PSOETOT+1
+41 KILL ^XTMP("SDPSO145","PROB",PSOTG1)
+42 KILL ^XTMP("SDPSO145","PROB1",PSOTG1)
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;LOOP THROUGH SCHEDULING XTMP HERE
+44 DO SCH^PSOTPCRX
PASS ;
+1 SET ^XTMP("SDPSO145","ELIG")=+$GET(PSOETOT)
+2 SET ^XTMP("SDPSO145","INEL")=+$GET(PSOITOT)
+3 DO EN^PSO145PS
+4 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET ^XTMP("SDPSO145","STOP")=$GET(Y)
KILL Y
+5 ;***need HL7 routine name (moved to phase 2)
+6 ;I '$$PATCH^XPDUTL("PSO*7.0*145") S ZTRTN="NAME^EXTRACT",ZTIO="",ZTDESC="TPB EIGIBILITY FILE EXTRACT",ZTDTH=$H D ^%ZTLOAD K ZTRTN,ZTIO,ZTDESC,ZTDTH
+7 DO MAIL
+8 LOCK -^XTMP("SDPSO145")
+9 KILL DA,DIE,DR
SET DA=$ORDER(^DIC(19,"B","PSO TPB PATIENT ENTER/EDIT",0))
IF DA
SET DIE="^DIC(19,"
SET DR="2////"_"@"
DO ^DIE
KILL DIE,DA,DR
+10 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+11 QUIT
MAIL ;
+1 NEW PSOTUCI,PSOTUCI1,XMTEXT,XMSUB,XMDUZ,XMY,PSOMLIN,PSOMLINN,PSOTDEL,PSOMNAME,PSOMLLP,PSOMLCT,PSOSTEXT,PSOQTIME,X,Y,%
+2 SET PSOMLINN=""
SET PSOMLIN=$PIECE($GET(^XMB(1,1,"XUS")),"^",17)
IF PSOMLIN'>0
SET PSOMLIN=$GET(DUZ(2))
+3 IF PSOMLIN
SET PSOMLINN=$PIECE($GET(^DIC(4,PSOMLIN,0)),"^")
+4 SET XMSUB=$SELECT($GET(PSOMLINN)="":"Unknown Institution",1:$GET(PSOMLINN)_" ("_$GET(PSOMLIN)_")")_" TPB FILE BUILD"
+5 SET XMDUZ="Patch PSO*7*145 Post Install"
IF $GET(DUZ)
SET XMY(DUZ)=""
+6 XECUTE ^%ZOSF("UCI")
SET PSOTUCI=$PIECE($GET(Y),",")
SET PSOTUCI1=$PIECE($GET(^%ZOSF("PROD")),",")
IF PSOTUCI=PSOTUCI1
Begin DoDot:1
+7 SET XMY("TEMPLETON,SHANNON@DOMAIN.EXT")=""
+8 SET XMY("BROCKERT,JUDITH@DOMAIN.EXT")=""
+9 SET XMY("CHOW,ANGELA@DOMAIN.EXT")=""
+10 SET XMY("RUZBACKI,RON@DOMAIN.EXT")=""
+11 SET XMY("BARRON,LUANNE@DOMAIN.EXT")=""
+12 SET XMY("WASHINGTON,JANET P@DOMAIN.EXT")=""
End DoDot:1
+13 IF $GET(PSOTLOCK)
Begin DoDot:1
+14 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET PSOQTIME=Y
+15 KILL PSOSTEXT
SET PSOSTEXT(1)="The TPB ELIGIBILITY file building, and other post-install functions of"
SET PSOSTEXT(2)="patch PSO*7*145, queued to run at "_$GET(PSOQTIME)_","
SET PSOSTEXT(3)="was NOT run, because the XTMP patient global was locked."
+16 SET PSOSTEXT(4)="This Post-Install may have been queued by another user. Please contact"
SET PSOSTEXT(5)="Customer Support."
End DoDot:1
GOTO MAILX
+17 SET PSOSTEXT(1)="The Post-Init from Patch PSO*7.0*145 is complete. The TPB ELIGIBILITY"
SET PSOSTEXT(2)="File (#52.91) has been populated."
SET PSOSTEXT(3)=" "
+18 SET PSOSTEXT(4)="The job started at "_$GET(^XTMP("SDPSO145","START"))
SET PSOSTEXT(5)="The job ended at "_$GET(^XTMP("SDPSO145","STOP"))
SET PSOSTEXT(6)=" "
+19 SET PSOSTEXT(7)="Total number of eligible patients added to file = "_$GET(^XTMP("SDPSO145","ELIG"))
SET PSOSTEXT(8)="Total number of ineligible patients added to file = "_$GET(^XTMP("SDPSO145","INEL"))
SET PSOSTEXT(9)=" "
+20 SET PSOMLCT=10
+21 SET PSOTDEL=""
FOR
SET PSOTDEL=$ORDER(^XTMP("SDPSO145","PROB",PSOTDEL))
if PSOTDEL=""
QUIT
IF $DATA(^PS(52.91,PSOTDEL,0))
KILL ^XTMP("SDPSO145","PROB",PSOTDEL)
+22 SET PSOTDEL=""
FOR
SET PSOTDEL=$ORDER(^XTMP("SDPDO145","PROB1",PSOTDEL))
if PSOTDEL=""
QUIT
IF $DATA(^PS(52.91,PSOTDEL,0))
KILL ^XTMP("SDPSO145","PROB1",PSOTDEL)
+23 IF $ORDER(^XTMP("SDPSO145","PROB",0))
Begin DoDot:1
+24 SET PSOSTEXT(PSOMLCT)="The following patients qualify for the Transitional Pharmacy"
SET PSOMLCT=PSOMLCT+1
SET PSOSTEXT(PSOMLCT)="Benefit, but were unable to be added to the file for unknown reasons:"
SET PSOMLCT=PSOMLCT+1
+25 SET PSOMLLP=""
FOR
SET PSOMLLP=$ORDER(^XTMP("SDPSO145","PROB",PSOMLLP))
if PSOMLLP=""
QUIT
Begin DoDot:2
+26 DO PNM
+27 SET PSOSTEXT(PSOMLCT)=$GET(PSOMNAME)_$GET(^XTMP("SDPSO145","PROB",PSOMLLP))
SET PSOMLCT=PSOMLCT+1
End DoDot:2
End DoDot:1
+28 IF PSOMLCT>10
SET PSOSTEXT(PSOMLCT)=" "
SET PSOMLCT=PSOMLCT+1
+29 IF $ORDER(^XTMP("SDPSO145","PROB1",0))
Begin DoDot:1
+30 SET PSOSTEXT(PSOMLCT)="The following patients qualify for the Transitional Pharmacy"
SET PSOMLCT=PSOMLCT+1
SET PSOSTEXT(PSOMLCT)="Benefit, but were unable to be added to the file because a Station Number"
SET PSOMLCT=PSOMLCT+1
+31 SET PSOSTEXT(PSOMLCT)="could not be found for the Institution associated with the patient:"
SET PSOMLCT=PSOMLCT+1
+32 SET PSOMLLP=""
FOR
SET PSOMLLP=$ORDER(^XTMP("SDPSO145","PROB1",PSOMLLP))
if PSOMLLP=""
QUIT
Begin DoDot:2
+33 DO PNM
+34 SET PSOSTEXT(PSOMLCT)=$GET(PSOMNAME)_$GET(^XTMP("SDPSO145","PROB1",PSOMLLP))
SET PSOMLCT=PSOMLCT+1
End DoDot:2
End DoDot:1
MAILX ;
+1 IF $ORDER(XMY(""))'=""
SET XMTEXT="PSOSTEXT("
NEW DIFROM
DO ^XMD
+2 KILL PSOSTEXT,XMTEXT,XMSUB,XMDUZ,XMY
+3 QUIT
GETDATE ;
+1 NEW PSONOW,PSOTODAY,X,Y,PSOSAVEY,PSOSAVEX,PSOXXX
+2 SET ZTDTH=""
SET PSONOW=0
+3 DO NOW^%DTC
SET (Y,PSOTODAY)=%
DO DD^%DT
+4 DO BMES^XPDUTL("At the following prompt, enter a starting date@time")
+5 DO MES^XPDUTL("or enter NOW to queue the job immediately.")
+6 DO BMES^XPDUTL("If this prompting is during patch installation, you may not see what you type.")
+7 WRITE !
KILL %DT
DO NOW^%DTC
SET %DT="RAEX"
SET %DT(0)=%
SET %DT("A")="Queue TPB Eligibility File building job for what Date@Time: "
+8 DO ^%DT
KILL %DT
IF $DATA(DTOUT)!(Y<0)
WRITE "Task will be queued to run NOW"
SET ZTDTH=$HOROLOG
SET PSONOW=1
+9 SET PSOSAVEY=Y
+10 IF 'PSONOW
IF PSOSAVEY>0
Begin DoDot:1
+11 SET Y=PSOSAVEY
DO DD^%DT
+12 SET PSOSAVEX=Y
End DoDot:1
+13 IF 'PSONOW
IF $GET(PSOSAVEY)<0
KILL PSOXXX,PSOSAVEX,PSOSAVEY,X,Y,PSONOW,PSOTODAY
GOTO GETDATE
ASK ;
+1 DO BMES^XPDUTL("Task will be queued to run "_$SELECT(PSONOW:"NOW",1:PSOSAVEX)_". Is that correct? ")
+2 READ PSOXXX:300
if '$TEST!($GET(PSOXXX)="")
SET PSOXXX="Y"
SET PSOXXX=$$UP^XLFSTR(PSOXXX)
IF PSOXXX'="Y"
IF PSOXXX'="YES"
IF PSOXXX'="N"
IF PSOXXX'="NO"
WRITE "Enter Y or N"
GOTO ASK
+3 IF PSOXXX'="Y"
IF PSOXXX'="YES"
KILL PSOXXX,PSOSAVEX,PSOSAVEY,X,Y,PSONOW,PSOTODAY
GOTO GETDATE
+4 IF PSOSAVEY>0
IF ZTDTH=""
SET ZTDTH=PSOSAVEY
+5 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+6 QUIT
PNM ;
+1 NEW DFN,VADM,VA,VAERR
+2 KILL PSOMNANE,VADM
+3 SET DFN=+$GET(PSOMLLP)
IF 'DFN
QUIT
+4 DO DEM^VADPT
IF $GET(VADM(1))=""
KILL VADM
QUIT
+5 SET PSOMNAME=$GET(VADM(1))
+6 KILL VADM
+7 KILL VA,VAERR
SET DFN=+$GET(PSOMLLP)
DO PID^VADPT6
+8 SET PSOMNAME=PSOMNAME_" "_"("_$GET(VA("BID"))_")"
+9 KILL VA,VAERR
+10 QUIT
