IBJPI2 ;DAOU/BHS - eIV SITE PARAMETERS SCREEN ACTIONS ;26-JUN-2002
;;2.0;INTEGRATED BILLING;**184,271,316,416,438,713,737,763**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
;
; eIV - electronic Insurance Verification Interface
;
; Only call from tag
Q
;
IIVEDIT ; -- IBJP IIV EDIT ACTIONS (GP,PW): Edit eIV Site Parameters
N DA,DR,DIE,DIC,X,Y
;
;IB*737/TAZ - Removed parameter and clean up the code
;
D FULL^VALM1
W @IOF,!,"General Parameters",!
S DR="[IBCNE GENERAL PARAMETER EDIT]"
S DIE="^IBE(350.9,",DA=1 D ^DIE K DA,DR,DIE,DIC,X,Y
;
D INIT^IBJPI S VALMBCK="R"
Q
;
LTENT ; entry from list template protocol 'IBJP IIV FIX CORRUPT BUFFERS' from 'IBJP INS VER MENU' menu
N IBA,IBERR,IBFL,IBFR,IBMSG,IBOK,IBXTMPNM,IBGHDESC,ZTDESC,IBOKM ;IB*763/CKB - added IBFL,IBFR
;
S IBXTMPNM="IBJPI2_FIX_BUFFER_RECS",IBGHDESC="IB file 355.33 Corrupt Buffer Clean up"
S ZTDESC="IB eInsurance FIX CORRUPTED BUFFERS IN #355.33"
S (IBOK,IBOKM)=1
I $G(DT)="" S DT=$$DT^XLFDT
FXLST ;IB*763/CKB - Prompt user to run 'Fix or List Corrupt Buffers'
D FULL^VALM1
K DIR,DIRUT,DUOUT,X,Y
S DIR(0)="SA^F:Fix;L:List"
S DIR("A")="Fix or List Corrupt Buffers? "
S DIR("?")="^D FLHELP^IBJPI2"
S DIR("??")="^D FLHELP^IBJPI2"
S DIR("B")="List"
D ^DIR K DIR
S IBFR=$$UP^XLFSTR($E(Y,1))
I IBFR="^"!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) D PAUSE^VALM1 G LTOUT
I (IBFR'="F")&(IBFR'="L") W !," Select 'F'ix or 'L'ist",! G FXLST
;
;IB*763/CKB - if user selects LIST, change ZTDESC, IBXTMPNM and IBGHDESC
; set IBFR=("F" or "L") / IBFL=("Fix Corrupt Buffer" or "List of Corrupt Buffers")
I IBFR="L" D
. S ZTDESC="IB eInsurance LIST OF CORRUPTED BUFFERS IN #355.33"
. S IBXTMPNM="IBJPI2_LIST_BUFFER_RECS",IBGHDESC="IB file 355.33 List of Corrupt Buffers"
S IBFL=$S(IBFR="F":"Fix Corrupt Buffer",1:"List of Corrupt Buffers")
;
D LTCHKRN I 'IBOK D D PAUSE^VALM1 G LTOUT
.;IB*763/CKB - Allow to Fix or List, using variables IBFR and IBFL
. I IBOKM D
.. I IBFR="F" W !,"Not submitting Fix Corrupt Buffers to run"
.. I IBFR="L" W !,"Not creating List of Corrupt Buffers."
D FULL^VALM1 W !!
S IBMSG(0)=0
S IBERR=$$TASKIN($S(IBFR="L":IBFL,1:"Corrupt Buffers Fixed"),$G(DUZ),"IBMSG")
I +IBERR!('$G(IBMSG(0))) D D PAUSE^VALM1 G LTOUT
. W !!,"Error in submitting '"_IBFL_"'."
. W !,"Please Contact eInsurance Team"
I $G(IBMSG(0)) W !! S IBA=0 F S IBA=$O(IBMSG(IBA)) D:'IBA PAUSE^VALM1 Q:'IBA W IBMSG(IBA),!
;
LTOUT ; list template protocol quit
D INIT^IBJPI S VALMBCK="R"
Q
;
LTCHKRN ; has the CBF been run in the last 15 days
N DIR,DIRUT,DUOUT,IBA,IBA1,IBB,IBB1,IBC,IBCHK,IBLCNT,IBLCTOP,IBLDT,IBMSF,IBMSG
N IBRDT,IBSTR,IBT,MSG,MSGD,X,Y
;
S IBCHK="",IBSTR="",$P(IBSTR,"*",80)=""
S IBLCNT=$G(^XTMP(IBXTMPNM,"C")) I IBLCNT S IBCHK=$G(^XTMP(IBXTMPNM,0))
S IBLDT=$P($P(IBCHK,U,2),".",1),IBRDT=$$FMTE^XLFDT(IBLDT)
S IBMSF="Last run was "_($S(IBLDT:"on "_IBRDT,1:"over 2 weeks ago"))
S MSGD="",MSG=$$CHKTSK
D FULL^VALM1 W !!
W IBMSF,!
;IB*763/CKB - Set MSGD using IBFL for Fix or List wording
; IBFL = "Fix Corrupt Buffer" or "List of Corrupt Buffers"
I +MSG D
. S MSGD="*** '"_IBFL_"' "
. S MSGD=MSGD_$P($P(MSG,U,2),"y",1)_"y ***^*** "_$P($P(MSG,U,2),"y",2,999)
I IBLDT D I 'IBOK Q
. K DIR,DIRUT,DUOUT
. S DIR("?")="Enter 'Y' to view the details of the last run, Enter 'N' to skip or '^' to quit."
. S DIR("A")="Do you want the details",DIR(0)="Y",DIR("B")="No" D ^DIR
. I 'Y S:$E(Y)=U!($D(DIRUT))!($D(DUOUT)) IBOK=0 Q
. S IBLCTOP=^XTMP(IBXTMPNM,IBLCNT,0),IBT=$G(^XTMP(IBXTMPNM,IBLCNT,"T"))
. M IBMSG=^XTMP(IBXTMPNM,IBLCNT,"M")
. W !!,"Run For: ",$P(IBLCTOP,U,2),!
. W "Started: " S IBC=$P(IBT,U,1) S:IBC'="" IBC=$$FMTE^XLFDT(IBC),IBC=$P(IBC,":",1,2) W IBC
. W ?35,"Completed: " S IBC=$P(IBT,U,2) S:IBC'="" IBC=$$FMTE^XLFDT(IBC),IBC=$P(IBC,":",1,2) W IBC,!
. S IBA=0 F S IBA=$O(IBMSG(IBA)) Q:IBA="" S IBB=IBMSG(IBA) I IBB'=""&(IBB'=" ") W !,IBB
. W !
; don't ask submit question if already scheduled just quit out
I MSGD'="" D S (IBOK,IBOKM)=0 Q
. S IBA1=$P(MSGD,U,1),IBB1=$P(MSGD,U,2,99)
. W !!,$E(IBSTR,1,$L(IBA1)),!,IBA1,!,IBB1,($E(" ",1,($L(IBA1)-3-$L(IBB1)))),"***",!
. W $E(IBSTR,1,$L(IBA1))
;
;IB*763/CKB - Include X,Y in kill and use IBFL for Fix or List Help Text wording
K DIR,DIRUT,DUOUT,X,Y
S DIR("A")="Do you want to run "_IBFL
S DIR("?")="Enter 'Y' to run "_$S(IBFR="L":"the "_IBFL,1:"Corrupt Buffers Fix")
S DIR("?")=DIR("?")_", Enter 'N' or '^' to quit."
S DIR(0)="Y",DIR("B")="No"
D ^DIR K DIR
I $E(Y)=U!('Y)!($D(DIRUT))!($D(DUOUT)) S IBOK=0
Q
;
TASKIN(IBSB,IBUS,IBRET,IBFLIN) ; Clean-up corrupted records in the Insurance Verification Processor file #355.33
;INPUT:
; IBSB - message subject
; IBUS - user DUZ to use
; IBRET - message return array to calling entity passed in as "VARIBLE"
; IBFLIN - first line of e-mail message (if one) [opt]
;
N IBA,IBB,IBNAME,IBUDUZ,MSG,RMSG,WMSG,ZTDTH,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE
;
S IBUDUZ=$G(DUZ)
S IBUS=$G(IBUS) S:IBUS="" IBUS=$G(DUZ) I IBUS="" S IBUS=.5
S IBSB=$G(IBSB)
S IBRET=$G(IBRET) I IBRET="" Q "1^Need return array"
S IBFLIN=$G(IBFLIN)
K @IBRET
;
;IB*763/CKB - ZTDESC is already set, don't want to reset. Overwrites if user is running List
;S ZTDESC="IB eInsurance FIX CORRUPTED BUFFERS IN #355.33"
;
; ZTDTH = TODAY AT 8:00 PM
S ZTDTH=$P($$NOW^XLFDT(),"."),ZTDTH=$$FMADD^XLFDT(ZTDTH,,20)
S ZTIO=""
S ZTQUEUED=1
S ZTRTN="BADRECS^IBJPI2"
I $E(IBSB,1)="L" S ZTRTN="LIST^IBJPI2" ;IB*763/CKB
S ZTSAVE("IBUS")="",ZTSAVE("IBSB")="",ZTSAVE("IBFLIN")=""
S ZTSAVE("IBXTMPNM")="",ZTSAVE("IBGHDESC")=""
;
S @IBRET@(0)=1
S RMSG(0)="",MSG=$$TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO,.RMSG)
S @IBRET@(1)=MSG
I RMSG(0) D ;< multi line message to avoid wrap
. S IBA=0 F S IBA=$O(RMSG(IBA)) Q:'IBA S IBB=$G(RMSG(IBA)) I IBB'="" S @IBRET@(IBA+1)=IBB,@IBRET@(0)=@IBRET@(0)+1
;
TSKCLNQ ;
Q ""
;
CHKTSK() ;Check if task already scheduled for date/time
N GTASKS,MSGA,TSK,ZTSK
;
K GTASKS
D DESC^%ZTLOAD(ZTDESC,"GTASKS")
S TSK="",MSGA=0
S TSK=$O(GTASKS(TSK))
I TSK'="" D Q MSGA
. S ZTSK=TSK D ISQED^%ZTLOAD
. S MSGA="1^Task #"_+ZTSK_" is already scheduled to run on "_$$HTE^XLFDT(ZTSK("D"),1)_" "
Q MSGA
;
TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO,RMSG) ;bypass for queued task
N %DT,GTASKS,IBAA,IDT,MSG,MSG1,NOW,TIME,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
S RMSG(0)=0
S MSG=$$CHKTSK
I +MSG S MSG=$P(MSG,U,2,999) Q MSG
;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 NOW=$$NOW^XLFDT,TIME=""
I '$P(TSK,U,3) S TIME=NOW
I $P(TSK,U,3) S TIME=$P(TSK,U,2)
S TIME=$$FMTE^XLFDT(TIME)
;IB*763/CKB - allow for Fix or List message
S MSG="Task: "_$P($G(TSK),U)_" Clean-up of corrupted records in file #355.33"
I IBFR="L" S MSG="Task: "_$P($G(TSK),U)_" List of Corrupt Buffers in file #355.33 "
S RMSG(1)=" scheduled for "_TIME
S RMSG(0)=1
Q MSG
;
SCHED(ZTDTH,ZTIO) ;
N ZTSK,IBDT
D ^%ZTLOAD
I $G(ZTSK)="" Q ""
S IBDT=$$HTFM^XLFDT(ZTSK("D"))
; 72000 represents 8pm in $harlog seconds
Q ZTSK_U_IBDT_U_$S($P(ZTSK("D"),",",2)=72000:1,1:0)
;
BADRECS ; Clean-up corrupted records in File #355.33.
N CNT,DA,DIC,DIE,DR,I,IBART,IBUNAME,IBBUFDA,IBNODE0,IBOK,IBP01,IBPATNM
N IBRETA,IBSTAT,IBSTART,IBSTOP,IBTYP,IBWRKARY,IBXMY,MSG,SITESYS,SITENAME
N TOTAL,X,Y
;
K IBART S IBART=""
; 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 #
S IBSTART=$$NOW^XLFDT()
F I="AR","B","E" S CNT(I)=0
;
;Search for corrupted entries
S IBBUFDA=0
F S IBBUFDA=$O(^IBA(355.33,IBBUFDA)) Q:('+IBBUFDA) D
. ; get node 0
. S IBNODE0=$G(^IBA(355.33,IBBUFDA,0))
. ; get (#.01) date entered, (#.04) status, (#60.01) patient name
. K IBRETA D GETS^DIQ(355.33,IBBUFDA_",",".01;.04;60.01","I","IBRETA")
. K IBWRKARY M IBWRKARY=IBRETA(355.33,IBBUFDA_",")
. S IBSTAT=$G(IBWRKARY(.04,"I")),IBP01=$G(IBWRKARY(.01,"I")),IBPATNM=$G(IBWRKARY(60.01,"I"))
. ;
. ; If missing .01 then delete (DATE ENTERED is not populated)
. I IBP01="" D DELREC(".01",IBPATNM) S IBTYP="B",CNT(IBTYP)=$G(CNT(IBTYP))+1 Q
. ;
. ; Corrupted buffer entry (STATUS is not E,A,R)
. I IBSTAT="" D DELREC(".04",IBPATNM) S IBTYP="B",CNT(IBTYP)=$G(CNT(IBTYP))+1 Q
. ;
. I IBSTAT="E" D Q
. . ; Patient Name is missing for Entered Status
. . I IBPATNM="" D DELREC("60.01",IBPATNM) S IBTYP="B",CNT(IBTYP)=$G(CNT(IBTYP))+1
. ;
. ; Accepted/Rejected buffer entries, clean up all but the Zero node
. I (("^A^R^")[("^"_IBSTAT_"^")) D
. . ; Corrupted buffer entry (PATIENT NAME is populated - EVIL GHOST)
. . I IBPATNM'="" D DELDATA S IBTYP="E",CNT(IBTYP)=$G(CNT(IBTYP))+1 Q
. . ;
. . ; Corrupted buffer entry (PATIENT NAME is not populated & has a node other than Zero)
. . I IBPATNM="",$O(^IBA(355.33,IBBUFDA,0)) D
. . . D XREFC(0) D DELDATA S IBTYP="AR",CNT(IBTYP)=$G(CNT(IBTYP))+1
;
;Send mailman message at completion.
S IBUNAME=$$NAME^XUSER($G(IBUS))
I $G(IBFLIN)="" S IBFLIN=IBUNAME_", ran 'Fix Corrupt Buffer' on "_$$FMTE^XLFDT($P($$NOW^XLFDT,".",1),1)
;
S MSG(1)=IBFLIN
S MSG(2)=" - Clean-up of corrupted #355.33 records has completed."
S MSG(3)="------------------------------------------------------------------------"
S MSG(4)=" # of corrupt buffer entries corrected (stopped ins. verification): "_CNT("E")
S MSG(5)=" "
S MSG(6)=" # of corrupt Accepted/Rejected buffer entries corrected: "_CNT("AR")
S MSG(7)=" "
S MSG(8)=" # of corrupt buffer entries removed (bad zero node): "_CNT("B")
S TOTAL=CNT("E")+CNT("AR")
S MSG(9)=" "
S MSG(10)=" Total entries removed: "_CNT("B")
S MSG(11)=" "
S MSG(12)=" Total entries corrected: "_TOTAL
;
D IBXSAV
; Only send to eInsurance Rapid Response if in Production
; 1=Production Environment, 0=Test Environment
I $G(IBSB)="" S IBSB="Corrupt Buffers Fixed"
I $$PROD^XUPROD(1) D
. S IBXMY("VHAeInsuranceRapidResponse@domain.ext")=""
. D MSG^IBCNEUT5(,IBSB_" ("_SITESYS_"-"_SITENAME_")","MSG(",,.IBXMY)
;
; Tell TaskManager to delete the task's record
I $D(ZTQUEUED) S ZTREQ="@"
;
BADRECQ ; Exit from Cleaning up Buffers.
Q
;
IBXSAV ; save message into ^XTMP for 15 days
N IBNOK,IBCNT,IBHNG
;
S (IBNOK,IBCNT,IBHNG)=0,IBSTOP=$$NOW^XLFDT()
F L +^XTMP(IBXTMPNM):30 Q:$T H 10 S IBHNG=IBHNG+1 I IBHNG>10 S IBNOK=1 Q
I IBNOK Q ; not able to get the lock
S ^XTMP(IBXTMPNM,0)=$$FMADD^XLFDT(DT,15)_U_$$NOW^XLFDT()_U_IBGHDESC
S IBCNT=$G(^XTMP(IBXTMPNM,"C"))+1,^XTMP(IBXTMPNM,"C")=IBCNT
L -^XTMP(IBXTMPNM)
; place message info in ^XTMP
S ^XTMP(IBXTMPNM,IBCNT,0)=$G(IBUNAME)_U_SITESYS_"-"_SITENAME
M ^XTMP(IBXTMPNM,IBCNT,"M")=MSG
; place start-stop time
S ^XTMP(IBXTMPNM,IBCNT,"T")=IBSTART_U_IBSTOP
;
; place tmp array kill items in ^XTMP
; M ^XTMP(IBXTMPNM,IBCNT,"K")=IBART ;(* use for debugging by programmer only)
Q
;
DELDATA ; Delete data from corrupted records
D DELDATA^IBCNBED(IBBUFDA)
Q
;
DELREC(FIELD,IBPATNM) ;Delete entire record as it is unrecoverable
;; Kills all nodes, including the zero node, and all cross references
; FIELD - missing field so we have to kill a few cross-references first
; IBPATNM - Patient name (#355.33,60.01)
;
N DA,DIK,IBAR1,IBAR2,IBAR3,IBL1,IBL2,IBL3,IBLIEN,IBLP,IBSP,IBSN,IBOST
;
I FIELD="" Q
;
; ** Before killing the buffer record using IBBUFDA, search and kill specific
; cross-references that would be left behind due to missing
; data as it is a corrupted record.
;
I FIELD=".01" D ; (#355.33,.01)
. K IBAR1,IBAR2,IBAR3
. S IBL1=0 F S IBL1=$O(^IBA(355.33,"B",IBL1)) Q:'IBL1 D
. . S IBLIEN=0 F S IBLIEN=$O(^IBA(355.33,"B",IBL1,IBLIEN)) Q:'IBLIEN D
. . . I IBLIEN=IBBUFDA S IBAR1(IBL1)="" K ^IBA(355.33,"B",IBL1,IBBUFDA)
;
I FIELD=".01"!(FIELD=".04") D ; (#355.33,.01) & (#355.33,.04)
. S IBL1="" F S IBL1=$O(^IBA(355.33,"AEST",IBL1)) Q:IBL1="" D
. . S IBL2=0 F S IBL2=$O(^IBA(355.33,"AEST",IBL1,IBL2)) Q:'IBL2 D
. . . S IBLIEN=0 F S IBLIEN=$O(^IBA(355.33,"AEST",IBL1,IBL2,IBLIEN)) Q:'IBLIEN D
. . . . I IBLIEN=IBBUFDA S IBAR2(IBL1,IBL2)="" K ^IBA(355.33,"AEST",IBL1,IBL2,IBBUFDA)
. ;
. S IBL1="" F S IBL1=$O(^IBA(355.33,"AFST",IBL1)) Q:IBL1="" D
. . S IBL2=0 F S IBL2=$O(^IBA(355.33,"AFST",IBL1,IBL2)) Q:'IBL2 D
. . . S IBLIEN=0 F S IBLIEN=$O(^IBA(355.33,"AFST",IBL1,IBL2,IBLIEN)) Q:'IBLIEN D
. . . . I IBLIEN=IBBUFDA S IBAR3(IBL1,IBL2)="" K ^IBA(355.33,"AFST",IBL1,IBL2,IBBUFDA)
. ;
. I 'IBPATNM D XREFC(1)
. ;
. ; save into total ;(* IBART - use for debugging by programmer only)
. ;M IBART(IBBUFDA,"B")=IBAR1,IBART(IBBUFDA,"AEST")=IBAR2,IBART(IBBUFDA,"AFST")=IBAR3
;
I FIELD="60.01" D XREFC(1)
;
; Kills all nodes, including the zero node, and all cross references where the
; data was present on the record
S DIK="^IBA(355.33,",DA=IBBUFDA
D ^DIK K DA,DIK
Q
;
XREFC(DELREC) ; Clean up possible bad "C" cross-reference related to (#355.33,60.01)
;
; DELREC - 1 if the entire record in #355.33 will be killed, track the killing of the "C" x-ref
; 0 the record will not be killed, do not track the killing of the "C" x-ref
;
N IBAR4,IBL1,IBLIEN
K IBAR4
S IBL1=0 F S IBL1=$O(^IBA(355.33,"C",IBL1)) Q:'IBL1 D
. S IBLIEN=0 F S IBLIEN=$O(^IBA(355.33,"C",IBL1,IBLIEN)) Q:'IBLIEN D
. . I IBLIEN=IBBUFDA S IBAR4(IBL1)="" K ^IBA(355.33,"C",IBL1,IBBUFDA)
;
; save into total ;(* IBART - use for debugging by programmer only)
;I DELREC M IBART(IBBUFDA,"C")=IBAR4
Q
;
LIST ;IB*763/CKB - List of Corrupted Buffers in File #355.33
N IBARR,IBBUFDA,IBCNT,IBHNG,IBNODE0,IBNOK,IBP01,IBPATNM,IBREC,IBSTART,IBSTAT,IBSTOP
N IBUNAME,LN,MSG,SITENAME,SITESYS,TOTAL
;
; 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 #
S IBSTART=$$NOW^XLFDT()
S IBUNAME=$$NAME^XUSER($G(IBUS))
;
;List Header
S LN=1,TOTAL=0
S MSG(LN)="Last run by "_IBUNAME,LN=LN+1
S MSG(LN)=" ",LN=LN+1
S MSG(LN)="Date Created^Buffer IEN^Patient",LN=LN+1
;
;Search for corrupted entries
S IBBUFDA=0 F S IBBUFDA=$O(^IBA(355.33,IBBUFDA)) Q:('+IBBUFDA) D
. ; get node 0
. S IBNODE0=$G(^IBA(355.33,IBBUFDA,0))
. ; get (#.01) date entered, (#.04) status, (#60.01) patient name
. K IBARR,IBREC
. D GETS^DIQ(355.33,IBBUFDA_",",".01;.04;60.01","IE","IBREC")
. M IBARR=IBREC(355.33,IBBUFDA_",")
. S IBSTAT=$G(IBARR(.04,"I")),IBP01=$G(IBARR(.01,"I")),IBPATNM=$G(IBARR(60.01,"E"))
. ;
. ; If missing .01(DATE ENTERED is not populated)
. I IBP01="" D SAVLIST Q
. ; Corrupted buffer entry (STATUS is not E,A,R)
. I IBSTAT="" D SAVLIST Q
. ; Patient Name is missing for Entered Status
. I IBSTAT="E",IBPATNM="" D SAVLIST Q
. ;
. ; Accepted/Rejected buffer entries
. I (("^A^R^")[("^"_IBSTAT_"^")) D
. . ; Corrupted buffer entry (PATIENT NAME is populated - EVIL GHOST)
. . I IBPATNM'="" D SAVLIST Q
. . ; Corrupted buffer entry (PATIENT NAME is not populated & has a node other than Zero)
. . I IBPATNM="",$O(^IBA(355.33,IBBUFDA,0)) D SAVLIST
;
S MSG(LN)="**End of Report**"
;
; save message into ^XTMP for 15 days
S (IBNOK,IBCNT,IBHNG)=0,IBSTOP=$$NOW^XLFDT()
;
; IBXTMPNM = "IB eInsurance LIST OF CORRUPTED BUFFERS IN #355.33"
F L +^XTMP(IBXTMPNM):30 Q:$T H 10 S IBHNG=IBHNG+1 I IBHNG>10 S IBNOK=1 Q
I IBNOK Q ; not able to get the lock
S ^XTMP(IBXTMPNM,0)=$$FMADD^XLFDT(DT,15)_U_$$NOW^XLFDT()_U_"IB file 355.33 List of Corrupt Buffers"
S IBCNT=$G(^XTMP(IBXTMPNM,"C"))+1,^XTMP(IBXTMPNM,"C")=IBCNT
L -^XTMP(IBXTMPNM)
;
; place message info in ^XTMP
S ^XTMP(IBXTMPNM,IBCNT,0)=$G(IBUNAME)_U_SITESYS_"-"_SITENAME
M ^XTMP(IBXTMPNM,IBCNT,"M")=MSG
; place start-stop time
S ^XTMP(IBXTMPNM,IBCNT,"T")=IBSTART_U_IBSTOP
;
LISTQ ; Exit from List
; Tell TaskManager to delete the task's record
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
SAVLIST ;IB*763/CKB - Save List output to MSG array
S MSG(LN)=$$DAT3^IBOUTL(IBARR(.01,"I"))_"^"_IBBUFDA_"^"_IBARR(60.01,"E")
S LN=LN+1,TOTAL=TOTAL+1
Q
;
FLHELP ;IB*763/CKB - Help Text for the 'Fix or List Corrupt Buffers' prompt.
W !!," Select Fix to fix corrupted entries in the INSURANCE VERIFICATION PROCESSOR"
W !," file (#355.33) aka 'the buffer file'. Select List to display corrupted entries"
W !," in the INSURANCE VERIFICATION PROCESSOR file (#355.33) aka 'the buffer file'."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPI2 16931 printed Sep 23, 2025@19:59:49 Page 2
IBJPI2 ;DAOU/BHS - eIV SITE PARAMETERS SCREEN ACTIONS ;26-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,316,416,438,713,737,763**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; eIV - electronic Insurance Verification Interface
+5 ;
+6 ; Only call from tag
+7 QUIT
+8 ;
IIVEDIT ; -- IBJP IIV EDIT ACTIONS (GP,PW): Edit eIV Site Parameters
+1 NEW DA,DR,DIE,DIC,X,Y
+2 ;
+3 ;IB*737/TAZ - Removed parameter and clean up the code
+4 ;
+5 DO FULL^VALM1
+6 WRITE @IOF,!,"General Parameters",!
+7 SET DR="[IBCNE GENERAL PARAMETER EDIT]"
+8 SET DIE="^IBE(350.9,"
SET DA=1
DO ^DIE
KILL DA,DR,DIE,DIC,X,Y
+9 ;
+10 DO INIT^IBJPI
SET VALMBCK="R"
+11 QUIT
+12 ;
LTENT ; entry from list template protocol 'IBJP IIV FIX CORRUPT BUFFERS' from 'IBJP INS VER MENU' menu
+1 ;IB*763/CKB - added IBFL,IBFR
NEW IBA,IBERR,IBFL,IBFR,IBMSG,IBOK,IBXTMPNM,IBGHDESC,ZTDESC,IBOKM
+2 ;
+3 SET IBXTMPNM="IBJPI2_FIX_BUFFER_RECS"
SET IBGHDESC="IB file 355.33 Corrupt Buffer Clean up"
+4 SET ZTDESC="IB eInsurance FIX CORRUPTED BUFFERS IN #355.33"
+5 SET (IBOK,IBOKM)=1
+6 IF $GET(DT)=""
SET DT=$$DT^XLFDT
FXLST ;IB*763/CKB - Prompt user to run 'Fix or List Corrupt Buffers'
+1 DO FULL^VALM1
+2 KILL DIR,DIRUT,DUOUT,X,Y
+3 SET DIR(0)="SA^F:Fix;L:List"
+4 SET DIR("A")="Fix or List Corrupt Buffers? "
+5 SET DIR("?")="^D FLHELP^IBJPI2"
+6 SET DIR("??")="^D FLHELP^IBJPI2"
+7 SET DIR("B")="List"
+8 DO ^DIR
KILL DIR
+9 SET IBFR=$$UP^XLFSTR($EXTRACT(Y,1))
+10 IF IBFR="^"!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
DO PAUSE^VALM1
GOTO LTOUT
+11 IF (IBFR'="F")&(IBFR'="L")
WRITE !," Select 'F'ix or 'L'ist",!
GOTO FXLST
+12 ;
+13 ;IB*763/CKB - if user selects LIST, change ZTDESC, IBXTMPNM and IBGHDESC
+14 ; set IBFR=("F" or "L") / IBFL=("Fix Corrupt Buffer" or "List of Corrupt Buffers")
+15 IF IBFR="L"
Begin DoDot:1
+16 SET ZTDESC="IB eInsurance LIST OF CORRUPTED BUFFERS IN #355.33"
+17 SET IBXTMPNM="IBJPI2_LIST_BUFFER_RECS"
SET IBGHDESC="IB file 355.33 List of Corrupt Buffers"
End DoDot:1
+18 SET IBFL=$SELECT(IBFR="F":"Fix Corrupt Buffer",1:"List of Corrupt Buffers")
+19 ;
+20 DO LTCHKRN
IF 'IBOK
Begin DoDot:1
+21 ;IB*763/CKB - Allow to Fix or List, using variables IBFR and IBFL
+22 IF IBOKM
Begin DoDot:2
+23 IF IBFR="F"
WRITE !,"Not submitting Fix Corrupt Buffers to run"
+24 IF IBFR="L"
WRITE !,"Not creating List of Corrupt Buffers."
End DoDot:2
End DoDot:1
DO PAUSE^VALM1
GOTO LTOUT
+25 DO FULL^VALM1
WRITE !!
+26 SET IBMSG(0)=0
+27 SET IBERR=$$TASKIN($SELECT(IBFR="L":IBFL,1:"Corrupt Buffers Fixed"),$GET(DUZ),"IBMSG")
+28 IF +IBERR!('$GET(IBMSG(0)))
Begin DoDot:1
+29 WRITE !!,"Error in submitting '"_IBFL_"'."
+30 WRITE !,"Please Contact eInsurance Team"
End DoDot:1
DO PAUSE^VALM1
GOTO LTOUT
+31 IF $GET(IBMSG(0))
WRITE !!
SET IBA=0
FOR
SET IBA=$ORDER(IBMSG(IBA))
if 'IBA
DO PAUSE^VALM1
if 'IBA
QUIT
WRITE IBMSG(IBA),!
+32 ;
LTOUT ; list template protocol quit
+1 DO INIT^IBJPI
SET VALMBCK="R"
+2 QUIT
+3 ;
LTCHKRN ; has the CBF been run in the last 15 days
+1 NEW DIR,DIRUT,DUOUT,IBA,IBA1,IBB,IBB1,IBC,IBCHK,IBLCNT,IBLCTOP,IBLDT,IBMSF,IBMSG
+2 NEW IBRDT,IBSTR,IBT,MSG,MSGD,X,Y
+3 ;
+4 SET IBCHK=""
SET IBSTR=""
SET $PIECE(IBSTR,"*",80)=""
+5 SET IBLCNT=$GET(^XTMP(IBXTMPNM,"C"))
IF IBLCNT
SET IBCHK=$GET(^XTMP(IBXTMPNM,0))
+6 SET IBLDT=$PIECE($PIECE(IBCHK,U,2),".",1)
SET IBRDT=$$FMTE^XLFDT(IBLDT)
+7 SET IBMSF="Last run was "_($SELECT(IBLDT:"on "_IBRDT,1:"over 2 weeks ago"))
+8 SET MSGD=""
SET MSG=$$CHKTSK
+9 DO FULL^VALM1
WRITE !!
+10 WRITE IBMSF,!
+11 ;IB*763/CKB - Set MSGD using IBFL for Fix or List wording
+12 ; IBFL = "Fix Corrupt Buffer" or "List of Corrupt Buffers"
+13 IF +MSG
Begin DoDot:1
+14 SET MSGD="*** '"_IBFL_"' "
+15 SET MSGD=MSGD_$PIECE($PIECE(MSG,U,2),"y",1)_"y ***^*** "_$PIECE($PIECE(MSG,U,2),"y",2,999)
End DoDot:1
+16 IF IBLDT
Begin DoDot:1
+17 KILL DIR,DIRUT,DUOUT
+18 SET DIR("?")="Enter 'Y' to view the details of the last run, Enter 'N' to skip or '^' to quit."
+19 SET DIR("A")="Do you want the details"
SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
+20 IF 'Y
if $EXTRACT(Y)=U!($DATA(DIRUT))!($DATA(DUOUT))
SET IBOK=0
QUIT
+21 SET IBLCTOP=^XTMP(IBXTMPNM,IBLCNT,0)
SET IBT=$GET(^XTMP(IBXTMPNM,IBLCNT,"T"))
+22 MERGE IBMSG=^XTMP(IBXTMPNM,IBLCNT,"M")
+23 WRITE !!,"Run For: ",$PIECE(IBLCTOP,U,2),!
+24 WRITE "Started: "
SET IBC=$PIECE(IBT,U,1)
if IBC'=""
SET IBC=$$FMTE^XLFDT(IBC)
SET IBC=$PIECE(IBC,":",1,2)
WRITE IBC
+25 WRITE ?35,"Completed: "
SET IBC=$PIECE(IBT,U,2)
if IBC'=""
SET IBC=$$FMTE^XLFDT(IBC)
SET IBC=$PIECE(IBC,":",1,2)
WRITE IBC,!
+26 SET IBA=0
FOR
SET IBA=$ORDER(IBMSG(IBA))
if IBA=""
QUIT
SET IBB=IBMSG(IBA)
IF IBB'=""&(IBB'=" ")
WRITE !,IBB
+27 WRITE !
End DoDot:1
IF 'IBOK
QUIT
+28 ; don't ask submit question if already scheduled just quit out
+29 IF MSGD'=""
Begin DoDot:1
+30 SET IBA1=$PIECE(MSGD,U,1)
SET IBB1=$PIECE(MSGD,U,2,99)
+31 WRITE !!,$EXTRACT(IBSTR,1,$LENGTH(IBA1)),!,IBA1,!,IBB1,($EXTRACT(" ",1,($LENGTH(IBA1)-3-$LENGTH(IBB1)))),"***",!
+32 WRITE $EXTRACT(IBSTR,1,$LENGTH(IBA1))
End DoDot:1
SET (IBOK,IBOKM)=0
QUIT
+33 ;
+34 ;IB*763/CKB - Include X,Y in kill and use IBFL for Fix or List Help Text wording
+35 KILL DIR,DIRUT,DUOUT,X,Y
+36 SET DIR("A")="Do you want to run "_IBFL
+37 SET DIR("?")="Enter 'Y' to run "_$SELECT(IBFR="L":"the "_IBFL,1:"Corrupt Buffers Fix")
+38 SET DIR("?")=DIR("?")_", Enter 'N' or '^' to quit."
+39 SET DIR(0)="Y"
SET DIR("B")="No"
+40 DO ^DIR
KILL DIR
+41 IF $EXTRACT(Y)=U!('Y)!($DATA(DIRUT))!($DATA(DUOUT))
SET IBOK=0
+42 QUIT
+43 ;
TASKIN(IBSB,IBUS,IBRET,IBFLIN) ; Clean-up corrupted records in the Insurance Verification Processor file #355.33
+1 ;INPUT:
+2 ; IBSB - message subject
+3 ; IBUS - user DUZ to use
+4 ; IBRET - message return array to calling entity passed in as "VARIBLE"
+5 ; IBFLIN - first line of e-mail message (if one) [opt]
+6 ;
+7 NEW IBA,IBB,IBNAME,IBUDUZ,MSG,RMSG,WMSG,ZTDTH,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE
+8 ;
+9 SET IBUDUZ=$GET(DUZ)
+10 SET IBUS=$GET(IBUS)
if IBUS=""
SET IBUS=$GET(DUZ)
IF IBUS=""
SET IBUS=.5
+11 SET IBSB=$GET(IBSB)
+12 SET IBRET=$GET(IBRET)
IF IBRET=""
QUIT "1^Need return array"
+13 SET IBFLIN=$GET(IBFLIN)
+14 KILL @IBRET
+15 ;
+16 ;IB*763/CKB - ZTDESC is already set, don't want to reset. Overwrites if user is running List
+17 ;S ZTDESC="IB eInsurance FIX CORRUPTED BUFFERS IN #355.33"
+18 ;
+19 ; ZTDTH = TODAY AT 8:00 PM
+20 SET ZTDTH=$PIECE($$NOW^XLFDT(),".")
SET ZTDTH=$$FMADD^XLFDT(ZTDTH,,20)
+21 SET ZTIO=""
+22 SET ZTQUEUED=1
+23 SET ZTRTN="BADRECS^IBJPI2"
+24 ;IB*763/CKB
IF $EXTRACT(IBSB,1)="L"
SET ZTRTN="LIST^IBJPI2"
+25 SET ZTSAVE("IBUS")=""
SET ZTSAVE("IBSB")=""
SET ZTSAVE("IBFLIN")=""
+26 SET ZTSAVE("IBXTMPNM")=""
SET ZTSAVE("IBGHDESC")=""
+27 ;
+28 SET @IBRET@(0)=1
+29 SET RMSG(0)=""
SET MSG=$$TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO,.RMSG)
+30 SET @IBRET@(1)=MSG
+31 ;< multi line message to avoid wrap
IF RMSG(0)
Begin DoDot:1
+32 SET IBA=0
FOR
SET IBA=$ORDER(RMSG(IBA))
if 'IBA
QUIT
SET IBB=$GET(RMSG(IBA))
IF IBB'=""
SET @IBRET@(IBA+1)=IBB
SET @IBRET@(0)=@IBRET@(0)+1
End DoDot:1
+33 ;
TSKCLNQ ;
+1 QUIT ""
+2 ;
CHKTSK() ;Check if task already scheduled for date/time
+1 NEW GTASKS,MSGA,TSK,ZTSK
+2 ;
+3 KILL GTASKS
+4 DO DESC^%ZTLOAD(ZTDESC,"GTASKS")
+5 SET TSK=""
SET MSGA=0
+6 SET TSK=$ORDER(GTASKS(TSK))
+7 IF TSK'=""
Begin DoDot:1
+8 SET ZTSK=TSK
DO ISQED^%ZTLOAD
+9 SET MSGA="1^Task #"_+ZTSK_" is already scheduled to run on "_$$HTE^XLFDT(ZTSK("D"),1)_" "
End DoDot:1
QUIT MSGA
+10 QUIT MSGA
+11 ;
TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO,RMSG) ;bypass for queued task
+1 NEW %DT,GTASKS,IBAA,IDT,MSG,MSG1,NOW,TIME,TSK,XDT,Y,ZTSK
+2 ;
+3 ; XDT is TODAY@2000 reformatted to a readable date.
SET (IDT,Y)=ZTDTH
DO DD^%DT
SET XDT=Y
+4 ;
+5 ;Check if task already scheduled for date/time
+6 SET RMSG(0)=0
+7 SET MSG=$$CHKTSK
+8 IF +MSG
SET MSG=$PIECE(MSG,U,2,999)
QUIT MSG
+9 ;Schedule the task
+10 SET TSK=$$SCHED(IDT,ZTIO)
+11 ;
+12 ;Check for scheduling problem
+13 IF $GET(TSK)=""
SET MSG=" Task Could Not Be Scheduled"
QUIT MSG
+14 ;
+15 ;Send successful schedule message
+16 SET NOW=$$NOW^XLFDT
SET TIME=""
+17 IF '$PIECE(TSK,U,3)
SET TIME=NOW
+18 IF $PIECE(TSK,U,3)
SET TIME=$PIECE(TSK,U,2)
+19 SET TIME=$$FMTE^XLFDT(TIME)
+20 ;IB*763/CKB - allow for Fix or List message
+21 SET MSG="Task: "_$PIECE($GET(TSK),U)_" Clean-up of corrupted records in file #355.33"
+22 IF IBFR="L"
SET MSG="Task: "_$PIECE($GET(TSK),U)_" List of Corrupt Buffers in file #355.33 "
+23 SET RMSG(1)=" scheduled for "_TIME
+24 SET RMSG(0)=1
+25 QUIT MSG
+26 ;
SCHED(ZTDTH,ZTIO) ;
+1 NEW ZTSK,IBDT
+2 DO ^%ZTLOAD
+3 IF $GET(ZTSK)=""
QUIT ""
+4 SET IBDT=$$HTFM^XLFDT(ZTSK("D"))
+5 ; 72000 represents 8pm in $harlog seconds
+6 QUIT ZTSK_U_IBDT_U_$SELECT($PIECE(ZTSK("D"),",",2)=72000:1,1:0)
+7 ;
BADRECS ; Clean-up corrupted records in File #355.33.
+1 NEW CNT,DA,DIC,DIE,DR,I,IBART,IBUNAME,IBBUFDA,IBNODE0,IBOK,IBP01,IBPATNM
+2 NEW IBRETA,IBSTAT,IBSTART,IBSTOP,IBTYP,IBWRKARY,IBXMY,MSG,SITESYS,SITENAME
+3 NEW TOTAL,X,Y
+4 ;
+5 KILL IBART
SET IBART=""
+6 ; recalculate SITESYS here as this tag is called from TaskMan
+7 ; Get the site name & #
SET SITESYS=$$SITE^VASITE
+8 ; piece 3 is the site #
SET SITENAME=$PIECE(SITESYS,U,2)
SET SITESYS=$PIECE(SITESYS,U,3)
+9 SET IBSTART=$$NOW^XLFDT()
+10 FOR I="AR","B","E"
SET CNT(I)=0
+11 ;
+12 ;Search for corrupted entries
+13 SET IBBUFDA=0
+14 FOR
SET IBBUFDA=$ORDER(^IBA(355.33,IBBUFDA))
if ('+IBBUFDA)
QUIT
Begin DoDot:1
+15 ; get node 0
+16 SET IBNODE0=$GET(^IBA(355.33,IBBUFDA,0))
+17 ; get (#.01) date entered, (#.04) status, (#60.01) patient name
+18 KILL IBRETA
DO GETS^DIQ(355.33,IBBUFDA_",",".01;.04;60.01","I","IBRETA")
+19 KILL IBWRKARY
MERGE IBWRKARY=IBRETA(355.33,IBBUFDA_",")
+20 SET IBSTAT=$GET(IBWRKARY(.04,"I"))
SET IBP01=$GET(IBWRKARY(.01,"I"))
SET IBPATNM=$GET(IBWRKARY(60.01,"I"))
+21 ;
+22 ; If missing .01 then delete (DATE ENTERED is not populated)
+23 IF IBP01=""
DO DELREC(".01",IBPATNM)
SET IBTYP="B"
SET CNT(IBTYP)=$GET(CNT(IBTYP))+1
QUIT
+24 ;
+25 ; Corrupted buffer entry (STATUS is not E,A,R)
+26 IF IBSTAT=""
DO DELREC(".04",IBPATNM)
SET IBTYP="B"
SET CNT(IBTYP)=$GET(CNT(IBTYP))+1
QUIT
+27 ;
+28 IF IBSTAT="E"
Begin DoDot:2
+29 ; Patient Name is missing for Entered Status
+30 IF IBPATNM=""
DO DELREC("60.01",IBPATNM)
SET IBTYP="B"
SET CNT(IBTYP)=$GET(CNT(IBTYP))+1
End DoDot:2
QUIT
+31 ;
+32 ; Accepted/Rejected buffer entries, clean up all but the Zero node
+33 IF (("^A^R^")[("^"_IBSTAT_"^"))
Begin DoDot:2
+34 ; Corrupted buffer entry (PATIENT NAME is populated - EVIL GHOST)
+35 IF IBPATNM'=""
DO DELDATA
SET IBTYP="E"
SET CNT(IBTYP)=$GET(CNT(IBTYP))+1
QUIT
+36 ;
+37 ; Corrupted buffer entry (PATIENT NAME is not populated & has a node other than Zero)
+38 IF IBPATNM=""
IF $ORDER(^IBA(355.33,IBBUFDA,0))
Begin DoDot:3
+39 DO XREFC(0)
DO DELDATA
SET IBTYP="AR"
SET CNT(IBTYP)=$GET(CNT(IBTYP))+1
End DoDot:3
End DoDot:2
End DoDot:1
+40 ;
+41 ;Send mailman message at completion.
+42 SET IBUNAME=$$NAME^XUSER($GET(IBUS))
+43 IF $GET(IBFLIN)=""
SET IBFLIN=IBUNAME_", ran 'Fix Corrupt Buffer' on "_$$FMTE^XLFDT($PIECE($$NOW^XLFDT,".",1),1)
+44 ;
+45 SET MSG(1)=IBFLIN
+46 SET MSG(2)=" - Clean-up of corrupted #355.33 records has completed."
+47 SET MSG(3)="------------------------------------------------------------------------"
+48 SET MSG(4)=" # of corrupt buffer entries corrected (stopped ins. verification): "_CNT("E")
+49 SET MSG(5)=" "
+50 SET MSG(6)=" # of corrupt Accepted/Rejected buffer entries corrected: "_CNT("AR")
+51 SET MSG(7)=" "
+52 SET MSG(8)=" # of corrupt buffer entries removed (bad zero node): "_CNT("B")
+53 SET TOTAL=CNT("E")+CNT("AR")
+54 SET MSG(9)=" "
+55 SET MSG(10)=" Total entries removed: "_CNT("B")
+56 SET MSG(11)=" "
+57 SET MSG(12)=" Total entries corrected: "_TOTAL
+58 ;
+59 DO IBXSAV
+60 ; Only send to eInsurance Rapid Response if in Production
+61 ; 1=Production Environment, 0=Test Environment
+62 IF $GET(IBSB)=""
SET IBSB="Corrupt Buffers Fixed"
+63 IF $$PROD^XUPROD(1)
Begin DoDot:1
+64 SET IBXMY("VHAeInsuranceRapidResponse@domain.ext")=""
+65 DO MSG^IBCNEUT5(,IBSB_" ("_SITESYS_"-"_SITENAME_")","MSG(",,.IBXMY)
End DoDot:1
+66 ;
+67 ; Tell TaskManager to delete the task's record
+68 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+69 ;
BADRECQ ; Exit from Cleaning up Buffers.
+1 QUIT
+2 ;
IBXSAV ; save message into ^XTMP for 15 days
+1 NEW IBNOK,IBCNT,IBHNG
+2 ;
+3 SET (IBNOK,IBCNT,IBHNG)=0
SET IBSTOP=$$NOW^XLFDT()
+4 FOR
LOCK +^XTMP(IBXTMPNM):30
if $TEST
QUIT
HANG 10
SET IBHNG=IBHNG+1
IF IBHNG>10
SET IBNOK=1
QUIT
+5 ; not able to get the lock
IF IBNOK
QUIT
+6 SET ^XTMP(IBXTMPNM,0)=$$FMADD^XLFDT(DT,15)_U_$$NOW^XLFDT()_U_IBGHDESC
+7 SET IBCNT=$GET(^XTMP(IBXTMPNM,"C"))+1
SET ^XTMP(IBXTMPNM,"C")=IBCNT
+8 LOCK -^XTMP(IBXTMPNM)
+9 ; place message info in ^XTMP
+10 SET ^XTMP(IBXTMPNM,IBCNT,0)=$GET(IBUNAME)_U_SITESYS_"-"_SITENAME
+11 MERGE ^XTMP(IBXTMPNM,IBCNT,"M")=MSG
+12 ; place start-stop time
+13 SET ^XTMP(IBXTMPNM,IBCNT,"T")=IBSTART_U_IBSTOP
+14 ;
+15 ; place tmp array kill items in ^XTMP
+16 ; M ^XTMP(IBXTMPNM,IBCNT,"K")=IBART ;(* use for debugging by programmer only)
+17 QUIT
+18 ;
DELDATA ; Delete data from corrupted records
+1 DO DELDATA^IBCNBED(IBBUFDA)
+2 QUIT
+3 ;
DELREC(FIELD,IBPATNM) ;Delete entire record as it is unrecoverable
+1 ;; Kills all nodes, including the zero node, and all cross references
+2 ; FIELD - missing field so we have to kill a few cross-references first
+3 ; IBPATNM - Patient name (#355.33,60.01)
+4 ;
+5 NEW DA,DIK,IBAR1,IBAR2,IBAR3,IBL1,IBL2,IBL3,IBLIEN,IBLP,IBSP,IBSN,IBOST
+6 ;
+7 IF FIELD=""
QUIT
+8 ;
+9 ; ** Before killing the buffer record using IBBUFDA, search and kill specific
+10 ; cross-references that would be left behind due to missing
+11 ; data as it is a corrupted record.
+12 ;
+13 ; (#355.33,.01)
IF FIELD=".01"
Begin DoDot:1
+14 KILL IBAR1,IBAR2,IBAR3
+15 SET IBL1=0
FOR
SET IBL1=$ORDER(^IBA(355.33,"B",IBL1))
if 'IBL1
QUIT
Begin DoDot:2
+16 SET IBLIEN=0
FOR
SET IBLIEN=$ORDER(^IBA(355.33,"B",IBL1,IBLIEN))
if 'IBLIEN
QUIT
Begin DoDot:3
+17 IF IBLIEN=IBBUFDA
SET IBAR1(IBL1)=""
KILL ^IBA(355.33,"B",IBL1,IBBUFDA)
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 ; (#355.33,.01) & (#355.33,.04)
IF FIELD=".01"!(FIELD=".04")
Begin DoDot:1
+20 SET IBL1=""
FOR
SET IBL1=$ORDER(^IBA(355.33,"AEST",IBL1))
if IBL1=""
QUIT
Begin DoDot:2
+21 SET IBL2=0
FOR
SET IBL2=$ORDER(^IBA(355.33,"AEST",IBL1,IBL2))
if 'IBL2
QUIT
Begin DoDot:3
+22 SET IBLIEN=0
FOR
SET IBLIEN=$ORDER(^IBA(355.33,"AEST",IBL1,IBL2,IBLIEN))
if 'IBLIEN
QUIT
Begin DoDot:4
+23 IF IBLIEN=IBBUFDA
SET IBAR2(IBL1,IBL2)=""
KILL ^IBA(355.33,"AEST",IBL1,IBL2,IBBUFDA)
End DoDot:4
End DoDot:3
End DoDot:2
+24 ;
+25 SET IBL1=""
FOR
SET IBL1=$ORDER(^IBA(355.33,"AFST",IBL1))
if IBL1=""
QUIT
Begin DoDot:2
+26 SET IBL2=0
FOR
SET IBL2=$ORDER(^IBA(355.33,"AFST",IBL1,IBL2))
if 'IBL2
QUIT
Begin DoDot:3
+27 SET IBLIEN=0
FOR
SET IBLIEN=$ORDER(^IBA(355.33,"AFST",IBL1,IBL2,IBLIEN))
if 'IBLIEN
QUIT
Begin DoDot:4
+28 IF IBLIEN=IBBUFDA
SET IBAR3(IBL1,IBL2)=""
KILL ^IBA(355.33,"AFST",IBL1,IBL2,IBBUFDA)
End DoDot:4
End DoDot:3
End DoDot:2
+29 ;
+30 IF 'IBPATNM
DO XREFC(1)
+31 ;
+32 ; save into total ;(* IBART - use for debugging by programmer only)
+33 ;M IBART(IBBUFDA,"B")=IBAR1,IBART(IBBUFDA,"AEST")=IBAR2,IBART(IBBUFDA,"AFST")=IBAR3
End DoDot:1
+34 ;
+35 IF FIELD="60.01"
DO XREFC(1)
+36 ;
+37 ; Kills all nodes, including the zero node, and all cross references where the
+38 ; data was present on the record
+39 SET DIK="^IBA(355.33,"
SET DA=IBBUFDA
+40 DO ^DIK
KILL DA,DIK
+41 QUIT
+42 ;
XREFC(DELREC) ; Clean up possible bad "C" cross-reference related to (#355.33,60.01)
+1 ;
+2 ; DELREC - 1 if the entire record in #355.33 will be killed, track the killing of the "C" x-ref
+3 ; 0 the record will not be killed, do not track the killing of the "C" x-ref
+4 ;
+5 NEW IBAR4,IBL1,IBLIEN
+6 KILL IBAR4
+7 SET IBL1=0
FOR
SET IBL1=$ORDER(^IBA(355.33,"C",IBL1))
if 'IBL1
QUIT
Begin DoDot:1
+8 SET IBLIEN=0
FOR
SET IBLIEN=$ORDER(^IBA(355.33,"C",IBL1,IBLIEN))
if 'IBLIEN
QUIT
Begin DoDot:2
+9 IF IBLIEN=IBBUFDA
SET IBAR4(IBL1)=""
KILL ^IBA(355.33,"C",IBL1,IBBUFDA)
End DoDot:2
End DoDot:1
+10 ;
+11 ; save into total ;(* IBART - use for debugging by programmer only)
+12 ;I DELREC M IBART(IBBUFDA,"C")=IBAR4
+13 QUIT
+14 ;
LIST ;IB*763/CKB - List of Corrupted Buffers in File #355.33
+1 NEW IBARR,IBBUFDA,IBCNT,IBHNG,IBNODE0,IBNOK,IBP01,IBPATNM,IBREC,IBSTART,IBSTAT,IBSTOP
+2 NEW IBUNAME,LN,MSG,SITENAME,SITESYS,TOTAL
+3 ;
+4 ; recalculate SITESYS here as this tag is called from TaskMan
+5 ; Get the site name & #
SET SITESYS=$$SITE^VASITE
+6 ; piece 3 is the site #
SET SITENAME=$PIECE(SITESYS,U,2)
SET SITESYS=$PIECE(SITESYS,U,3)
+7 SET IBSTART=$$NOW^XLFDT()
+8 SET IBUNAME=$$NAME^XUSER($GET(IBUS))
+9 ;
+10 ;List Header
+11 SET LN=1
SET TOTAL=0
+12 SET MSG(LN)="Last run by "_IBUNAME
SET LN=LN+1
+13 SET MSG(LN)=" "
SET LN=LN+1
+14 SET MSG(LN)="Date Created^Buffer IEN^Patient"
SET LN=LN+1
+15 ;
+16 ;Search for corrupted entries
+17 SET IBBUFDA=0
FOR
SET IBBUFDA=$ORDER(^IBA(355.33,IBBUFDA))
if ('+IBBUFDA)
QUIT
Begin DoDot:1
+18 ; get node 0
+19 SET IBNODE0=$GET(^IBA(355.33,IBBUFDA,0))
+20 ; get (#.01) date entered, (#.04) status, (#60.01) patient name
+21 KILL IBARR,IBREC
+22 DO GETS^DIQ(355.33,IBBUFDA_",",".01;.04;60.01","IE","IBREC")
+23 MERGE IBARR=IBREC(355.33,IBBUFDA_",")
+24 SET IBSTAT=$GET(IBARR(.04,"I"))
SET IBP01=$GET(IBARR(.01,"I"))
SET IBPATNM=$GET(IBARR(60.01,"E"))
+25 ;
+26 ; If missing .01(DATE ENTERED is not populated)
+27 IF IBP01=""
DO SAVLIST
QUIT
+28 ; Corrupted buffer entry (STATUS is not E,A,R)
+29 IF IBSTAT=""
DO SAVLIST
QUIT
+30 ; Patient Name is missing for Entered Status
+31 IF IBSTAT="E"
IF IBPATNM=""
DO SAVLIST
QUIT
+32 ;
+33 ; Accepted/Rejected buffer entries
+34 IF (("^A^R^")[("^"_IBSTAT_"^"))
Begin DoDot:2
+35 ; Corrupted buffer entry (PATIENT NAME is populated - EVIL GHOST)
+36 IF IBPATNM'=""
DO SAVLIST
QUIT
+37 ; Corrupted buffer entry (PATIENT NAME is not populated & has a node other than Zero)
+38 IF IBPATNM=""
IF $ORDER(^IBA(355.33,IBBUFDA,0))
DO SAVLIST
End DoDot:2
End DoDot:1
+39 ;
+40 SET MSG(LN)="**End of Report**"
+41 ;
+42 ; save message into ^XTMP for 15 days
+43 SET (IBNOK,IBCNT,IBHNG)=0
SET IBSTOP=$$NOW^XLFDT()
+44 ;
+45 ; IBXTMPNM = "IB eInsurance LIST OF CORRUPTED BUFFERS IN #355.33"
+46 FOR
LOCK +^XTMP(IBXTMPNM):30
if $TEST
QUIT
HANG 10
SET IBHNG=IBHNG+1
IF IBHNG>10
SET IBNOK=1
QUIT
+47 ; not able to get the lock
IF IBNOK
QUIT
+48 SET ^XTMP(IBXTMPNM,0)=$$FMADD^XLFDT(DT,15)_U_$$NOW^XLFDT()_U_"IB file 355.33 List of Corrupt Buffers"
+49 SET IBCNT=$GET(^XTMP(IBXTMPNM,"C"))+1
SET ^XTMP(IBXTMPNM,"C")=IBCNT
+50 LOCK -^XTMP(IBXTMPNM)
+51 ;
+52 ; place message info in ^XTMP
+53 SET ^XTMP(IBXTMPNM,IBCNT,0)=$GET(IBUNAME)_U_SITESYS_"-"_SITENAME
+54 MERGE ^XTMP(IBXTMPNM,IBCNT,"M")=MSG
+55 ; place start-stop time
+56 SET ^XTMP(IBXTMPNM,IBCNT,"T")=IBSTART_U_IBSTOP
+57 ;
LISTQ ; Exit from List
+1 ; Tell TaskManager to delete the task's record
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
SAVLIST ;IB*763/CKB - Save List output to MSG array
+1 SET MSG(LN)=$$DAT3^IBOUTL(IBARR(.01,"I"))_"^"_IBBUFDA_"^"_IBARR(60.01,"E")
+2 SET LN=LN+1
SET TOTAL=TOTAL+1
+3 QUIT
+4 ;
FLHELP ;IB*763/CKB - Help Text for the 'Fix or List Corrupt Buffers' prompt.
+1 WRITE !!," Select Fix to fix corrupted entries in the INSURANCE VERIFICATION PROCESSOR"
+2 WRITE !," file (#355.33) aka 'the buffer file'. Select List to display corrupted entries"
+3 WRITE !," in the INSURANCE VERIFICATION PROCESSOR file (#355.33) aka 'the buffer file'."
+4 QUIT
