IB20P669.m

IB20P669 ;/Albany - IB*2.0*669 POST INSTALL;03/10/20 2:10pm

 ;;2.0;Integrated Billing;**669**;Mar 20, 1995;Build 20

 ;Per VA Directive 6402, this routine should not be modified.

 Q

 ;

POSTINIT ;Post Install for IB*2.0*669

 D BMES^XPDUTL(" >>  Starting the Post-Initialization routine for IB*2.0*669")

 ; Adding AR CATEGORIES and REVENUE SOURCE CODES

 D QUEUEINT

 ;D INITUCDB  ; Load initial data into Visit tracking DB

 D NEWCREAS

 D CANCLUC

 D BMES^XPDUTL(" >>  End of the Post-Initialization routine for IB*2.0*669")

 Q

 ;

QUEUEINT ; Run the UC Visit DB initialization in the background.

 ;

 N ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSK

 ;

 ; Set up the other TaskManager variables

 S ZTRTN="INITUCDB^IB20P669"

 S ZTDTH=$$NOW^XLFDT

 S ZTDESC="IB*2.0*669 Initialize/Update File 351.82 - Urgent Care Visit Tracking DB"

 S ZTIO=""

 D ^%ZTLOAD    ; Call TaskManager

 D BMES^XPDUTL(" >>  Task "_ZTSK_" started to update the Urgent Care Visit Tracking DB")

 Q

 ;

