IBCNUPD ;ALB/TAZ - UPDATE SUBCRIBER INFO FOR SELECTED PATIENTS ; 07 Mar 2013 14:44 PM
;;2.0;INTEGRATED BILLING;**497,506**;21-MAR-94;Build 74
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Call at tags only
Q
;
;
EN ; Entry Point for TaskMan. The routine should be called at label TASK since it will take awhile to complete.
;
N DFN,FILE,INS,IBREL,IBVAL,IENS,FIELD,DATA,DA,DR,DIE,EXPDT,X,Y
K ^TMP($J,"IBCNUPD")
S DFN=0
S FILE=2.312
F S DFN=$O(^DPT(DFN)) Q:'DFN D
. K ^UTILITY("VAPA",$J),^UTILITY("VADM",$J)
. S INS=0
. F S INS=$O(^DPT(DFN,.312,INS)) Q:'INS D
.. I '$D(^DPT(DFN,.312,INS,0)) Q ;Don't process bad nodes.
.. S IENS=INS_","_DFN_","
.. S EXPDT=+$$GET1^DIQ(FILE,IENS,3,"I")
.. I EXPDT,EXPDT<DT Q ;insurance expiration date exists and it's a past date which means inactive policy
.. I $$GET1^DIQ(FILE,IENS,4.03)'="SELF" Q
.. S IBREL=$$GET1^DIQ(FILE,IENS,4.03,"I")
.. F FIELD=7.01,3.01,3.02,3.05,3.06,3.07,3.08,3.09,3.1,3.11,3.12 D ; IB*2.0*497 (vd)
... S DATA=$$GET1^DIQ(FILE,IENS,FIELD) I DATA'="" Q
... S IBVAL=$$PIDEF^IBCNSP1(IBREL,FIELD,DFN,0) I IBVAL="" Q
... S DIE="^DPT("_DFN_",.312,"
... S DA(1)=DFN,DA=INS
... S DR=FIELD_"///^S X=IBVAL"
... D ^DIE
;Send completion message
D MAIL
;
ENQ Q
;
OPT ; Enter from the option
W !,$$TASK()
OPTQ ;
Q
;
TASK(IBQ) ;Set up task to run the option
N X,Y,IDT,XDT,TSK,MSG,DTOUT,DUOUT
;
;If option is queued, set up queue date/time and bypass prompt
I $G(IBQ) D G TASK1
. S X="T+1@2100"
. S %DT="FR"
. D ^%DT
;
W !,"*************************** IMPORTANT!! ********************************"
W !,"This option will scan through the entire Patient File for patients with "
W !,"insurance where the relationship to insured is self. Certain fields in "
W !,"Insurance Type sub-file will be updated to match the patient data if it "
W !,"does not already exist. This will take awhile and must be queued to run"
W !,"in the background when there are few users on the system. The default is"
W !,"Tomorrow at 9:00 p.m."
W !
;
;Set Date and Time
K %DT
S %DT="AEFR"
S %DT("A")="Enter date/time to queue the option: "
S %DT("B")="T+1@2100"
S %DT(0)="NOW" ; prevent past date/time being entered
D ^%DT
I $D(DTOUT)!$D(DUOUT)!(Y<0) S MSG="Task Aborted. Option NOT scheduled." G TASKQ
;
TASK1 ;bypass for queued task
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 'TSK S MSG=" Task Could Not Be Scheduled" G TASKQ
;
;Send successful schedule message
S MSG=" Update Subscriber Information 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))["IBCN SUBSCRIBER UPDATE" 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
;
;Schedule Task
;
SCHED(ZTDTH) ;
N ZTRTN,ZTDESC,ZTIO,ZTSK
S ZTRTN="EN^IBCNUPD"
S ZTDESC="IBCN SUBSCRIBER UPDATE"
S ZTIO=""
D ^%ZTLOAD
Q ZTSK
;
MAIL ;Send completion message
NEW XMDUZ,XMSUBJ,XMBODY,MSG,XMTO,DA,DIE,DR
S XMDUZ=DUZ,XMSUBJ="Subscriber Update Has Completed",XMBODY="MSG"
S MSG(1)="The Subscriber Update Option has completed at "
S MSG(2)=" "
S MSG(3)=" "_$$SITE^VASITE
;
; recipients of message
S XMTO(DUZ)=""
S XMTO("G.PATCHES")=""
S XMTO("G.IB EDI")=""
S XMTO("G.IB EDI SUPERVISOR")=""
;
D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNUPD 4064 printed Nov 22, 2024@17:28:15 Page 2
IBCNUPD ;ALB/TAZ - UPDATE SUBCRIBER INFO FOR SELECTED PATIENTS ; 07 Mar 2013 14:44 PM
+1 ;;2.0;INTEGRATED BILLING;**497,506**;21-MAR-94;Build 74
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Call at tags only
+5 QUIT
+6 ;
+7 ;
EN ; Entry Point for TaskMan. The routine should be called at label TASK since it will take awhile to complete.
+1 ;
+2 NEW DFN,FILE,INS,IBREL,IBVAL,IENS,FIELD,DATA,DA,DR,DIE,EXPDT,X,Y
+3 KILL ^TMP($JOB,"IBCNUPD")
+4 SET DFN=0
+5 SET FILE=2.312
+6 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+7 KILL ^UTILITY("VAPA",$JOB),^UTILITY("VADM",$JOB)
+8 SET INS=0
+9 FOR
SET INS=$ORDER(^DPT(DFN,.312,INS))
if 'INS
QUIT
Begin DoDot:2
+10 ;Don't process bad nodes.
IF '$DATA(^DPT(DFN,.312,INS,0))
QUIT
+11 SET IENS=INS_","_DFN_","
+12 SET EXPDT=+$$GET1^DIQ(FILE,IENS,3,"I")
+13 ;insurance expiration date exists and it's a past date which means inactive policy
IF EXPDT
IF EXPDT<DT
QUIT
+14 IF $$GET1^DIQ(FILE,IENS,4.03)'="SELF"
QUIT
+15 SET IBREL=$$GET1^DIQ(FILE,IENS,4.03,"I")
+16 ; IB*2.0*497 (vd)
FOR FIELD=7.01,3.01,3.02,3.05,3.06,3.07,3.08,3.09,3.1,3.11,3.12
Begin DoDot:3
+17 SET DATA=$$GET1^DIQ(FILE,IENS,FIELD)
IF DATA'=""
QUIT
+18 SET IBVAL=$$PIDEF^IBCNSP1(IBREL,FIELD,DFN,0)
IF IBVAL=""
QUIT
+19 SET DIE="^DPT("_DFN_",.312,"
+20 SET DA(1)=DFN
SET DA=INS
+21 SET DR=FIELD_"///^S X=IBVAL"
+22 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;Send completion message
+24 DO MAIL
+25 ;
ENQ QUIT
+1 ;
OPT ; Enter from the option
+1 WRITE !,$$TASK()
OPTQ ;
+1 QUIT
+2 ;
TASK(IBQ) ;Set up task to run the option
+1 NEW X,Y,IDT,XDT,TSK,MSG,DTOUT,DUOUT
+2 ;
+3 ;If option is queued, set up queue date/time and bypass prompt
+4 IF $GET(IBQ)
Begin DoDot:1
+5 SET X="T+1@2100"
+6 SET %DT="FR"
+7 DO ^%DT
End DoDot:1
GOTO TASK1
+8 ;
+9 WRITE !,"*************************** IMPORTANT!! ********************************"
+10 WRITE !,"This option will scan through the entire Patient File for patients with "
+11 WRITE !,"insurance where the relationship to insured is self. Certain fields in "
+12 WRITE !,"Insurance Type sub-file will be updated to match the patient data if it "
+13 WRITE !,"does not already exist. This will take awhile and must be queued to run"
+14 WRITE !,"in the background when there are few users on the system. The default is"
+15 WRITE !,"Tomorrow at 9:00 p.m."
+16 WRITE !
+17 ;
+18 ;Set Date and Time
+19 KILL %DT
+20 SET %DT="AEFR"
+21 SET %DT("A")="Enter date/time to queue the option: "
+22 SET %DT("B")="T+1@2100"
+23 ; prevent past date/time being entered
SET %DT(0)="NOW"
+24 DO ^%DT
+25 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
SET MSG="Task Aborted. Option NOT scheduled."
GOTO TASKQ
+26 ;
TASK1 ;bypass for queued task
+1 SET IDT=Y
DO DD^%DT
SET XDT=Y
+2 ;
+3 ;Check if task already scheduled for date/time
+4 SET TSK=$$GETTASK(IDT)
+5 IF TSK
Begin DoDot:1
+6 SET Y=$PIECE(TSK,U,2)
DO DD^%DT
+7 SET MSG=" Task (#"_+TSK_") already scheduled to run on "_Y
End DoDot:1
GOTO TASKQ
+8 ;
+9 ;Schedule the task
+10 SET TSK=$$SCHED(IDT)
+11 ;
+12 ;Check for scheduling problem
+13 IF 'TSK
SET MSG=" Task Could Not Be Scheduled"
GOTO TASKQ
+14 ;
+15 ;Send successful schedule message
+16 SET MSG=" Update Subscriber Information Scheduled for "_XDT
+17 ;
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))["IBCN SUBSCRIBER UPDATE"
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 ;
+22 ;Schedule Task
+23 ;
SCHED(ZTDTH) ;
+1 NEW ZTRTN,ZTDESC,ZTIO,ZTSK
+2 SET ZTRTN="EN^IBCNUPD"
+3 SET ZTDESC="IBCN SUBSCRIBER UPDATE"
+4 SET ZTIO=""
+5 DO ^%ZTLOAD
+6 QUIT ZTSK
+7 ;
MAIL ;Send completion message
+1 NEW XMDUZ,XMSUBJ,XMBODY,MSG,XMTO,DA,DIE,DR
+2 SET XMDUZ=DUZ
SET XMSUBJ="Subscriber Update Has Completed"
SET XMBODY="MSG"
+3 SET MSG(1)="The Subscriber Update Option has completed at "
+4 SET MSG(2)=" "
+5 SET MSG(3)=" "_$$SITE^VASITE
+6 ;
+7 ; recipients of message
+8 SET XMTO(DUZ)=""
+9 SET XMTO("G.PATCHES")=""
+10 SET XMTO("G.IB EDI")=""
+11 SET XMTO("G.IB EDI SUPERVISOR")=""
+12 ;
+13 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO)
+14 ;
+15 QUIT
