IBY593PR.m

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 ---IBY593PR   3959     printed  Mar 13, 2025@21:39:53                                                                                                                                                                                                    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