INITUCDB   ; Loop through the Copay file (350) to find any Urgent Care visits and update the UC database 

 ;

 N LOOP,FDA,FDAIEN,IBUCIEN1,IBUCIEN3,IBUCIEN4,IBQUIT,IBN,IBDATA,IBDFN,IBVST

 N IBERR1,IBERR2,IBERR3,IBERR4,IBERR5,IBERR6

 N IBVSTIEN,IBSTAT,IBBILL,IBBLST,IBREAS,IBLSDTA,IBSITE,IBCREAS

 N X,Y,DIE,DA,DR,DLAYGO,DIC,DINUM

 ;

 ; Check to see if previously installed.  If so, exit with message.

 ;I $O(^IBUC(351.82,0))]"" D  Q

 ;.  D BMES^XPDUTL(" >>  Urgent Care Visit Tracking Database present.  Initialization not tasked.")

 ;

 ;Looping through initially for adds

 S IBUCIEN1=$O(^IBE(350.1,"B","CC URGENT CARE (OPT) NEW",""))

 S IBUCIEN3=$O(^IBE(350.1,"B","CC URGENT CARE (OPT) CANCEL",""))

 S IBUCIEN4=$O(^IBE(350.1,"B","DG FEE SERVICE (OPT) CANCEL",""))

 S IBERR1=$O(^IBE(350.3,"B","UC - ENTERED IN ERROR",""))       ;Skip

 S IBERR2=$O(^IBE(350.3,"B","UC - DUPLICATE VISIT",""))        ;Skip

 S IBERR3=$O(^IBE(350.3,"B","ENTERED IN ERROR",""))            ;Removed    Entered in Error

 S IBERR4=$O(^IBE(350.3,"B","CATASTROPHICALLY DISABLED",""))  ;Free if <3   MISSION Act otherwise Visit Only No Copay

 S IBERR5=$O(^IBE(350.3,"B","COMBAT VETERAN",""))             ;Free if <3   MISSION Act otherwise Visit Only No Copay

 S IBERR6=$O(^IBE(350.3,"B","PURPLE HEART CONFIRMED",""))     ;Free if <3   MISSION Act otherwise Visit Only No Copay

 D SITE^IBAUTL    ;Defines variable IBSITE

 ;

 S IBQUIT=0

 ;

 ;Initialize process tracking array in case initialization stops

 N X,X2,X1,DT

 S DT=$$DT^XLFDT,X1=DT,X2=30 D C^%DTC

 S ^XTMP("IB20P669",0)=X_U_DT_U_"IB*2.0*669 Post install Urgent Care Visit Tracking Initialization"

 ;

 F LOOP=IBUCIEN1,IBUCIEN3,IBUCIEN4 D  Q:IBQUIT

 . ;

 . S IBN=0

 . ;

 . ;See if the initialization was halted. If so, restore loop variables to last entry processed.

 . I $D(^XTMP("IB20P669",1)) S IBLSDTA=$G(^XTMP("IB20P669",1)),LOOP=$P(IBLSDTA,U),IBN=$P(IBLSDTA,U,2)

 . ;

 . F  S IBN=$O(^IB("AE",LOOP,IBN)) Q:'IBN  D

 . . S IBDATA=$G(^IB(IBN,0))     ; Get the data

 . . Q:IBDATA=""

 . . S IBDFN=$P(IBDATA,U,2),IBVST=$P(IBDATA,U,14),IBVSTIEN=0

 . . Q:IBVST<3190606             ;Do not count UC visits prior to the start of the UC program on 6/6/2019

 . . S IBVSTIEN=$$DBCHK(IBDFN,IBVST)

 . . S IBSTAT=4,IBREAS=5,IBBILL="@"   ;init variables

 . . S IBBLST=$P(IBDATA,U,5)         ; Get the bill status

 . . I (LOOP=IBUCIEN4),($P(IBDATA,U,7)'=30) Q    ;Captures all of the DG FEE CANCEL entries from 6/6/2019 to install of IB*2.0*656

 . . S IBCREAS=$P(IBDATA,U,10),IBBLST=$P(IBDATA,U,5)

 . . I (IBBLST'=10),(LOOP=IBUCIEN1),+IBVSTIEN Q    ;don't process if visit already in DB and adding a new paid visit

 . . I IBBLST'=10 D

 . . . S IBSTAT=1,IBREAS=""

 . . . S IBBILL=$P(IBDATA,U,11)   ;Billing Number

 . . . I (IBBLST=8),(IBBILL="") S IBBILL="ON HOLD"

 . . I IBBLST=10 D

 . . . I (IBCREAS=IBERR3) S IBSTAT=3,IBREAS=3    ;Set Visit to Removed/Entered in Error

 . . . ; If Cat Disabled, Purple Heart, or Combat Vet Cancel Reason is used, check for free visits.  If any free visits available, set the visit to free

 . . . I (IBCREAS=IBERR4)!(IBCREAS=IBERR5)!(IBCREAS=IBERR6),$$GETELGP^IBECEA36(IBDFN,IBVST) D

 . . . . S IBNOVST=$$GETVST^IBECEA36(IBDFN,IBVST)

 . . . . I $P(IBNOVST,U,2)<3 S IBSTAT=1,IBREAS=1    ;Potential Free visits

 . . ;Add new entry to the tracking database

 . . I (IBVSTIEN=0) D  Q

 . . . K FDA

 . . . ;Store in array for adding to the file (#351.82)

 . . . S FDA(351.82,"+1,",.01)=IBDFN    ;Patient

 . . . S FDA(351.82,"+1,",.02)=IBSITE   ;Site

 . . . S FDA(351.82,"+1,",.03)=IBVST    ;Visit Date

 . . . S FDA(351.82,"+1,",.04)=IBSTAT   ;Status (2 - Billed or 3- Not Counted)

 . . . S FDA(351.82,"+1,",.05)=IBBILL   ;Status (2 - Billed or 3- Not Counted)

 . . . S FDA(351.82,"+1,",1.01)=1       ;Status (2 - Billed or 3- Not Counted)

 . . . S:$G(IBREAS)'="" FDA(351.82,"+1,",.06)=IBREAS   ;Reason (Not counted)

 . . . S FDA(351.82,"+1,",1.01)=1

 . . . ;Add to the file.

 . . . D UPDATE^DIE(,"FDA","FDAIEN")

 . . . S FDAIEN=FDAIEN(1) K FDAIEN(1)

 . . ;

 . . ;Otherwise Taking a canceled visit and updating the reason, bill no, and status fields

 . . I IBVSTIEN'=0 D

 . . . ;S DLAYGO=351.82,DIC="^IBUC(351.82,",DIC(0)="L"

 . . . ;I '+$G(IBVSTIEN) D FILE^DICN S LIEN=+IBVSTIEN K DIC,DINUM,DLAYGO

 . . . S DR=".04////"_IBSTAT      ; Visit Tracking Status

 . . . S DR=DR_";.05////"_IBBILL  ; Bill Number (should reset to NULL)

 . . . S DR=DR_";.06////"_IBREAS  ; Reason (should be UC-ENTERED IN ERROR or UC-Duplicate Event)

 . . . S DR=DR_";1.01////1"       ; Flag for multi-site transmission

 . . . ;

 . . . S DIE="^IBUC(351.82,",DA=IBVSTIEN

 . . . D ^DIE

 . . . K DR

 . . ;Save the entry just processed

 . . S ^XTMP("IB20P669",1)=LOOP_U_IBN

 . . I $$S^%ZTLOAD() D  Q

 . . . ;

 . . . N ZTRTN,ZTDTH,ZTDESC,ZTIO

 . . . ;

 . . . ;requeue for later

 . . . S ZTRTN="INITUCDB^IB20P669"

 . . . S ZTDTH=$$NOW^XLFDT+.01    ; reschedule for 1 hr after time process stopped

 . . . S ZTDESC="IB*2.0*669 Initialize File 351.82 - Urgent Care Visit Tracking DB"

 . . . S ZTIO=""

 . . . D ^%ZTLOAD    ; Call TaskManager

 . . . S IBQUIT=1

 K DR   ;Clear update array before next use

 Q

 ;

DBCHK(IBDFN,IBVDT) ; Check to see if the visit is already in the DB.

 ; 

 N IBLP,IBQUIT,IBDATA,IBDT

 ; Returns IBQUIT - the IEN of the Visit OR 0

 ;loop through the patient's visits to see if it has already been recorded.

 S IBLP=0,IBQUIT=0

 F  S IBLP=$O(^IBUC(351.82,"B",IBDFN,IBLP)) Q:'IBLP  D  Q:IBQUIT

 .  S IBDATA=$G(^IBUC(351.82,IBLP,0))

 .  S IBDT=$P(IBDATA,U,3)

 .  ; quit if there is a visit already stored on that day.

 .  I IBDT=IBVDT S IBQUIT=IBLP

 Q IBQUIT

 ;

CANCLUC ; Initialize the new CAN CANCEL URGENT CARE field (.04) in the IB CHARGE REMOVE REASON file (#350.3).

 ;  Also inactivate UC-ENTERED IN ERROR AND UC-CHANGE IN ELIGIBILITY

 ;  Also define the type of UC Visit Tracking DB (351.82) update process to follow when using the cancellation

 ;

 N LOOP,LIEN,IBDATA,IBCCUC,IBINACT,IBNM,IBNOVST,IBUCDB

 N X,Y,DIE,DA,DR,DTOUT,DATA

 ;

 D MES^XPDUTL("     -> Update of the new IB CHARGE REMOVE REASON fields started.")

 ; Grab all of the entries to update

 F LOOP=1:1:14 D

 . ;Extract the new ACTION TYPE to be added.

 . S IBDATA=$T(IBDDAT+LOOP)

 . S IBDATA=$P(IBDATA,";;",2)

 . S IBNM=$P(IBDATA,";",1),IBCCUC=$P(IBDATA,";",2),IBUCDB=$P(IBDATA,";",3),IBINACT=$P(IBDATA,";",4)

 . S LIEN=$O(^IBE(350.3,"B",IBNM,""))  ; find CHARGE REMOVE REASON entry 

 . Q:LIEN=""

 . ;

 . ; File the update along with inactivate the ACTION TYPE

 . S DR=".04///"_IBCCUC

 . S DR=DR_";.05///"_IBUCDB

 . S:IBINACT'="" DR=DR_";.06///"_IBINACT

 . S DIE="^IBE(350.3,",DA=LIEN

 . D ^DIE

 . K DR   ;Clear update array before next use

 ;

 S DR=""

 D MES^XPDUTL("     -> Update of IB CHARGE REMOVE REASON completed.")

 Q

 ;

IBDDAT ; Cancellation reasons (350.3) to update

 ;;ENTERED IN ERROR;Y;1

 ;;PATIENT DECEASED;Y;2

 ;;CHANGE IN ELIGIBILITY;Y;3

 ;;RECD INPATIENT CARE;Y;2

 ;;PURPLE HEART CONFIRMED;N;3

 ;;BILLED AT HIGHER TIER RATE;Y;2

 ;;BILLED LTC CHARGE;Y;2

 ;;COMBAT VETERAN;N;3

 ;;CATASTROPHICALLY DISABLED;N;3

 ;;UC - ENTERED IN ERROR;Y;1;Y

 ;;UC - CHANGE IN ELIGIBILITY;Y;3;Y

 ;;UC - DUPLICATE VISIT;Y;4

 ;;UC - SEQUENCE UPDATE;Y;3

 ;;UC - PG6 REVIEWED;Y;3

 ;;END

 ;

NEWCREAS ; New Cancellation Reasons

 N LOOP,LIEN,IBDATA,IBCNNM

 N X,Y,DIE,DA,DR,DTOUT,DATA,IBDATAB

 ; 

 N CANIEN,UPDIEN,SVCIEN,CHGIEN

 ;

 ; Grab all of the entries to update

 D MES^XPDUTL("     -> Adding new Cancellation Reason to the IB CHARGE REMOVE REASON file (350.3).")

 S Y=-1

 F LOOP=1:1 S IBDATA=$T(REASDAT+LOOP) Q:$P(IBDATA,";",3)="END"  D

 . S DR=""

 . ;Extract the new ACTION TYPE to be added.

 . ;Store in array for adding to the file (#350.1).

 . Q:IBDATA=""    ;go to next entry if Category is not to be updated.

 . ;

 . S IBCNNM=$P(IBDATA,";",3)

 . S LIEN=$O(^IBE(350.3,"B",IBCNNM,""))

 . ; File the update along with inactivate the ACTION TYPE

 . S DLAYGO=350.3,DIC="^IBE(350.3,",DIC(0)="L",X=IBCNNM

 . I '+LIEN D FILE^DICN S LIEN=+Y K DIC,DINUM,DLAYGO

 . S DR=".02////"_$P(IBDATA,";",4)   ; ABBREVIATION

 . S DR=DR_";.03////"_$P(IBDATA,";",5)  ; LIMIT

 . ;

 . S DIE="^IBE(350.3,",DA=LIEN

 . D ^DIE

 . ;<re-index new entry here>

 . S DA=LIEN,DIK="^IBE(350.3," D IX^DIK

 . K DR

 Q

 ;

REASDAT ; Fee Service to inactivate

 ;;UC - PG6 REVIEWED;UCPG6;3

 ;;END

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P669   9419     printed  Mar 13, 2025@21:09:11                                                                                                                                                                                                    Page 2

IB20P669  ;/Albany - IB*2.0*669 POST INSTALL;03/10/20 2:10pm

 +1       ;;2.0;Integrated Billing;**669**;Mar 20, 1995;Build 20

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3        QUIT 

 +4       ;

POSTINIT  ;Post Install for IB*2.0*669

 +1        DO BMES^XPDUTL(" >>  Starting the Post-Initialization routine for IB*2.0*669")

 +2       ; Adding AR CATEGORIES and REVENUE SOURCE CODES

 +3        DO QUEUEINT

 +4       ;D INITUCDB  ; Load initial data into Visit tracking DB

 +5        DO NEWCREAS

 +6        DO CANCLUC

 +7        DO BMES^XPDUTL(" >>  End of the Post-Initialization routine for IB*2.0*669")

 +8        QUIT 

 +9       ;

QUEUEINT  ; Run the UC Visit DB initialization in the background.

 +1       ;

 +2        NEW ZTRTN,ZTDTH,ZTDESC,ZTIO,ZTSK

 +3       ;

 +4       ; Set up the other TaskManager variables

 +5        SET ZTRTN="INITUCDB^IB20P669"

 +6        SET ZTDTH=$$NOW^XLFDT

 +7        SET ZTDESC="IB*2.0*669 Initialize/Update File 351.82 - Urgent Care Visit Tracking DB"

 +8        SET ZTIO=""

 +9       ; Call TaskManager

           DO ^%ZTLOAD

 +10       DO BMES^XPDUTL(" >>  Task "_ZTSK_" started to update the Urgent Care Visit Tracking DB")

 +11       QUIT 

 +12      ;

INITUCDB  ; Loop through the Copay file (350) to find any Urgent Care visits and update the UC database 

 +1       ;

 +2        NEW LOOP,FDA,FDAIEN,IBUCIEN1,IBUCIEN3,IBUCIEN4,IBQUIT,IBN,IBDATA,IBDFN,IBVST

 +3        NEW IBERR1,IBERR2,IBERR3,IBERR4,IBERR5,IBERR6

 +4        NEW IBVSTIEN,IBSTAT,IBBILL,IBBLST,IBREAS,IBLSDTA,IBSITE,IBCREAS

 +5        NEW X,Y,DIE,DA,DR,DLAYGO,DIC,DINUM

 +6       ;

 +7       ; Check to see if previously installed.  If so, exit with message.

 +8       ;I $O(^IBUC(351.82,0))]"" D  Q

 +9       ;.  D BMES^XPDUTL(" >>  Urgent Care Visit Tracking Database present.  Initialization not tasked.")

 +10      ;

 +11      ;Looping through initially for adds

 +12       SET IBUCIEN1=$ORDER(^IBE(350.1,"B","CC URGENT CARE (OPT) NEW",""))

 +13       SET IBUCIEN3=$ORDER(^IBE(350.1,"B","CC URGENT CARE (OPT) CANCEL",""))

 +14       SET IBUCIEN4=$ORDER(^IBE(350.1,"B","DG FEE SERVICE (OPT) CANCEL",""))

 +15      ;Skip

           SET IBERR1=$ORDER(^IBE(350.3,"B","UC - ENTERED IN ERROR",""))

 +16      ;Skip

           SET IBERR2=$ORDER(^IBE(350.3,"B","UC - DUPLICATE VISIT",""))

 +17      ;Removed    Entered in Error

           SET IBERR3=$ORDER(^IBE(350.3,"B","ENTERED IN ERROR",""))

 +18      ;Free if <3   MISSION Act otherwise Visit Only No Copay

           SET IBERR4=$ORDER(^IBE(350.3,"B","CATASTROPHICALLY DISABLED",""))

 +19      ;Free if <3   MISSION Act otherwise Visit Only No Copay

           SET IBERR5=$ORDER(^IBE(350.3,"B","COMBAT VETERAN",""))

 +20      ;Free if <3   MISSION Act otherwise Visit Only No Copay

           SET IBERR6=$ORDER(^IBE(350.3,"B","PURPLE HEART CONFIRMED",""))

 +21      ;Defines variable IBSITE

           DO SITE^IBAUTL

 +22      ;

 +23       SET IBQUIT=0

 +24      ;

 +25      ;Initialize process tracking array in case initialization stops

 +26       NEW X,X2,X1,DT

 +27       SET DT=$$DT^XLFDT

           SET X1=DT

           SET X2=30

           DO C^%DTC

 +28       SET ^XTMP("IB20P669",0)=X_U_DT_U_"IB*2.0*669 Post install Urgent Care Visit Tracking Initialization"

 +29      ;

 +30       FOR LOOP=IBUCIEN1,IBUCIEN3,IBUCIEN4

               Begin DoDot:1

 +31      ;

 +32               SET IBN=0

 +33      ;

 +34      ;See if the initialization was halted. If so, restore loop variables to last entry processed.

 +35               IF $DATA(^XTMP("IB20P669",1))

                       SET IBLSDTA=$GET(^XTMP("IB20P669",1))

                       SET LOOP=$PIECE(IBLSDTA,U)

                       SET IBN=$PIECE(IBLSDTA,U,2)

 +36      ;

 +37               FOR 

                       SET IBN=$ORDER(^IB("AE",LOOP,IBN))

                       if 'IBN

                           QUIT 

                       Begin DoDot:2

 +38      ; Get the data

                           SET IBDATA=$GET(^IB(IBN,0))

 +39                       if IBDATA=""

                               QUIT 

 +40                       SET IBDFN=$PIECE(IBDATA,U,2)

                           SET IBVST=$PIECE(IBDATA,U,14)

                           SET IBVSTIEN=0

 +41      ;Do not count UC visits prior to the start of the UC program on 6/6/2019

                           if IBVST<3190606

                               QUIT 

 +42                       SET IBVSTIEN=$$DBCHK(IBDFN,IBVST)

 +43      ;init variables

                           SET IBSTAT=4

                           SET IBREAS=5

                           SET IBBILL="@"

 +44      ; Get the bill status

                           SET IBBLST=$PIECE(IBDATA,U,5)

 +45      ;Captures all of the DG FEE CANCEL entries from 6/6/2019 to install of IB*2.0*656

                           IF (LOOP=IBUCIEN4)

                               IF ($PIECE(IBDATA,U,7)'=30)

                                   QUIT 

 +46                       SET IBCREAS=$PIECE(IBDATA,U,10)

                           SET IBBLST=$PIECE(IBDATA,U,5)

 +47      ;don't process if visit already in DB and adding a new paid visit

                           IF (IBBLST'=10)

                               IF (LOOP=IBUCIEN1)

                                   IF +IBVSTIEN

                                       QUIT 

 +48                       IF IBBLST'=10

                               Begin DoDot:3

 +49                               SET IBSTAT=1

                                   SET IBREAS=""

 +50      ;Billing Number

                                   SET IBBILL=$PIECE(IBDATA,U,11)

 +51                               IF (IBBLST=8)

                                       IF (IBBILL="")

                                           SET IBBILL="ON HOLD"

                               End DoDot:3

 +52                       IF IBBLST=10

                               Begin DoDot:3

 +53      ;Set Visit to Removed/Entered in Error

                                   IF (IBCREAS=IBERR3)

                                       SET IBSTAT=3

                                       SET IBREAS=3

 +54      ; If Cat Disabled, Purple Heart, or Combat Vet Cancel Reason is used, check for free visits.  If any free visits available, set the visit to free

 +55                               IF (IBCREAS=IBERR4)!(IBCREAS=IBERR5)!(IBCREAS=IBERR6)

                                       IF $$GETELGP^IBECEA36(IBDFN,IBVST)

                                           Begin DoDot:4

 +56                                           SET IBNOVST=$$GETVST^IBECEA36(IBDFN,IBVST)

 +57      ;Potential Free visits

                                               IF $PIECE(IBNOVST,U,2)<3

                                                   SET IBSTAT=1

                                                   SET IBREAS=1

                                           End DoDot:4

                               End DoDot:3

 +58      ;Add new entry to the tracking database

 +59                       IF (IBVSTIEN=0)

                               Begin DoDot:3

 +60                               KILL FDA

 +61      ;Store in array for adding to the file (#351.82)

 +62      ;Patient

                                   SET FDA(351.82,"+1,",.01)=IBDFN

 +63      ;Site

                                   SET FDA(351.82,"+1,",.02)=IBSITE

 +64      ;Visit Date

                                   SET FDA(351.82,"+1,",.03)=IBVST

 +65      ;Status (2 - Billed or 3- Not Counted)

                                   SET FDA(351.82,"+1,",.04)=IBSTAT

 +66      ;Status (2 - Billed or 3- Not Counted)

                                   SET FDA(351.82,"+1,",.05)=IBBILL

 +67      ;Status (2 - Billed or 3- Not Counted)

                                   SET FDA(351.82,"+1,",1.01)=1

 +68      ;Reason (Not counted)

                                   if $GET(IBREAS)'=""

                                       SET FDA(351.82,"+1,",.06)=IBREAS

 +69                               SET FDA(351.82,"+1,",1.01)=1

 +70      ;Add to the file.

 +71                               DO UPDATE^DIE(,"FDA","FDAIEN")

 +72                               SET FDAIEN=FDAIEN(1)

                                   KILL FDAIEN(1)

                               End DoDot:3

                               QUIT 

 +73      ;

 +74      ;Otherwise Taking a canceled visit and updating the reason, bill no, and status fields

 +75                       IF IBVSTIEN'=0

                               Begin DoDot:3

 +76      ;S DLAYGO=351.82,DIC="^IBUC(351.82,",DIC(0)="L"

 +77      ;I '+$G(IBVSTIEN) D FILE^DICN S LIEN=+IBVSTIEN K DIC,DINUM,DLAYGO

 +78      ; Visit Tracking Status

                                   SET DR=".04////"_IBSTAT

 +79      ; Bill Number (should reset to NULL)

                                   SET DR=DR_";.05////"_IBBILL

 +80      ; Reason (should be UC-ENTERED IN ERROR or UC-Duplicate Event)

                                   SET DR=DR_";.06////"_IBREAS

 +81      ; Flag for multi-site transmission

                                   SET DR=DR_";1.01////1"

 +82      ;

 +83                               SET DIE="^IBUC(351.82,"

                                   SET DA=IBVSTIEN

 +84                               DO ^DIE

 +85                               KILL DR

                               End DoDot:3

 +86      ;Save the entry just processed

 +87                       SET ^XTMP("IB20P669",1)=LOOP_U_IBN

 +88                       IF $$S^%ZTLOAD()

                               Begin DoDot:3

 +89      ;

 +90                               NEW ZTRTN,ZTDTH,ZTDESC,ZTIO

 +91      ;

 +92      ;requeue for later

 +93                               SET ZTRTN="INITUCDB^IB20P669"

 +94      ; reschedule for 1 hr after time process stopped

                                   SET ZTDTH=$$NOW^XLFDT+.01

 +95                               SET ZTDESC="IB*2.0*669 Initialize File 351.82 - Urgent Care Visit Tracking DB"

 +96                               SET ZTIO=""

 +97      ; Call TaskManager

                                   DO ^%ZTLOAD

 +98                               SET IBQUIT=1

                               End DoDot:3

                               QUIT 

                       End DoDot:2

               End DoDot:1

               if IBQUIT

                   QUIT 

 +99      ;Clear update array before next use

           KILL DR

 +100      QUIT 

 +101     ;

DBCHK(IBDFN,IBVDT) ; Check to see if the visit is already in the DB.

 +1       ; 

 +2        NEW IBLP,IBQUIT,IBDATA,IBDT

 +3       ; Returns IBQUIT - the IEN of the Visit OR 0

 +4       ;loop through the patient's visits to see if it has already been recorded.

 +5        SET IBLP=0

           SET IBQUIT=0

 +6        FOR 

               SET IBLP=$ORDER(^IBUC(351.82,"B",IBDFN,IBLP))

               if 'IBLP

                   QUIT 

               Begin DoDot:1

 +7                SET IBDATA=$GET(^IBUC(351.82,IBLP,0))

 +8                SET IBDT=$PIECE(IBDATA,U,3)

 +9       ; quit if there is a visit already stored on that day.

 +10               IF IBDT=IBVDT

                       SET IBQUIT=IBLP

               End DoDot:1

               if IBQUIT

                   QUIT 

 +11       QUIT IBQUIT

 +12      ;

CANCLUC   ; Initialize the new CAN CANCEL URGENT CARE field (.04) in the IB CHARGE REMOVE REASON file (#350.3).

 +1       ;  Also inactivate UC-ENTERED IN ERROR AND UC-CHANGE IN ELIGIBILITY

 +2       ;  Also define the type of UC Visit Tracking DB (351.82) update process to follow when using the cancellation

 +3       ;

 +4        NEW LOOP,LIEN,IBDATA,IBCCUC,IBINACT,IBNM,IBNOVST,IBUCDB

 +5        NEW X,Y,DIE,DA,DR,DTOUT,DATA

 +6       ;

 +7        DO MES^XPDUTL("     -> Update of the new IB CHARGE REMOVE REASON fields started.")

 +8       ; Grab all of the entries to update

 +9        FOR LOOP=1:1:14

               Begin DoDot:1

 +10      ;Extract the new ACTION TYPE to be added.

 +11               SET IBDATA=$TEXT(IBDDAT+LOOP)

 +12               SET IBDATA=$PIECE(IBDATA,";;",2)

 +13               SET IBNM=$PIECE(IBDATA,";",1)

                   SET IBCCUC=$PIECE(IBDATA,";",2)

                   SET IBUCDB=$PIECE(IBDATA,";",3)

                   SET IBINACT=$PIECE(IBDATA,";",4)

 +14      ; find CHARGE REMOVE REASON entry 

                   SET LIEN=$ORDER(^IBE(350.3,"B",IBNM,""))

 +15               if LIEN=""

                       QUIT 

 +16      ;

 +17      ; File the update along with inactivate the ACTION TYPE

 +18               SET DR=".04///"_IBCCUC

 +19               SET DR=DR_";.05///"_IBUCDB

 +20               if IBINACT'=""

                       SET DR=DR_";.06///"_IBINACT

 +21               SET DIE="^IBE(350.3,"

                   SET DA=LIEN

 +22               DO ^DIE

 +23      ;Clear update array before next use

                   KILL DR

               End DoDot:1

 +24      ;

 +25       SET DR=""

 +26       DO MES^XPDUTL("     -> Update of IB CHARGE REMOVE REASON completed.")

 +27       QUIT 

 +28      ;

IBDDAT    ; Cancellation reasons (350.3) to update

 +1       ;;ENTERED IN ERROR;Y;1

 +2       ;;PATIENT DECEASED;Y;2

 +3       ;;CHANGE IN ELIGIBILITY;Y;3

 +4       ;;RECD INPATIENT CARE;Y;2

 +5       ;;PURPLE HEART CONFIRMED;N;3

 +6       ;;BILLED AT HIGHER TIER RATE;Y;2

 +7       ;;BILLED LTC CHARGE;Y;2

 +8       ;;COMBAT VETERAN;N;3

 +9       ;;CATASTROPHICALLY DISABLED;N;3

 +10      ;;UC - ENTERED IN ERROR;Y;1;Y

 +11      ;;UC - CHANGE IN ELIGIBILITY;Y;3;Y

 +12      ;;UC - DUPLICATE VISIT;Y;4

 +13      ;;UC - SEQUENCE UPDATE;Y;3

 +14      ;;UC - PG6 REVIEWED;Y;3

 +15      ;;END

 +16      ;

NEWCREAS  ; New Cancellation Reasons

 +1        NEW LOOP,LIEN,IBDATA,IBCNNM

 +2        NEW X,Y,DIE,DA,DR,DTOUT,DATA,IBDATAB

 +3       ; 

 +4        NEW CANIEN,UPDIEN,SVCIEN,CHGIEN

 +5       ;

 +6       ; Grab all of the entries to update

 +7        DO MES^XPDUTL("     -> Adding new Cancellation Reason to the IB CHARGE REMOVE REASON file (350.3).")

 +8        SET Y=-1

 +9        FOR LOOP=1:1

               SET IBDATA=$TEXT(REASDAT+LOOP)

               if $PIECE(IBDATA,";",3)="END"

                   QUIT 

               Begin DoDot:1

 +10               SET DR=""

 +11      ;Extract the new ACTION TYPE to be added.

 +12      ;Store in array for adding to the file (#350.1).

 +13      ;go to next entry if Category is not to be updated.

                   if IBDATA=""

                       QUIT 

 +14      ;

 +15               SET IBCNNM=$PIECE(IBDATA,";",3)

 +16               SET LIEN=$ORDER(^IBE(350.3,"B",IBCNNM,""))

 +17      ; File the update along with inactivate the ACTION TYPE

 +18               SET DLAYGO=350.3

                   SET DIC="^IBE(350.3,"

                   SET DIC(0)="L"

                   SET X=IBCNNM

 +19               IF '+LIEN

                       DO FILE^DICN

                       SET LIEN=+Y

                       KILL DIC,DINUM,DLAYGO

 +20      ; ABBREVIATION

                   SET DR=".02////"_$PIECE(IBDATA,";",4)

 +21      ; LIMIT

                   SET DR=DR_";.03////"_$PIECE(IBDATA,";",5)

 +22      ;

 +23               SET DIE="^IBE(350.3,"

                   SET DA=LIEN

 +24               DO ^DIE

 +25      ;<re-index new entry here>

 +26               SET DA=LIEN

                   SET DIK="^IBE(350.3,"

                   DO IX^DIK

 +27               KILL DR

               End DoDot:1

 +28       QUIT 

 +29      ;

REASDAT   ; Fee Service to inactivate

 +1       ;;UC - PG6 REVIEWED;UCPG6;3

 +2       ;;END

 +3        QUIT