- 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 Apr 23, 2025@18:50:24 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
