IBY602PO ;EDE/DM - Post-Installation for IB*2.8*602 ; 23-MAR-2018
;;2.0;INTEGRATED BILLING;**602**;09-AUG-2018;Build 22
;;Per VA Directive 6402, this routine should not be modified.
;
POST ; POST ROUTINE(S)
N IBXPD,XPDIDTOT
S XPDIDTOT=1
;
; Task FIXTQ
D TSKFIXTQ(1)
;
; Done...
D MES^XPDUTL("")
D MES^XPDUTL("POST-Install Completed.")
Q
;
TSKFIXTQ(IBXPD) ; task the FIXTQ routine
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Tasking Examine/Clean IIV Response & IIV Transmission Queue ... ")
N MSG,ZTDESC,ZTRTN,ZTQUEUED
S ZTQUEUED=1
S ZTDESC="IBCN EXAMINE #365 & #365.1 FILES"
S ZTRTN="FIXTQ^IBY602PO"
S MSG=$$TASK("T@2000",ZTDESC,ZTRTN)
D MES^XPDUTL(MSG)
Q
;
TASK(X,ZTDESC,ZTRTN) ;bypass for queued task
N Y,IDT,XDT,TSK,MSG,ZTIO,ZTSK,%DT
S %DT="FR"
D ^%DT
S IDT=Y D DD^%DT S XDT=Y
;
;Check if task already scheduled for date/time
S TSK=$$GETTASK(IDT)
I TSK D Q MSG
. S Y=$P(TSK,U,2) D DD^%DT
. S MSG=" Task (#"_+TSK_") already scheduled to run on "_Y
;
;Schedule the task
S TSK=$$SCHED(IDT)
;
;Check for scheduling problem
I '$G(TSK) S MSG=" Task Could Not Be Scheduled" Q MSG
;
;Send successful schedule message
S MSG=" Examine/Clean IIV Transmission Queue Scheduled for "_XDT
Q MSG
;
GETTASK(IDT) ;
N TASK,TASKNO,TDT,XUSUCI,Y,ZTSK0
;
;Retrieve UCI
X ^%ZOSF("UCI") S XUSUCI=Y
;
S (TASK,TDT)=0,TASKNO=""
F S TASK=$O(^%ZTSK(TASK)) Q:'TASK D Q:TASKNO
.I $G(^%ZTSK(TASK,.03))[ZTDESC D
..S ZTSK0=$G(^%ZTSK(TASK,0))
..;
..;Exclude tasks scheduled by TaskMan
..Q:ZTSK0["ZTSK^XQ1"
..;
..;Exclude tasks in other ucis
..Q:(($P(ZTSK0,U,11)_","_$P(ZTSK0,U,12))'=XUSUCI)
..;
..;Check for correct date and time
..S TDT=$$HTFM^XLFDT($P(ZTSK0,"^",6))
..;I TDT=IDT S TASKNO=TASK
Q TASKNO_U_TDT
;
SCHED(ZTDTH) ;
N XUSUCI,ZTIO,ZTSK
;Retrieve UCI
X ^%ZOSF("UCI") S XUSUCI=Y
S ZTIO=""
D ^%ZTLOAD
Q ZTSK
;
FIXTQ(IBXPD) ; clean/report abnormal IIV TRANSMISSION QUEUE (#365.1) records
N DA,DIK,HLIEN,DNP,TQIEN,ENDDT,WKDT,WKZZ
N STATLIST,STAGE,TCNT,ACNT,MCNT,DONE
N BAD,TQS,TQD,TQQ,MSG,IBXMY
;
S STATLIST=","_$$FIND1^DIC(365.14,,"B","Response Received")
S STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Communication Failure")
S STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Cancelled")_","
S (TQIEN,TCNT,STAGE,ACNT,MCNT,DONE)=0
S MSG=""
S ENDDT=$$FMADD^XLFDT(DT,-182) ; about 6 months
; STAGE=0, delete abnormal < T-182
; STAGE=1, report abnormal from T-182 through T-32
;
D FIXRESP
;
F S TQIEN=$O(^IBCN(365.1,TQIEN)) Q:'TQIEN!DONE!$G(ZTSTOP) D
. S TCNT=TCNT+1
. I $D(ZTQUEUED),TCNT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
. S TQD=$$GET1^DIQ(365.1,TQIEN_",",.06,"I") ; DATE/TIME CREATED
. S WKDT=+$P(TQD,".",1)
. I WKDT>ENDDT,STAGE S DONE=1 Q
. I WKDT>ENDDT S STAGE=1,ENDDT=$$FMADD^XLFDT(DT,-32)
. I WKDT>ENDDT S DONE=1 Q
. ; check for abnormal
. S BAD=0
. S TQS=$$GET1^DIQ(365.1,TQIEN_",",.04,"I") ; TRANSMISSION STATUS
. S TQQ=$$GET1^DIQ(365.1,TQIEN_",",.11,"I") ; QUERY FLAG
. ; If the QUERY FLAG IS "I" and not an EICD Transaction entry will purge/report.
. S:TQQ="I"&'$D(^IBCN(365.18,"B",TQIEN)) BAD=1
. ; If the QUERY FLAG is null OR the DATE/TIME CREATED is null or
. ; TRANSMISSION STATUS not in STATLIST entry will purge/report
. S:(TQQ="")!('TQD)!('$F(STATLIST,","_TQS_",")) BAD=1
. Q:'BAD
. I STAGE=0 D
.. ; loop through the HL7 messages multiple and kill any response
.. ; records that are found for this transmission queue entry.
.. ; Preserve the TQ and any response that has DO NOT PURGE set to 1 (YES)
.. S DNP=0,HLIEN=0,DIK="^IBCN(365,"
.. F S HLIEN=$O(^IBCN(365.1,TQIEN,2,HLIEN)) Q:'HLIEN D
... S DA=$P($G(^IBCN(365.1,TQIEN,2,HLIEN,0)),U,3) Q:'DA
... I +$$GET1^DIQ(365,DA_",",.11,"I") S DNP=1 Q
... D ^DIK
... Q
.. ; now we can kill the TQ entry itself
.. ; as long as there was no DO NOT PURGE responses
.. I 'DNP S DA=TQIEN,DIK="^IBCN(365.1," D ^DIK
.. Q
. Q:'STAGE ; not reporting abnormal yet
. S ACNT=ACNT+1 ; abnormal count
. Q:MCNT>9 ; msg count, only want 10
. S MCNT=MCNT+1
. ;example of a detail line on the email
. ;FEB 22, 2017@10:44:08 T#:xxxxxxxxxx *xxxxxxxxxxxxxxxxxxxxx *NO QFLAG
. I 'TQD S $E(MSG(MCNT+2),1)="*NO DATE"
. I TQD S $E(MSG(MCNT+2),1)=$$GET1^DIQ(365.1,TQIEN_",",.06,"E") ;DATE/TIME CREATED
. S $E(MSG(MCNT+2),23)="T#:"_TQIEN
. I '$F(STATLIST,","_TQS_",") S $E(MSG(MCNT+2),40)=" *"_$$GET1^DIQ(365.1,TQIEN_",",.04,"E")
. S WKZZ=""
. I TQQ="" S WKZZ=" *NO QUERY FLAG"
. I TQQ="I" S WKZZ=" *QUERY FLAG: 'I'"
. S $E(MSG(MCNT+2),60)=WKZZ
; send mailman msg
S WKDT=$$SITE^VASITE()
S MSG(1)="Patch IB*2.0*602 Post Install Issue Summary for station "_$P(WKDT,U,3)_":"_$P(WKDT,U,2)
S MSG(2)="-------------------------------------------------------------------------------"
I 'ACNT S MSG(3)=" NO ISSUES FOUND"
I ACNT D
. S MSG(MCNT+3)=""
. S MSG(MCNT+4)="TOTAL ISSUES DETECTED: "_ACNT
S IBXMY("vhaeinsurancerr@domain.ext")=""
D MSG^IBCNEUT5(,"Patch IB*2.0*602 Post Install Issue Summary ("_$P(WKDT,U,3)_")","MSG(",,.IBXMY)
; Tell TaskManager to delete the task's record
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
FIXRESP ;Populate Response entries with null date/time created.
N DIE,DR,DTM,RDTM,RIEN,RPDTM
S RIEN=0,RPDTM=$$FMADD^XLFDT(DT,-182)
F S RIEN=$O(^IBCN(365,RIEN)) Q:'RIEN D
. S TCNT=TCNT+1
. I $D(ZTQUEUED),TCNT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
. ;
. S DTM=$$GET1^DIQ(365,RIEN_",",.08,"I") I DTM Q
. S RDTM=$$GET1^DIQ(365,RIEN_",",.07,"I")
. I RDTM>RPDTM D
.. S ACNT=ACNT+1
.. I MCNT<6 D
... S MCNT=MCNT+1
... S $E(MSG(MCNT+2),1)="*NO DATE/TIME CR"
... S $E(MSG(MCNT+2),23)="R#:"_$$GET1^DIQ(365,RIEN_",",.01) ;MESSAGE CONTROL ID
... S $E(MSG(MCNT+2),40)=" *"_$$GET1^DIQ(365,RIEN_",",.06) ;TRANSMISSION STATUS
... S $E(MSG(MCNT+2),60)=" *"_$$GET1^DIQ(365,RIEN_",",.1) ;RESPONSE TYPE
. S DTM=$S(RDTM:RDTM,1:"NOW")
. S DIE=365,DA=RIEN,DR=".08///"_DTM
. D ^DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY602PO 6086 printed Sep 23, 2025@20:11:09 Page 2
IBY602PO ;EDE/DM - Post-Installation for IB*2.8*602 ; 23-MAR-2018
+1 ;;2.0;INTEGRATED BILLING;**602**;09-AUG-2018;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
POST ; POST ROUTINE(S)
+1 NEW IBXPD,XPDIDTOT
+2 SET XPDIDTOT=1
+3 ;
+4 ; Task FIXTQ
+5 DO TSKFIXTQ(1)
+6 ;
+7 ; Done...
+8 DO MES^XPDUTL("")
+9 DO MES^XPDUTL("POST-Install Completed.")
+10 QUIT
+11 ;
TSKFIXTQ(IBXPD) ; task the FIXTQ routine
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Tasking Examine/Clean IIV Response & IIV Transmission Queue ... ")
+4 NEW MSG,ZTDESC,ZTRTN,ZTQUEUED
+5 SET ZTQUEUED=1
+6 SET ZTDESC="IBCN EXAMINE #365 & #365.1 FILES"
+7 SET ZTRTN="FIXTQ^IBY602PO"
+8 SET MSG=$$TASK("T@2000",ZTDESC,ZTRTN)
+9 DO MES^XPDUTL(MSG)
+10 QUIT
+11 ;
TASK(X,ZTDESC,ZTRTN) ;bypass for queued task
+1 NEW Y,IDT,XDT,TSK,MSG,ZTIO,ZTSK,%DT
+2 SET %DT="FR"
+3 DO ^%DT
+4 SET IDT=Y
DO DD^%DT
SET XDT=Y
+5 ;
+6 ;Check if task already scheduled for date/time
+7 SET TSK=$$GETTASK(IDT)
+8 IF TSK
Begin DoDot:1
+9 SET Y=$PIECE(TSK,U,2)
DO DD^%DT
+10 SET MSG=" Task (#"_+TSK_") already scheduled to run on "_Y
End DoDot:1
QUIT MSG
+11 ;
+12 ;Schedule the task
+13 SET TSK=$$SCHED(IDT)
+14 ;
+15 ;Check for scheduling problem
+16 IF '$GET(TSK)
SET MSG=" Task Could Not Be Scheduled"
QUIT MSG
+17 ;
+18 ;Send successful schedule message
+19 SET MSG=" Examine/Clean IIV Transmission Queue Scheduled for "_XDT
+20 QUIT MSG
+21 ;
GETTASK(IDT) ;
+1 NEW TASK,TASKNO,TDT,XUSUCI,Y,ZTSK0
+2 ;
+3 ;Retrieve UCI
+4 XECUTE ^%ZOSF("UCI")
SET XUSUCI=Y
+5 ;
+6 SET (TASK,TDT)=0
SET TASKNO=""
+7 FOR
SET TASK=$ORDER(^%ZTSK(TASK))
if 'TASK
QUIT
Begin DoDot:1
+8 IF $GET(^%ZTSK(TASK,.03))[ZTDESC
Begin DoDot:2
+9 SET ZTSK0=$GET(^%ZTSK(TASK,0))
+10 ;
+11 ;Exclude tasks scheduled by TaskMan
+12 if ZTSK0["ZTSK^XQ1"
QUIT
+13 ;
+14 ;Exclude tasks in other ucis
+15 if (($PIECE(ZTSK0,U,11)_","_$PIECE(ZTSK0,U,12))'=XUSUCI)
QUIT
+16 ;
+17 ;Check for correct date and time
+18 SET TDT=$$HTFM^XLFDT($PIECE(ZTSK0,"^",6))
+19 ;I TDT=IDT S TASKNO=TASK
End DoDot:2
End DoDot:1
if TASKNO
QUIT
+20 QUIT TASKNO_U_TDT
+21 ;
SCHED(ZTDTH) ;
+1 NEW XUSUCI,ZTIO,ZTSK
+2 ;Retrieve UCI
+3 XECUTE ^%ZOSF("UCI")
SET XUSUCI=Y
+4 SET ZTIO=""
+5 DO ^%ZTLOAD
+6 QUIT ZTSK
+7 ;
FIXTQ(IBXPD) ; clean/report abnormal IIV TRANSMISSION QUEUE (#365.1) records
+1 NEW DA,DIK,HLIEN,DNP,TQIEN,ENDDT,WKDT,WKZZ
+2 NEW STATLIST,STAGE,TCNT,ACNT,MCNT,DONE
+3 NEW BAD,TQS,TQD,TQQ,MSG,IBXMY
+4 ;
+5 SET STATLIST=","_$$FIND1^DIC(365.14,,"B","Response Received")
+6 SET STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Communication Failure")
+7 SET STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Cancelled")_","
+8 SET (TQIEN,TCNT,STAGE,ACNT,MCNT,DONE)=0
+9 SET MSG=""
+10 ; about 6 months
SET ENDDT=$$FMADD^XLFDT(DT,-182)
+11 ; STAGE=0, delete abnormal < T-182
+12 ; STAGE=1, report abnormal from T-182 through T-32
+13 ;
+14 DO FIXRESP
+15 ;
+16 FOR
SET TQIEN=$ORDER(^IBCN(365.1,TQIEN))
if 'TQIEN!DONE!$GET(ZTSTOP)
QUIT
Begin DoDot:1
+17 SET TCNT=TCNT+1
+18 IF $DATA(ZTQUEUED)
IF TCNT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+19 ; DATE/TIME CREATED
SET TQD=$$GET1^DIQ(365.1,TQIEN_",",.06,"I")
+20 SET WKDT=+$PIECE(TQD,".",1)
+21 IF WKDT>ENDDT
IF STAGE
SET DONE=1
QUIT
+22 IF WKDT>ENDDT
SET STAGE=1
SET ENDDT=$$FMADD^XLFDT(DT,-32)
+23 IF WKDT>ENDDT
SET DONE=1
QUIT
+24 ; check for abnormal
+25 SET BAD=0
+26 ; TRANSMISSION STATUS
SET TQS=$$GET1^DIQ(365.1,TQIEN_",",.04,"I")
+27 ; QUERY FLAG
SET TQQ=$$GET1^DIQ(365.1,TQIEN_",",.11,"I")
+28 ; If the QUERY FLAG IS "I" and not an EICD Transaction entry will purge/report.
+29 if TQQ="I"&'$DATA(^IBCN(365.18,"B",TQIEN))
SET BAD=1
+30 ; If the QUERY FLAG is null OR the DATE/TIME CREATED is null or
+31 ; TRANSMISSION STATUS not in STATLIST entry will purge/report
+32 if (TQQ="")!('TQD)!('$FIND(STATLIST,","_TQS_","))
SET BAD=1
+33 if 'BAD
QUIT
+34 IF STAGE=0
Begin DoDot:2
+35 ; loop through the HL7 messages multiple and kill any response
+36 ; records that are found for this transmission queue entry.
+37 ; Preserve the TQ and any response that has DO NOT PURGE set to 1 (YES)
+38 SET DNP=0
SET HLIEN=0
SET DIK="^IBCN(365,"
+39 FOR
SET HLIEN=$ORDER(^IBCN(365.1,TQIEN,2,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:3
+40 SET DA=$PIECE($GET(^IBCN(365.1,TQIEN,2,HLIEN,0)),U,3)
if 'DA
QUIT
+41 IF +$$GET1^DIQ(365,DA_",",.11,"I")
SET DNP=1
QUIT
+42 DO ^DIK
+43 QUIT
End DoDot:3
+44 ; now we can kill the TQ entry itself
+45 ; as long as there was no DO NOT PURGE responses
+46 IF 'DNP
SET DA=TQIEN
SET DIK="^IBCN(365.1,"
DO ^DIK
+47 QUIT
End DoDot:2
+48 ; not reporting abnormal yet
if 'STAGE
QUIT
+49 ; abnormal count
SET ACNT=ACNT+1
+50 ; msg count, only want 10
if MCNT>9
QUIT
+51 SET MCNT=MCNT+1
+52 ;example of a detail line on the email
+53 ;FEB 22, 2017@10:44:08 T#:xxxxxxxxxx *xxxxxxxxxxxxxxxxxxxxx *NO QFLAG
+54 IF 'TQD
SET $EXTRACT(MSG(MCNT+2),1)="*NO DATE"
+55 ;DATE/TIME CREATED
IF TQD
SET $EXTRACT(MSG(MCNT+2),1)=$$GET1^DIQ(365.1,TQIEN_",",.06,"E")
+56 SET $EXTRACT(MSG(MCNT+2),23)="T#:"_TQIEN
+57 IF '$FIND(STATLIST,","_TQS_",")
SET $EXTRACT(MSG(MCNT+2),40)=" *"_$$GET1^DIQ(365.1,TQIEN_",",.04,"E")
+58 SET WKZZ=""
+59 IF TQQ=""
SET WKZZ=" *NO QUERY FLAG"
+60 IF TQQ="I"
SET WKZZ=" *QUERY FLAG: 'I'"
+61 SET $EXTRACT(MSG(MCNT+2),60)=WKZZ
End DoDot:1
+62 ; send mailman msg
+63 SET WKDT=$$SITE^VASITE()
+64 SET MSG(1)="Patch IB*2.0*602 Post Install Issue Summary for station "_$PIECE(WKDT,U,3)_":"_$PIECE(WKDT,U,2)
+65 SET MSG(2)="-------------------------------------------------------------------------------"
+66 IF 'ACNT
SET MSG(3)=" NO ISSUES FOUND"
+67 IF ACNT
Begin DoDot:1
+68 SET MSG(MCNT+3)=""
+69 SET MSG(MCNT+4)="TOTAL ISSUES DETECTED: "_ACNT
End DoDot:1
+70 SET IBXMY("vhaeinsurancerr@domain.ext")=""
+71 DO MSG^IBCNEUT5(,"Patch IB*2.0*602 Post Install Issue Summary ("_$PIECE(WKDT,U,3)_")","MSG(",,.IBXMY)
+72 ; Tell TaskManager to delete the task's record
+73 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+74 QUIT
+75 ;
FIXRESP ;Populate Response entries with null date/time created.
+1 NEW DIE,DR,DTM,RDTM,RIEN,RPDTM
+2 SET RIEN=0
SET RPDTM=$$FMADD^XLFDT(DT,-182)
+3 FOR
SET RIEN=$ORDER(^IBCN(365,RIEN))
if 'RIEN
QUIT
Begin DoDot:1
+4 SET TCNT=TCNT+1
+5 IF $DATA(ZTQUEUED)
IF TCNT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+6 ;
+7 SET DTM=$$GET1^DIQ(365,RIEN_",",.08,"I")
IF DTM
QUIT
+8 SET RDTM=$$GET1^DIQ(365,RIEN_",",.07,"I")
+9 IF RDTM>RPDTM
Begin DoDot:2
+10 SET ACNT=ACNT+1
+11 IF MCNT<6
Begin DoDot:3
+12 SET MCNT=MCNT+1
+13 SET $EXTRACT(MSG(MCNT+2),1)="*NO DATE/TIME CR"
+14 ;MESSAGE CONTROL ID
SET $EXTRACT(MSG(MCNT+2),23)="R#:"_$$GET1^DIQ(365,RIEN_",",.01)
+15 ;TRANSMISSION STATUS
SET $EXTRACT(MSG(MCNT+2),40)=" *"_$$GET1^DIQ(365,RIEN_",",.06)
+16 ;RESPONSE TYPE
SET $EXTRACT(MSG(MCNT+2),60)=" *"_$$GET1^DIQ(365,RIEN_",",.1)
End DoDot:3
End DoDot:2
+17 SET DTM=$SELECT(RDTM:RDTM,1:"NOW")
+18 SET DIE=365
SET DA=RIEN
SET DR=".08///"_DTM
+19 DO ^DIE
End DoDot:1
+20 QUIT
+21 ;
