IBY593PR ;EDE/HN - Pre-Installation for IB patch 593 ; 17-APR-2017
;;2.0;INTEGRATED BILLING;**593**;21-MAR-94;Build 31
;;Per VA Directive 6402, this routine should not be modified.
;
; post routine stuff is below
POST ; POST ROUTINE(S)
N IBXPD,IBPRD,XPDIDTOT
S XPDIDTOT=3
;
; Determine if we're in a TEST or a PRODUCTION environment.
S IBPRD=$S($$PROD^XUPROD(1)=1:"P",1:"T")
;
; Reindex Patient File for fields 2.312,3 and 2.312,8
D REINDEX(1)
D PATIENT(2)
D ADDSOI(3)
D DONE
Q
;
DONE ; Displays the 'Done' message and finishes the progress bar
D MES^XPDUTL("")
D MES^XPDUTL("POST-Install Completed.")
Q
;
REINDEX(IBXPD) ; Run new indices. This is needed for entries at site not in file coming across.
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Building new ACHI index in the background ")
N MSG,ZTDESC,ZTRTN,ZTQUEUED
S ZTQUEUED=""
S ZTDESC="IBCN CREATE ACHI INDEX"
S ZTRTN="XREF^IBCNERTC"
S MSG=$$TASK("NOW",ZTDESC,ZTRTN)
D MES^XPDUTL(MSG)
D UPDATE^XPDID(IBXPD)
Q
;
PATIENT(IBXPD) ; Kick off Patient file update of Covered by Health Insurance flag (2.3192)
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Tasking Covered by Health Insurance update ... ")
N MSG,ZTDESC,ZTRTN,ZTQUEUED
S ZTQUEUED=1
S ZTDESC="IBCN COVERED BY HEALTH INSURANCE FLAG UPDATE"
S ZTRTN="UPATF^IBCNERTC"
S MSG=$$TASK("T@2100",ZTDESC,ZTRTN)
D MES^XPDUTL(MSG)
D UPDATE^XPDID(IBXPD)
Q
;
ADDSOI(IBXPD) ; Add new Source of Information.
N IBLN,IBPCE,IBDATA,IBERR,IBIEN,IBSTR
D BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
D MES^XPDUTL("-------------")
D MES^XPDUTL("Adding New Source of Information Codes ... ")
F IBLN=2:1 S IBSTR=$P($T(EN35512+IBLN),";;",2) Q:IBSTR="" D
. F IBPCE=1:1:3 S IBDATA(IBPCE/100)=$P(IBSTR,U,IBPCE)
. I $D(^IBE(355.12,"C",IBDATA(.02))) D Q
.. D MES^XPDUTL(" "_IBDATA(.02)_" ALEADY EXISTS IN THE SOURCE OF INFORMATION TABLE (#355.12)") Q
. S IBIEN=$$ADD^IBDFDBS(355.12,,.IBDATA,.IBERR)
. I IBERR D Q
.. D BMES^XPDUTL("*** ERROR ADDING "_IBDATA(.02)_" CODE TO THE SOURCE OF INFORMATION TABLE (#355.12) ***")
. D BMES^XPDUTL(" "_$$GET1^DIQ(355.12,IBIEN_",",.02)_" CODE ADDED TO THE SOURCE OF INFORMATION TABLE (#355.12)")
D MES^XPDUTL("STEP "_IBXPD_" of "_XPDIDTOT_" COMPLETE")
D UPDATE^XPDID(IBXPD)
Q
;
EN35512 ; Add Source of Information Codes
;
;;13^INSURANCE IMPORT^INSPT
;;14^PURCHASED CARE CHOICE^PCC
;;15^PURCHASED CARE FEE-BASIS^PCFB
;;16^PURCHASED CARE OTHER^PCOTR
;;17^INSURANCE INTAKE^INSIN
;;18^INSURANCE VERIFICATION^INSVR
;;19^VETERAN APPT REQUEST^VAR
;
Q
;
TASK(X,ZTDESC,ZTRTN) ;bypass for queued task
N Y,IDT,XDT,TSK,MSG,ZTIO,ZTSK
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 G TASKQ
. 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" G TASKQ
;
;Send successful schedule message
S MSG=" Update Covered by Health Insurance Flag Scheduled for "_XDT
;
TASKQ ;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY593PR 3959 printed Sep 23, 2025@20:11:06 Page 2
IBY593PR ;EDE/HN - Pre-Installation for IB patch 593 ; 17-APR-2017
+1 ;;2.0;INTEGRATED BILLING;**593**;21-MAR-94;Build 31
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; post routine stuff is below
POST ; POST ROUTINE(S)
+1 NEW IBXPD,IBPRD,XPDIDTOT
+2 SET XPDIDTOT=3
+3 ;
+4 ; Determine if we're in a TEST or a PRODUCTION environment.
+5 SET IBPRD=$SELECT($$PROD^XUPROD(1)=1:"P",1:"T")
+6 ;
+7 ; Reindex Patient File for fields 2.312,3 and 2.312,8
+8 DO REINDEX(1)
+9 DO PATIENT(2)
+10 DO ADDSOI(3)
+11 DO DONE
+12 QUIT
+13 ;
DONE ; Displays the 'Done' message and finishes the progress bar
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL("POST-Install Completed.")
+3 QUIT
+4 ;
REINDEX(IBXPD) ; Run new indices. This is needed for entries at site not in file coming across.
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Building new ACHI index in the background ")
+4 NEW MSG,ZTDESC,ZTRTN,ZTQUEUED
+5 SET ZTQUEUED=""
+6 SET ZTDESC="IBCN CREATE ACHI INDEX"
+7 SET ZTRTN="XREF^IBCNERTC"
+8 SET MSG=$$TASK("NOW",ZTDESC,ZTRTN)
+9 DO MES^XPDUTL(MSG)
+10 DO UPDATE^XPDID(IBXPD)
+11 QUIT
+12 ;
PATIENT(IBXPD) ; Kick off Patient file update of Covered by Health Insurance flag (2.3192)
+1 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+2 DO MES^XPDUTL("-------------")
+3 DO MES^XPDUTL("Tasking Covered by Health Insurance update ... ")
+4 NEW MSG,ZTDESC,ZTRTN,ZTQUEUED
+5 SET ZTQUEUED=1
+6 SET ZTDESC="IBCN COVERED BY HEALTH INSURANCE FLAG UPDATE"
+7 SET ZTRTN="UPATF^IBCNERTC"
+8 SET MSG=$$TASK("T@2100",ZTDESC,ZTRTN)
+9 DO MES^XPDUTL(MSG)
+10 DO UPDATE^XPDID(IBXPD)
+11 QUIT
+12 ;
ADDSOI(IBXPD) ; Add new Source of Information.
+1 NEW IBLN,IBPCE,IBDATA,IBERR,IBIEN,IBSTR
+2 DO BMES^XPDUTL(" STEP "_IBXPD_" of "_XPDIDTOT)
+3 DO MES^XPDUTL("-------------")
+4 DO MES^XPDUTL("Adding New Source of Information Codes ... ")
+5 FOR IBLN=2:1
SET IBSTR=$PIECE($TEXT(EN35512+IBLN),";;",2)
if IBSTR=""
QUIT
Begin DoDot:1
+6 FOR IBPCE=1:1:3
SET IBDATA(IBPCE/100)=$PIECE(IBSTR,U,IBPCE)
+7 IF $DATA(^IBE(355.12,"C",IBDATA(.02)))
Begin DoDot:2
+8 DO MES^XPDUTL(" "_IBDATA(.02)_" ALEADY EXISTS IN THE SOURCE OF INFORMATION TABLE (#355.12)")
QUIT
End DoDot:2
QUIT
+9 SET IBIEN=$$ADD^IBDFDBS(355.12,,.IBDATA,.IBERR)
+10 IF IBERR
Begin DoDot:2
+11 DO BMES^XPDUTL("*** ERROR ADDING "_IBDATA(.02)_" CODE TO THE SOURCE OF INFORMATION TABLE (#355.12) ***")
End DoDot:2
QUIT
+12 DO BMES^XPDUTL(" "_$$GET1^DIQ(355.12,IBIEN_",",.02)_" CODE ADDED TO THE SOURCE OF INFORMATION TABLE (#355.12)")
End DoDot:1
+13 DO MES^XPDUTL("STEP "_IBXPD_" of "_XPDIDTOT_" COMPLETE")
+14 DO UPDATE^XPDID(IBXPD)
+15 QUIT
+16 ;
EN35512 ; Add Source of Information Codes
+1 ;
+2 ;;13^INSURANCE IMPORT^INSPT
+3 ;;14^PURCHASED CARE CHOICE^PCC
+4 ;;15^PURCHASED CARE FEE-BASIS^PCFB
+5 ;;16^PURCHASED CARE OTHER^PCOTR
+6 ;;17^INSURANCE INTAKE^INSIN
+7 ;;18^INSURANCE VERIFICATION^INSVR
+8 ;;19^VETERAN APPT REQUEST^VAR
+9 ;
+10 QUIT
+11 ;
TASK(X,ZTDESC,ZTRTN) ;bypass for queued task
+1 NEW Y,IDT,XDT,TSK,MSG,ZTIO,ZTSK
+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
GOTO TASKQ
+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"
GOTO TASKQ
+17 ;
+18 ;Send successful schedule message
+19 SET MSG=" Update Covered by Health Insurance Flag Scheduled for "_XDT
+20 ;
TASKQ ;
+1 QUIT MSG
+2 ;
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
