Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBJPI2

IBJPI2.m

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