IBY659PO ;AITC/VD - Post-Installation for IB patch 659; 22-MAY-2018
;;2.0;INTEGRATED BILLING;**659**;21-MAR-94;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
DOC ;
; REGMSG send site registration message to FSC for version change from 10 to 11.
; Don't send if site is MANILA (#358)
; SITEFIL set the initial values for:
; MEDICARE FRESHNESS DAYS in [#350.9,51.32] to "365".
; MANILA EIV ENABLED in [#350.9,51.33] to "N" for all VAMC sites.
; TSKCLN clean-up the corrupted records in the Insurance Verification Processor file (#355.33).
; ICR # 10063 for ^%ZTLOAD
; ICR # 10103 for ^XLFDT
;
EN ; Entry Point for Post-Install routine
N IBXPD,SITESYS,XPDIDTOT
S XPDIDTOT=4
;
S SITESYS=$P($$SITE^VASITE,U,3) ; Get the current site number (piece 3 is the ACTUAL site #).
D MES^XPDUTL("")
D SITEFIL(1) ; Set initial value for the new field [#350.9,51.32]
D SITEFIL(2) ; Set initial value for the new field [#350.9,51.33]
D TSKCLN(3) ; Clean-up the corrupted records in the Insurance Verification Processor File (#355.33).
D REGMSG(4) ; Send site registration message to FSC
;
; Displays the 'Done' message and finishes the progress bar
D MES^XPDUTL("")
D MES^XPDUTL("POST-Install Completed.")
Q
;
REGMSG(IBXPD) ; send site registration message to FSC
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Sending site registration message to FSC ... ")
;
I SITESYS=358 D MES^XPDUTL("Current Site is MANILA - NO Site Registration Message sent") G REGMSGQ ; Don't send if Manila (#358)
I '$$PROD^XUPROD(1) D MES^XPDUTL(" N/A - Not a production account - No site registration message sent") G REGMSGQ
D ^IBCNEHLM
;
REGMSGQ ;
Q
;
SITEFIL(IBXPD) ; Set initial value of [#350.9,51.32] and [#350.9,51.33]
N DA,DIE,DR
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
;
I IBXPD=1 D Q
.D MES^XPDUTL("Initialize value of MEDICARE FRESHNESS DAYS to 365 in IB SITE PARAMETERS file...")
.S DIE=350.9,DA=1,DR="51.32///365" D ^DIE
.K DA,DIE,DR
;
I IBXPD=2 D Q
.D MES^XPDUTL("Setting MANILA EIV ENABLED field to 'N' for No in IB SITE PARAMETERS file...")
.S DA=1,DIE=350.9,DR="51.33///"_"N" D ^DIE
.K DA,DIE,DR
;
Q
;
TSKCLN(IBXPD) ; Clean-up corrupted records in the Insurance Verification Processor file #355.33
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Tasking the Clean-up of corrupted records in the Insurance Verification")
D MES^XPDUTL(" Processor file #355.33 ...")
N MSG,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTRTN
S ZTDESC="CLEAN-UP OF CORRUPTED RECORDS IN #355.33"
S ZTDTH=$P($$NOW^XLFDT(),"."),ZTDTH=$$FMADD^XLFDT(ZTDTH,,20) ; ZTDTH = TODAY AT 8:00 PM ;ICR# 10103 for XLFDT
S ZTIO=""
S ZTQUEUED=1
S ZTRTN="BADRECS^IBY659PO"
;
S MSG=$$TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO) ;To be run at 8:00 PM
D MES^XPDUTL(MSG)
TSKCLNQ Q
;
TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO) ;bypass for queued task
N %DT,GTASKS,IDT,MSG,TSK,XDT,Y,ZTSK
S (IDT,Y)=ZTDTH D DD^%DT S XDT=Y ; XDT is TODAY@2000 reformatted to a readable date.
;
;Check if task already scheduled for date/time
K GTASKS
D DESC^%ZTLOAD(ZTDESC,"GTASKS")
S TSK=""
S TSK=$O(GTASKS(TSK))
I TSK'="" D Q MSG
. S ZTSK=TSK D ISQED^%ZTLOAD
. S MSG="Task (#"_+ZTSK_") already scheduled to run on "_$$HTE^XLFDT(ZTSK("D"),1)
;
;Schedule the task
S TSK=$$SCHED(IDT,ZTIO)
;
;Check for scheduling problem
I '$G(TSK) S MSG=" Task Could Not Be Scheduled" Q MSG
;
;Send successful schedule message
S MSG=" Clean-up of corrupted records in file #355.33 scheduled for "_XDT
Q MSG
;
SCHED(ZTDTH,ZTIO) ;
N ZTSK
D ^%ZTLOAD
Q ZTSK
;
BADRECS(IBXPD) ; Clean-up corrupted records in File #355.33.
N CNT0,CNTAR,DA,DIC,DIE,DR,IBBUFDA,IBXMY,MSG,SITESYS,SITENAME
S (CNT0,CNTAR,IBBUFDA)=0
; recalculate SITESYS here as this tag is called from TaskMan
S SITESYS=$$SITE^VASITE ; Get the site name & #
S SITENAME=$P(SITESYS,U,2),SITESYS=$P(SITESYS,U,3) ; piece 3 is the site #
;
;Search for corrupted records.
F S IBBUFDA=$O(^IBA(355.33,IBBUFDA)) Q:('+IBBUFDA) D
. I '$D(^IBA(355.33,IBBUFDA,0)) D DELDATA S CNT0=CNT0+1 Q ;Delete the current buffer because there is no ZERO node.
. I (("^A^R^")[("^"_$$GET1^DIQ(355.33,IBBUFDA_",",.04,"I")_"^")),($O(^IBA(355.33,IBBUFDA,0))'="") D DELDATA S CNTAR=CNTAR+1 Q ;Check only Accepted or Rejected buffers to see if there is data to delete.
;
;Send mailman message at completion.
S MSG(1)="Patch IB*2.0*659 Post Install - Clean-up of corrupted #355.33 records has completed."
S MSG(2)="------------------------------------------------------------------------"
S MSG(3)=" Total number of corrupted buffer entries removed (no ZERO node): "_+CNT0
S MSG(4)=" Total number of Accepted/Rejected GHOST buffer entries removed: "_+CNTAR
;
I $$PROD^XUPROD(1) S IBXMY("VHAeInsuranceRapidResponse@domain.ext")="" ; Only send to eInsurance Rapid Response if in Production
D MSG^IBCNEUT5(,"IB*2.0*659 Post Install ("_SITESYS_"-"_SITENAME_")","MSG(",,.IBXMY)
;
; Tell TaskManager to delete the task's record
I $D(ZTQUEUED) S ZTREQ="@"
BADRECQ Q ; Exit from Cleaning up Buffers.
;
DELDATA ; Delete data from corrupted records.
N DA,DIC,DIE,DR,IBCNT,IBFLD,IBFLDS,IBI,IBIFN,IBX,X,Y
S X=$O(^IBA(355.33,IBBUFDA,0)) Q:X="" ; No data found after ZERO node - get next.
;
; The current buffer is either ACCEPTED or REJECTED & has data to be deleted.
S IBIFN=IBBUFDA_",",DR="",IBCNT=1
D GETS^DIQ(355.33,IBIFN,"1:999","IN","IBFLDS") ; This returns a non-blank fields.
;
S IBFLD=0
F S IBFLD=$O(IBFLDS(355.33,IBIFN,IBFLD)) Q:'IBFLD D ; Set up the DR string.
. I $L(DR)>200 S DR(1,355.33,IBCNT)=DR,DR="",IBCNT=IBCNT+1
. S DR=DR_IBFLD_"///@;"
;
I DR'="" D ; Delete data then nodes.
. S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DA,DIC,DIE,DR
;
; Kill blank nodes since DIE doesn't
S IBI=0
F S IBI=$O(^IBA(355.33,IBBUFDA,IBI)) Q:'IBI D
. S IBX=$G(^IBA(355.33,IBBUFDA,IBI))
. I IBX?."^" K ^IBA(355.33,IBBUFDA,IBI)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY659PO 6202 printed Apr 09, 2024@21:32:23 Page 2
IBY659PO ;AITC/VD - Post-Installation for IB patch 659; 22-MAY-2018
+1 ;;2.0;INTEGRATED BILLING;**659**;21-MAR-94;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
DOC ;
+1 ; REGMSG send site registration message to FSC for version change from 10 to 11.
+2 ; Don't send if site is MANILA (#358)
+3 ; SITEFIL set the initial values for:
+4 ; MEDICARE FRESHNESS DAYS in [#350.9,51.32] to "365".
+5 ; MANILA EIV ENABLED in [#350.9,51.33] to "N" for all VAMC sites.
+6 ; TSKCLN clean-up the corrupted records in the Insurance Verification Processor file (#355.33).
+7 ; ICR # 10063 for ^%ZTLOAD
+8 ; ICR # 10103 for ^XLFDT
+9 ;
EN ; Entry Point for Post-Install routine
+1 NEW IBXPD,SITESYS,XPDIDTOT
+2 SET XPDIDTOT=4
+3 ;
+4 ; Get the current site number (piece 3 is the ACTUAL site #).
SET SITESYS=$PIECE($$SITE^VASITE,U,3)
+5 DO MES^XPDUTL("")
+6 ; Set initial value for the new field [#350.9,51.32]
DO SITEFIL(1)
+7 ; Set initial value for the new field [#350.9,51.33]
DO SITEFIL(2)
+8 ; Clean-up the corrupted records in the Insurance Verification Processor File (#355.33).
DO TSKCLN(3)
+9 ; Send site registration message to FSC
DO REGMSG(4)
+10 ;
+11 ; Displays the 'Done' message and finishes the progress bar
+12 DO MES^XPDUTL("")
+13 DO MES^XPDUTL("POST-Install Completed.")
+14 QUIT
+15 ;
REGMSG(IBXPD) ; send site registration message to FSC
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Sending site registration message to FSC ... ")
+4 ;
+5 ; Don't send if Manila (#358)
IF SITESYS=358
DO MES^XPDUTL("Current Site is MANILA - NO Site Registration Message sent")
GOTO REGMSGQ
+6 IF '$$PROD^XUPROD(1)
DO MES^XPDUTL(" N/A - Not a production account - No site registration message sent")
GOTO REGMSGQ
+7 DO ^IBCNEHLM
+8 ;
REGMSGQ ;
+1 QUIT
+2 ;
SITEFIL(IBXPD) ; Set initial value of [#350.9,51.32] and [#350.9,51.33]
+1 NEW DA,DIE,DR
+2 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+3 DO MES^XPDUTL("-------------")
+4 ;
+5 IF IBXPD=1
Begin DoDot:1
+6 DO MES^XPDUTL("Initialize value of MEDICARE FRESHNESS DAYS to 365 in IB SITE PARAMETERS file...")
+7 SET DIE=350.9
SET DA=1
SET DR="51.32///365"
DO ^DIE
+8 KILL DA,DIE,DR
End DoDot:1
QUIT
+9 ;
+10 IF IBXPD=2
Begin DoDot:1
+11 DO MES^XPDUTL("Setting MANILA EIV ENABLED field to 'N' for No in IB SITE PARAMETERS file...")
+12 SET DA=1
SET DIE=350.9
SET DR="51.33///"_"N"
DO ^DIE
+13 KILL DA,DIE,DR
End DoDot:1
QUIT
+14 ;
+15 QUIT
+16 ;
TSKCLN(IBXPD) ; Clean-up corrupted records in the Insurance Verification Processor file #355.33
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Tasking the Clean-up of corrupted records in the Insurance Verification")
+4 DO MES^XPDUTL(" Processor file #355.33 ...")
+5 NEW MSG,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTRTN
+6 SET ZTDESC="CLEAN-UP OF CORRUPTED RECORDS IN #355.33"
+7 ; ZTDTH = TODAY AT 8:00 PM ;ICR# 10103 for XLFDT
SET ZTDTH=$PIECE($$NOW^XLFDT(),".")
SET ZTDTH=$$FMADD^XLFDT(ZTDTH,,20)
+8 SET ZTIO=""
+9 SET ZTQUEUED=1
+10 SET ZTRTN="BADRECS^IBY659PO"
+11 ;
+12 ;To be run at 8:00 PM
SET MSG=$$TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO)
+13 DO MES^XPDUTL(MSG)
TSKCLNQ QUIT
+1 ;
TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO) ;bypass for queued task
+1 NEW %DT,GTASKS,IDT,MSG,TSK,XDT,Y,ZTSK
+2 ; XDT is TODAY@2000 reformatted to a readable date.
SET (IDT,Y)=ZTDTH
DO DD^%DT
SET XDT=Y
+3 ;
+4 ;Check if task already scheduled for date/time
+5 KILL GTASKS
+6 DO DESC^%ZTLOAD(ZTDESC,"GTASKS")
+7 SET TSK=""
+8 SET TSK=$ORDER(GTASKS(TSK))
+9 IF TSK'=""
Begin DoDot:1
+10 SET ZTSK=TSK
DO ISQED^%ZTLOAD
+11 SET MSG="Task (#"_+ZTSK_") already scheduled to run on "_$$HTE^XLFDT(ZTSK("D"),1)
End DoDot:1
QUIT MSG
+12 ;
+13 ;Schedule the task
+14 SET TSK=$$SCHED(IDT,ZTIO)
+15 ;
+16 ;Check for scheduling problem
+17 IF '$GET(TSK)
SET MSG=" Task Could Not Be Scheduled"
QUIT MSG
+18 ;
+19 ;Send successful schedule message
+20 SET MSG=" Clean-up of corrupted records in file #355.33 scheduled for "_XDT
+21 QUIT MSG
+22 ;
SCHED(ZTDTH,ZTIO) ;
+1 NEW ZTSK
+2 DO ^%ZTLOAD
+3 QUIT ZTSK
+4 ;
BADRECS(IBXPD) ; Clean-up corrupted records in File #355.33.
+1 NEW CNT0,CNTAR,DA,DIC,DIE,DR,IBBUFDA,IBXMY,MSG,SITESYS,SITENAME
+2 SET (CNT0,CNTAR,IBBUFDA)=0
+3 ; recalculate SITESYS here as this tag is called from TaskMan
+4 ; Get the site name & #
SET SITESYS=$$SITE^VASITE
+5 ; piece 3 is the site #
SET SITENAME=$PIECE(SITESYS,U,2)
SET SITESYS=$PIECE(SITESYS,U,3)
+6 ;
+7 ;Search for corrupted records.
+8 FOR
SET IBBUFDA=$ORDER(^IBA(355.33,IBBUFDA))
if ('+IBBUFDA)
QUIT
Begin DoDot:1
+9 ;Delete the current buffer because there is no ZERO node.
IF '$DATA(^IBA(355.33,IBBUFDA,0))
DO DELDATA
SET CNT0=CNT0+1
QUIT
+10 ;Check only Accepted or Rejected buffers to see if there is data to delete.
IF (("^A^R^")[("^"_$$GET1^DIQ(355.33,IBBUFDA_",",.04,"I")_"^"))
IF ($ORDER(^IBA(355.33,IBBUFDA,0))'="")
DO DELDATA
SET CNTAR=CNTAR+1
QUIT
End DoDot:1
+11 ;
+12 ;Send mailman message at completion.
+13 SET MSG(1)="Patch IB*2.0*659 Post Install - Clean-up of corrupted #355.33 records has completed."
+14 SET MSG(2)="------------------------------------------------------------------------"
+15 SET MSG(3)=" Total number of corrupted buffer entries removed (no ZERO node): "_+CNT0
+16 SET MSG(4)=" Total number of Accepted/Rejected GHOST buffer entries removed: "_+CNTAR
+17 ;
+18 ; Only send to eInsurance Rapid Response if in Production
IF $$PROD^XUPROD(1)
SET IBXMY("VHAeInsuranceRapidResponse@domain.ext")=""
+19 DO MSG^IBCNEUT5(,"IB*2.0*659 Post Install ("_SITESYS_"-"_SITENAME_")","MSG(",,.IBXMY)
+20 ;
+21 ; Tell TaskManager to delete the task's record
+22 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
BADRECQ ; Exit from Cleaning up Buffers.
QUIT
+1 ;
DELDATA ; Delete data from corrupted records.
+1 NEW DA,DIC,DIE,DR,IBCNT,IBFLD,IBFLDS,IBI,IBIFN,IBX,X,Y
+2 ; No data found after ZERO node - get next.
SET X=$ORDER(^IBA(355.33,IBBUFDA,0))
if X=""
QUIT
+3 ;
+4 ; The current buffer is either ACCEPTED or REJECTED & has data to be deleted.
+5 SET IBIFN=IBBUFDA_","
SET DR=""
SET IBCNT=1
+6 ; This returns a non-blank fields.
DO GETS^DIQ(355.33,IBIFN,"1:999","IN","IBFLDS")
+7 ;
+8 SET IBFLD=0
+9 ; Set up the DR string.
FOR
SET IBFLD=$ORDER(IBFLDS(355.33,IBIFN,IBFLD))
if 'IBFLD
QUIT
Begin DoDot:1
+10 IF $LENGTH(DR)>200
SET DR(1,355.33,IBCNT)=DR
SET DR=""
SET IBCNT=IBCNT+1
+11 SET DR=DR_IBFLD_"///@;"
End DoDot:1
+12 ;
+13 ; Delete data then nodes.
IF DR'=""
Begin DoDot:1
+14 SET DIE="^IBA(355.33,"
SET DA=IBBUFDA
DO ^DIE
KILL DA,DIC,DIE,DR
End DoDot:1
+15 ;
+16 ; Kill blank nodes since DIE doesn't
+17 SET IBI=0
+18 FOR
SET IBI=$ORDER(^IBA(355.33,IBBUFDA,IBI))
if 'IBI
QUIT
Begin DoDot:1
+19 SET IBX=$GET(^IBA(355.33,IBBUFDA,IBI))
+20 IF IBX?."^"
KILL ^IBA(355.33,IBBUFDA,IBI)
End DoDot:1
+21 QUIT
+22 ;
