IBJPI3 ;AITC/CKB - INSURANCE VERIFICATION SITE PARAMETERS SCREEN ACTIONS ; 30-OCT-2024
;;2.0;INTEGRATED BILLING;**806**;21-MAR-94;Build 19
;;Per VA Directive 6402, this routine should not be modified
;
;
Q
;
BUFDUP ;-- IBJP IIV BUFFER DUPLICATE (BC) - IB*806/CKB
N DA,DR,DIE,DIC,X,Y
;
D FULL^VALM1
W @IOF,!,"Buffer Cleanup",!
S DR="[IBCN BU BUFFER CLEANUP]"
S DIE="^IBE(350.9,",DA=1
D ^DIE K DA,DR,DIE,DIC,X,Y
;
D INIT^IBJPI S VALMBCK="R"
Q
;
;-----------------------------------------------------------------------------
;
BUFCLN(IBRUN,IBQUAL,IBNUM) ; Clean up Buffer of Duplicate entries -IB*806/CKB
; called from IBCNINS - eInsurance Nightly Process
; IBRUN = Run buffer cleanup = 1 / Do not run buffer cleanup = 0
; IBQUAL = "A" - ALL / "N" - Number of buffer entries
; IBNUM = (QUAL=A) = "" / (QUAL=N) = # of buffer entries
;
N IBA,IBDUZ,IBERR,IBXTMPNM,ZTDESC
;
; Get Proxy User
S IBDUZ=+$$FIND1^DIC(200,,"MX","IB,BUFFER CLEANUP")
I IBDUZ="" Q ; if the Proxy User doesn't exist do not continue
I IBRUN="" Q
I $G(IBQUAL)'="" S IBQUAL=$$UP^XLFSTR(IBQUAL)
I $G(IBQUAL)'="" I "A/N/"'[IBQUAL Q
I $G(IBQUAL)="N",$G(IBNUM)="" Q
;
S IBXTMPNM="IBJPI3_CLEANUP_BUFFER_DUPLICATES"
S ZTDESC="IB eInsurance Duplicate Buffer Cleanup"
; if not running cleanup, don't task up - run to the screen
I IBRUN=0 D BUFREJ G BUFCLNX
;
S IBERR=$$TASKIN("Duplicate Buffer Cleanup",$G(IBDUZ),"IBMSG",IBRUN,IBQUAL,IBNUM)
;
BUFCLNX ; Exit Clean up Buffer
Q
;
BUFREJ ; Identify duplicate buffer entries and indicate the entries
; to be Rejected
;
; IBRUN = Run buffer cleanup = 1 / Do not run buffer cleanup = 0
; IBQUAL = "A" - ALL / "N" - Number of buffer entries
; IBNUM = A = "" / N = # of buffer entries
;
N FILE,FIELDS,IBARY,IBBUFDA,IBCNDT,IBCNT
K ^TMP($J,"IBCNINS"),^TMP("REJECT",$J)
;
I '$$FIND1^DIC(200,,"MX","IB,BUFFER CLEANUP") Q ;if the Proxy User doesn't exist do not continue
; *** CHANGE USER if running in the BACKGROUND
I $G(IBDUZ) N DUZ S DUZ=IBDUZ
Q:'DUZ
;
; Only run the cleanup if the BUFFER CLEANUP ENABLED field set to 'YES' or '1', if not Quit
; ** don't check if running the "what if" IBRUN=0
I IBRUN'=0 I $$GET1^DIQ(350.9,"1,",54.03)'="YES" G BUFREJEX ;Buffer Cleanup switch not enabled
;
S IBCNT=0 ;initialize count
S FILE=355.33
S FIELDS=".04;20.01;60.01;90.02;90.03"
; Only Reject entries prior to Today - ($P(IBCNDT,".")=DT)
S IBCNDT=0 F S IBCNDT=$O(^IBA(355.33,"AEST","E",IBCNDT)) Q:('IBCNDT)!($P(IBCNDT,".")=DT) D
. S IBBUFDA=0 F S IBBUFDA=$O(^IBA(355.33,"AEST","E",IBCNDT,IBBUFDA)) Q:'IBBUFDA D
. . N IBDT,IBGRP,IBINS,IBPATNM,IBSTAT,IBSUBID,IENS
. . S IENS=IBBUFDA_","
. . S IBDT=$$GET1^DIQ(FILE,IENS,.01,"I")
. . I (IBDT="")!('$D(^IBA(355.33,IBBUFDA,0))) Q ; bad record, quit
. . K IBARY
. . D GETS^DIQ(FILE,IENS,FIELDS,"EI","IBARY")
. . S IBSTAT=IBARY(FILE,IENS,.04,"I")
. . I IBSTAT'="E" Q ; only checking entries with an ENTERED status, quit
. . S IBPATNM=IBARY(FILE,IENS,60.01,"E")
. . S IBINS=IBARY(FILE,IENS,20.01,"E") I IBINS="" S IBINS="NONE"
. . S IBGRP=IBARY(FILE,IENS,90.02,"E") I IBGRP="" S IBGRP="NONE"
. . S IBSUBID=IBARY(FILE,IENS,90.03,"E") I IBSUBID="" S IBSUBID="NONE"
. . ; Remove any non-alpha numeric characters
. . I IBSUBID'="" S IBSUBID=$$STRIP^IBCNEDE3(IBSUBID)
. . ; There is already an entry in our array, check to see if it's a duplicate
. . I $D(^TMP($J,"IBCNINS",IBPATNM,IBINS,IBGRP,IBSUBID)) D
. . . N IBPCT
. . . ;Add duplicate entry, store in array to be Rejected
. . . S ^TMP("REJECT",$J,IBPATNM,IBBUFDA)=IBINS_U_IBGRP_U_IBSUBID
. . . S IBPCT=$G(^TMP("REJECT",$J,IBPATNM)),IBPCT=IBPCT+1
. . . S ^TMP("REJECT",$J,IBPATNM)=IBPCT
. . ; Store in array of buffer entries
. . S ^TMP($J,"IBCNINS",IBPATNM,IBINS,IBGRP,IBSUBID,IBBUFDA)=""
;
D REJECT
; Only store the BUFFER CLEANUP LAST RUN if the cleanup was actually run (IBRUN=1)
I IBRUN=0 G BUFREJEX
;
; Update the BUFFER CLEANUP LAST RUN field #54.04
N DA,DIE,DR
S DIE="^IBE(350.9,",DA=1,DR="54.04///NOW" D ^DIE
;
BUFREJEX ; Tell TaskManager to delete the task's record
I $D(ZTQUEUED) S ZTREQ="@"
K ^TMP($J,"IBCNINS"),^TMP("REJECT",$J)
Q
;
REJECT ; Reject OR create a list of entries that would be rejected
; loop through ^TMP("REJECT",$J,[patient name],[buffer ien])
N BIEN,GRP,HDR,IBOK,IBRTN,IBSUPRES,INS,PATNAM,REC,REJCNT,SUBID
S (IBOK,REJCNT)=0,IBRTN="IBJPI3"
;
; If IBRUN=0 write Header for the list of entries that would ("what if") be rejected
I IBRUN=0 W !,"Duplicate Buffer Entries Cleanup",! D W !
. S HDR="Patient Name"_U_"Buffer IEN"_U_"Insurance Company"_U_"Group Number"_U_"Subscriber ID"
. W !,HDR,! N I F I=1:1:$L(HDR) W "="
;
S PATNAM="" F S PATNAM=$O(^TMP("REJECT",$J,PATNAM)) Q:PATNAM="" D
. S BIEN="" F S BIEN=$O(^TMP("REJECT",$J,PATNAM,BIEN)) Q:'BIEN!(BIEN="") D
. . S REC=^TMP("REJECT",$J,PATNAM,BIEN)
. . S INS=$P(REC,U),GRP=$P(REC,U,2),SUBID=$P(REC,U,3)
. . ;DO NOT reject Buffer entries with an ASSOCIATED IMAGE (#355.33,.19)
. . I $$GET1^DIQ(355.33,BIEN_",",.19,"I")=1 Q
. . ;create list of entries that would be rejected
. . S REJCNT=REJCNT+1
. . I IBRUN=0,$G(IBQUAL)="N" I REJCNT>$G(IBNUM) Q
. . I IBRUN=0 S IBOK=1 W PATNAM,U,BIEN,U,INS,U,$S(GRP="NONE":"",1:GRP),U,$S(SUBID="NONE":"",1:SUBID),!
. . ;Reject duplicate entries
. . I IBRUN=1 S IBBUFDA=BIEN D
. . . L +^IBA(355.33,IBBUFDA):15 I '$T Q
. . . D REJECT^IBCNBAR(IBBUFDA,IBRTN)
. . . L -^IBA(355.33,IBBUFDA)
. . . Q
. . Q
;
I IBRUN=0,IBOK=0 W "** NONE **",!
Q
;
TASKIN(IBSB,IBDUZ,IBRET,IBRUN,IBQUAL,IBNUM) ; Task Duplicate Buffer Cleanup
;INPUT:
; IBSB - message subject
; IBDUZ - user DUZ to use - IB,BUFFER CLEANUP
; IBRET - message return array to calling entity passed in as "VARIABLE"
; IBRUN - Run buffer cleanup = 1 / Do not run buffer cleanup = 0
; IBQUAL - "A" - ALL / "N" - Number of patients
; IBNUM - (IBQUAL=A) = "" / (IBQUAL=N) = # of patients
;
N IBA,IBB,MSG,RMSG,ZTDTH,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE
;
S IBSB=$G(IBSB)
S IBDUZ=$G(IBDUZ) S:IBDUZ="" IBDUZ=$G(DUZ)
S IBRET=$G(IBRET) I IBRET="" Q "1^Need return array"
K @IBRET
S IBRET="IBMSG" ; IBRET - message return array to calling entity passed in as "VARIABLE"
;
; ZTDTH = TODAY AT 10:00 PM
S ZTDTH=$P($$NOW^XLFDT(),"."),ZTDTH=$$FMADD^XLFDT(ZTDTH,,22)
S ZTIO=""
S ZTQUEUED=1
S ZTRTN="BUFREJ^IBJPI3"
S ZTSAVE("IBDUZ")="",ZTSAVE("IBSB")="",ZTSAVE("IBXTMPNM")=""
S ZTSAVE("IBRUN")="",ZTSAVE("IBQUAL")="",ZTSAVE("IBNUM")=""
;
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 ""
;
TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO,RMSG) ;bypass for queued task
N %DT,GTASKS,IBAA,IDT,MSG,NOW,TIME,TSK,XDT,Y,ZTSK
;
S (IDT,Y)=ZTDTH D DD^%DT S XDT=Y ; XDT is TODAY+1@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 MSG="Task: "_$P($G(TSK),U)_" Duplicate Buffer Cleanup is scheduled for "_XDT ;TIME
Q MSG
;
SCHED(ZTDTH,ZTIO) ;
N ZTSK,IBDT
D ^%ZTLOAD
I $G(ZTSK)="" Q ""
S IBDT=$$HTFM^XLFDT(ZTSK("D"))
; 90000 represents 10pm in $harlog seconds
Q ZTSK_U_IBDT_U_$S($P(ZTSK("D"),",",2)=90000:1,1:0)
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPI3 8067 printed Jan 29, 2026@15:22:33 Page 2
IBJPI3 ;AITC/CKB - INSURANCE VERIFICATION SITE PARAMETERS SCREEN ACTIONS ; 30-OCT-2024
+1 ;;2.0;INTEGRATED BILLING;**806**;21-MAR-94;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 ;
+5 QUIT
+6 ;
BUFDUP ;-- IBJP IIV BUFFER DUPLICATE (BC) - IB*806/CKB
+1 NEW DA,DR,DIE,DIC,X,Y
+2 ;
+3 DO FULL^VALM1
+4 WRITE @IOF,!,"Buffer Cleanup",!
+5 SET DR="[IBCN BU BUFFER CLEANUP]"
+6 SET DIE="^IBE(350.9,"
SET DA=1
+7 DO ^DIE
KILL DA,DR,DIE,DIC,X,Y
+8 ;
+9 DO INIT^IBJPI
SET VALMBCK="R"
+10 QUIT
+11 ;
+12 ;-----------------------------------------------------------------------------
+13 ;
BUFCLN(IBRUN,IBQUAL,IBNUM) ; Clean up Buffer of Duplicate entries -IB*806/CKB
+1 ; called from IBCNINS - eInsurance Nightly Process
+2 ; IBRUN = Run buffer cleanup = 1 / Do not run buffer cleanup = 0
+3 ; IBQUAL = "A" - ALL / "N" - Number of buffer entries
+4 ; IBNUM = (QUAL=A) = "" / (QUAL=N) = # of buffer entries
+5 ;
+6 NEW IBA,IBDUZ,IBERR,IBXTMPNM,ZTDESC
+7 ;
+8 ; Get Proxy User
+9 SET IBDUZ=+$$FIND1^DIC(200,,"MX","IB,BUFFER CLEANUP")
+10 ; if the Proxy User doesn't exist do not continue
IF IBDUZ=""
QUIT
+11 IF IBRUN=""
QUIT
+12 IF $GET(IBQUAL)'=""
SET IBQUAL=$$UP^XLFSTR(IBQUAL)
+13 IF $GET(IBQUAL)'=""
IF "A/N/"'[IBQUAL
QUIT
+14 IF $GET(IBQUAL)="N"
IF $GET(IBNUM)=""
QUIT
+15 ;
+16 SET IBXTMPNM="IBJPI3_CLEANUP_BUFFER_DUPLICATES"
+17 SET ZTDESC="IB eInsurance Duplicate Buffer Cleanup"
+18 ; if not running cleanup, don't task up - run to the screen
+19 IF IBRUN=0
DO BUFREJ
GOTO BUFCLNX
+20 ;
+21 SET IBERR=$$TASKIN("Duplicate Buffer Cleanup",$GET(IBDUZ),"IBMSG",IBRUN,IBQUAL,IBNUM)
+22 ;
BUFCLNX ; Exit Clean up Buffer
+1 QUIT
+2 ;
BUFREJ ; Identify duplicate buffer entries and indicate the entries
+1 ; to be Rejected
+2 ;
+3 ; IBRUN = Run buffer cleanup = 1 / Do not run buffer cleanup = 0
+4 ; IBQUAL = "A" - ALL / "N" - Number of buffer entries
+5 ; IBNUM = A = "" / N = # of buffer entries
+6 ;
+7 NEW FILE,FIELDS,IBARY,IBBUFDA,IBCNDT,IBCNT
+8 KILL ^TMP($JOB,"IBCNINS"),^TMP("REJECT",$JOB)
+9 ;
+10 ;if the Proxy User doesn't exist do not continue
IF '$$FIND1^DIC(200,,"MX","IB,BUFFER CLEANUP")
QUIT
+11 ; *** CHANGE USER if running in the BACKGROUND
+12 IF $GET(IBDUZ)
NEW DUZ
SET DUZ=IBDUZ
+13 if 'DUZ
QUIT
+14 ;
+15 ; Only run the cleanup if the BUFFER CLEANUP ENABLED field set to 'YES' or '1', if not Quit
+16 ; ** don't check if running the "what if" IBRUN=0
+17 ;Buffer Cleanup switch not enabled
IF IBRUN'=0
IF $$GET1^DIQ(350.9,"1,",54.03)'="YES"
GOTO BUFREJEX
+18 ;
+19 ;initialize count
SET IBCNT=0
+20 SET FILE=355.33
+21 SET FIELDS=".04;20.01;60.01;90.02;90.03"
+22 ; Only Reject entries prior to Today - ($P(IBCNDT,".")=DT)
+23 SET IBCNDT=0
FOR
SET IBCNDT=$ORDER(^IBA(355.33,"AEST","E",IBCNDT))
if ('IBCNDT)!($PIECE(IBCNDT,".")=DT)
QUIT
Begin DoDot:1
+24 SET IBBUFDA=0
FOR
SET IBBUFDA=$ORDER(^IBA(355.33,"AEST","E",IBCNDT,IBBUFDA))
if 'IBBUFDA
QUIT
Begin DoDot:2
+25 NEW IBDT,IBGRP,IBINS,IBPATNM,IBSTAT,IBSUBID,IENS
+26 SET IENS=IBBUFDA_","
+27 SET IBDT=$$GET1^DIQ(FILE,IENS,.01,"I")
+28 ; bad record, quit
IF (IBDT="")!('$DATA(^IBA(355.33,IBBUFDA,0)))
QUIT
+29 KILL IBARY
+30 DO GETS^DIQ(FILE,IENS,FIELDS,"EI","IBARY")
+31 SET IBSTAT=IBARY(FILE,IENS,.04,"I")
+32 ; only checking entries with an ENTERED status, quit
IF IBSTAT'="E"
QUIT
+33 SET IBPATNM=IBARY(FILE,IENS,60.01,"E")
+34 SET IBINS=IBARY(FILE,IENS,20.01,"E")
IF IBINS=""
SET IBINS="NONE"
+35 SET IBGRP=IBARY(FILE,IENS,90.02,"E")
IF IBGRP=""
SET IBGRP="NONE"
+36 SET IBSUBID=IBARY(FILE,IENS,90.03,"E")
IF IBSUBID=""
SET IBSUBID="NONE"
+37 ; Remove any non-alpha numeric characters
+38 IF IBSUBID'=""
SET IBSUBID=$$STRIP^IBCNEDE3(IBSUBID)
+39 ; There is already an entry in our array, check to see if it's a duplicate
+40 IF $DATA(^TMP($JOB,"IBCNINS",IBPATNM,IBINS,IBGRP,IBSUBID))
Begin DoDot:3
+41 NEW IBPCT
+42 ;Add duplicate entry, store in array to be Rejected
+43 SET ^TMP("REJECT",$JOB,IBPATNM,IBBUFDA)=IBINS_U_IBGRP_U_IBSUBID
+44 SET IBPCT=$GET(^TMP("REJECT",$JOB,IBPATNM))
SET IBPCT=IBPCT+1
+45 SET ^TMP("REJECT",$JOB,IBPATNM)=IBPCT
End DoDot:3
+46 ; Store in array of buffer entries
+47 SET ^TMP($JOB,"IBCNINS",IBPATNM,IBINS,IBGRP,IBSUBID,IBBUFDA)=""
End DoDot:2
End DoDot:1
+48 ;
+49 DO REJECT
+50 ; Only store the BUFFER CLEANUP LAST RUN if the cleanup was actually run (IBRUN=1)
+51 IF IBRUN=0
GOTO BUFREJEX
+52 ;
+53 ; Update the BUFFER CLEANUP LAST RUN field #54.04
+54 NEW DA,DIE,DR
+55 SET DIE="^IBE(350.9,"
SET DA=1
SET DR="54.04///NOW"
DO ^DIE
+56 ;
BUFREJEX ; Tell TaskManager to delete the task's record
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ^TMP($JOB,"IBCNINS"),^TMP("REJECT",$JOB)
+3 QUIT
+4 ;
REJECT ; Reject OR create a list of entries that would be rejected
+1 ; loop through ^TMP("REJECT",$J,[patient name],[buffer ien])
+2 NEW BIEN,GRP,HDR,IBOK,IBRTN,IBSUPRES,INS,PATNAM,REC,REJCNT,SUBID
+3 SET (IBOK,REJCNT)=0
SET IBRTN="IBJPI3"
+4 ;
+5 ; If IBRUN=0 write Header for the list of entries that would ("what if") be rejected
+6 IF IBRUN=0
WRITE !,"Duplicate Buffer Entries Cleanup",!
Begin DoDot:1
+7 SET HDR="Patient Name"_U_"Buffer IEN"_U_"Insurance Company"_U_"Group Number"_U_"Subscriber ID"
+8 WRITE !,HDR,!
NEW I
FOR I=1:1:$LENGTH(HDR)
WRITE "="
End DoDot:1
WRITE !
+9 ;
+10 SET PATNAM=""
FOR
SET PATNAM=$ORDER(^TMP("REJECT",$JOB,PATNAM))
if PATNAM=""
QUIT
Begin DoDot:1
+11 SET BIEN=""
FOR
SET BIEN=$ORDER(^TMP("REJECT",$JOB,PATNAM,BIEN))
if 'BIEN!(BIEN="")
QUIT
Begin DoDot:2
+12 SET REC=^TMP("REJECT",$JOB,PATNAM,BIEN)
+13 SET INS=$PIECE(REC,U)
SET GRP=$PIECE(REC,U,2)
SET SUBID=$PIECE(REC,U,3)
+14 ;DO NOT reject Buffer entries with an ASSOCIATED IMAGE (#355.33,.19)
+15 IF $$GET1^DIQ(355.33,BIEN_",",.19,"I")=1
QUIT
+16 ;create list of entries that would be rejected
+17 SET REJCNT=REJCNT+1
+18 IF IBRUN=0
IF $GET(IBQUAL)="N"
IF REJCNT>$GET(IBNUM)
QUIT
+19 IF IBRUN=0
SET IBOK=1
WRITE PATNAM,U,BIEN,U,INS,U,$SELECT(GRP="NONE":"",1:GRP),U,$SELECT(SUBID="NONE":"",1:SUBID),!
+20 ;Reject duplicate entries
+21 IF IBRUN=1
SET IBBUFDA=BIEN
Begin DoDot:3
+22 LOCK +^IBA(355.33,IBBUFDA):15
IF '$TEST
QUIT
+23 DO REJECT^IBCNBAR(IBBUFDA,IBRTN)
+24 LOCK -^IBA(355.33,IBBUFDA)
+25 QUIT
End DoDot:3
+26 QUIT
End DoDot:2
End DoDot:1
+27 ;
+28 IF IBRUN=0
IF IBOK=0
WRITE "** NONE **",!
+29 QUIT
+30 ;
TASKIN(IBSB,IBDUZ,IBRET,IBRUN,IBQUAL,IBNUM) ; Task Duplicate Buffer Cleanup
+1 ;INPUT:
+2 ; IBSB - message subject
+3 ; IBDUZ - user DUZ to use - IB,BUFFER CLEANUP
+4 ; IBRET - message return array to calling entity passed in as "VARIABLE"
+5 ; IBRUN - Run buffer cleanup = 1 / Do not run buffer cleanup = 0
+6 ; IBQUAL - "A" - ALL / "N" - Number of patients
+7 ; IBNUM - (IBQUAL=A) = "" / (IBQUAL=N) = # of patients
+8 ;
+9 NEW IBA,IBB,MSG,RMSG,ZTDTH,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE
+10 ;
+11 SET IBSB=$GET(IBSB)
+12 SET IBDUZ=$GET(IBDUZ)
if IBDUZ=""
SET IBDUZ=$GET(DUZ)
+13 SET IBRET=$GET(IBRET)
IF IBRET=""
QUIT "1^Need return array"
+14 KILL @IBRET
+15 ; IBRET - message return array to calling entity passed in as "VARIABLE"
SET IBRET="IBMSG"
+16 ;
+17 ; ZTDTH = TODAY AT 10:00 PM
+18 SET ZTDTH=$PIECE($$NOW^XLFDT(),".")
SET ZTDTH=$$FMADD^XLFDT(ZTDTH,,22)
+19 SET ZTIO=""
+20 SET ZTQUEUED=1
+21 SET ZTRTN="BUFREJ^IBJPI3"
+22 SET ZTSAVE("IBDUZ")=""
SET ZTSAVE("IBSB")=""
SET ZTSAVE("IBXTMPNM")=""
+23 SET ZTSAVE("IBRUN")=""
SET ZTSAVE("IBQUAL")=""
SET ZTSAVE("IBNUM")=""
+24 ;
+25 SET @IBRET@(0)=1
+26 SET RMSG(0)=""
SET MSG=$$TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO,.RMSG)
+27 SET @IBRET@(1)=MSG
+28 ;< multi line message to avoid wrap
IF RMSG(0)
Begin DoDot:1
+29 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
+30 ;
TSKCLNQ ;
+1 QUIT ""
+2 ;
TASK(ZTDTH,ZTDESC,ZTRTN,ZTIO,RMSG) ;bypass for queued task
+1 NEW %DT,GTASKS,IBAA,IDT,MSG,NOW,TIME,TSK,XDT,Y,ZTSK
+2 ;
+3 ; XDT is TODAY+1@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 ;
+10 ;Schedule the task
+11 SET TSK=$$SCHED(IDT,ZTIO)
+12 ;
+13 ;Check for scheduling problem
+14 IF $GET(TSK)=""
SET MSG=" Task Could Not Be Scheduled"
QUIT MSG
+15 ;
+16 ;Send successful schedule message
+17 ;TIME
SET MSG="Task: "_$PIECE($GET(TSK),U)_" Duplicate Buffer Cleanup is scheduled for "_XDT
+18 QUIT MSG
+19 ;
SCHED(ZTDTH,ZTIO) ;
+1 NEW ZTSK,IBDT
+2 DO ^%ZTLOAD
+3 IF $GET(ZTSK)=""
QUIT ""
+4 SET IBDT=$$HTFM^XLFDT(ZTSK("D"))
+5 ; 90000 represents 10pm in $harlog seconds
+6 QUIT ZTSK_U_IBDT_U_$SELECT($PIECE(ZTSK("D"),",",2)=90000:1,1:0)
+7 ;
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
