- 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 Jan 18, 2025@03:24:45 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