Routine: IB20P656

IB20P656 ;/Albany - IB*2.0*656 POST INSTALL;07/25/19 2:10pm

 ;;2.0;Integrated Billing;**656**;Mar 20, 1995;Build 17

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

 ; Reference to ^DIC(49 supported by IA# 10093

 ; Reference to ^PRCA(430.2 supported by IA# 594

POSTINIT ;Post Install for IB*2.0*656

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

 ; Adding AR CATEGORIES and REVENUE SOURCE CODES

 D UPDIB ; Update ^IBE fields

 D IBUPD

 D UPDACT

 D UPDDGFEE

 D DGSET

 D NEWCREAS

 D SRVUPD

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

UPDIB   ; Update IBE field(s)

 N IBSL2,IBSL2TXT

 N LOOP,LIEN,IBDATA

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

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

 . ;Extract the new ACTION TYPE

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

 . S LIEN=$O(^IBE(350.1,"B",$P(IBDATA,";",3),""))

 . S DR=""

 . S IBSL2TXT=$P(IBDATA,";",4)

 . S IBSL2="S IBDESC="_$C(34)_IBSL2TXT_$C(34)

 . S DR=DR_"20///"_IBSL2

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

 . D ^DIE

 K DR   ;Clear update array before next use

UPDDGFEE   ; Deactivate FEE Service Entry (inactivate flag to YES)

 ;DG FEE SERVICE (OPT) NEW

 ; LOOKUP - FEE SERVICE/OUTPATIENT

 ; LOGIC - S IBDESC="FEE OPT COPAYMENT"

 N DG,DGN,DGU,DGC,DR,LIEN

 S DGN="DG FEE SERVICE (OPT) NEW"

 S DGC="DG FEE SERVICE (OPT) CANCEL"

 S DGU="DG FEE SERVICE (OPT) UPDATE"

 F DG=DGC,DGU,DGN S LIEN=$O(^IBE(350.1,"B",DG,"")) D

 .S DR=".12////1;"

 .S:DG=DGN DR=DR_".08///FEE SERVICE/OUTPATIENT"  ; USER LOOKUP NAME

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

 .D ^DIE

DGSET ; SET LOGIC

 N DR,LIEN

 N IBSL2,IBSL2TXT

 S IBSL2TXT="FEE OPT COPAYMENT"

 S IBSL2="S IBDESC="_$C(34)_IBSL2TXT_$C(34)

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

 S DR="20///"_IBSL2

 S DIE="^IBE(350.1,",DA=LIEN

 D ^DIE

 K DR   ;Clear update array before next use

 S DR=""

IBUPD ; CC URGENT CARE Category

 N LOOP,LIEN,IBDATA,IBSERVIC

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

 N IBSL2,IBSL2TXT

 N CANIEN,UPDIEN,SVCIEN,CHGIEN

 ;Get the MAS SERVICE IEN POINTER

 S IBSERVIC=$$GET1^DIQ(350.9,"1,",1.14,"I")

 S IBSL2TXT="CC URGENT OPT COPAY"

 S IBSL2="S IBDESC="_$C(34)_IBSL2TXT_$C(34)

 ; Grab all of the entries to update

 D MES^XPDUTL("     -> Adding new CC URGENT CARE Action Types (file 350.1).")

 S Y=-1

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

 . S CHGIEN=$O(^PRCA(430.2,"B",$P(IBDATA,";",5),""))   ; CHARGE CATEGORY -> IEN (used as pointer)

 . ;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 LIEN=$O(^IBE(350.1,"B",$P(IBDATA,";",3),""))

 . ; File the update along with inactivate the ACTION TYPE

 . S DLAYGO=350.1,DIC="^IBE(350.1,",DIC(0)="L",X=$P(IBDATA,";",3)

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

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

 . S DR=DR_";.03///"_$G(CHGIEN)          ; CHARGE CATEGORY

 . S DR=DR_";.04////"_IBSERVIC           ; SERVICE

 . S DR=DR_";.05///"_$P(IBDATA,";",7)    ; SEQ. #

 . S DR=DR_";.06///"_$P(IBDATA,";",8)    ; CANCEL ACTION TYPE

 . S DR=DR_";.07///"_$P(IBDATA,";",9)    ; UPDATE ACTION TYPE

 . S DR=DR_";.08///"_$P(IBDATA,";",10)   ; USER LOOKUP NAME

 . S DR=DR_";.09////"_$P(IBDATA,";",11)  ; NEW ACTION TYPE

 . S DR=DR_";.1///"_$P(IBDATA,";",12)    ; PLACE ON HOLD

 . S DR=DR_";.11///"_$P(IBDATA,";",13)   ; BILLING GROUP

 . S:$P(IBDATA,";",14)="IBSL2" DR=DR_";20////"_IBSL2   ;SET LOGIC

. ;

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

 . D ^DIE

 . ;<re-index new entry here>

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

 .S DR=""

 ;350.1,.01    3 NAME                   0;1 FREE TEXT (Required)

 ;350.1,.02    4 ABBREVIATION           0;2 FREE TEXT

 ;350.1,.03    5 CHARGE CATEGORY        0;3 POINTER TO ACCOUNTS RECEIVABLE CATEGORY FILE (#430.2)

 ;350.1,.04    6 SERVICE                0;4 POINTER TO DIC FILE (#49)

 ;350.1,.05    7 SEQUENCE NUMBER        0;5 SET

 ;350.1,.06    8 CANCELLATION ACTION TYPE 0;6 POINTER TO IB ACTION TYPE FILE (#350.1)

 ;350.1,.07    9 UPDATE ACTION TYPE     0;7 POINTER TO IB ACTION TYPE FILE (#350.1)

 ;350.1,.08   10 USER LOOKUP NAME       0;8 FREE TEXT

 ;350.1,.09   11 NEW ACTION TYPE        0;9 POINTER TO IB ACTION TYPE FILE (#350.1

 ;350.1,.1    12 PLACE ON HOLD          0;10 SET

 ;350.1,.11   13 BILLING GROUP          0;11 SET

 ;350.1,10    14 PARENT TRACE LOGIC     10;E1,245 MUMPS

 ;350.1,20    15 SET LOGIC              20;E1,245 MUMPS

 ;350.1,30    16 FULL PROFILE LOGIC     30;E1,245 MUMPS

 ;350.1,40    17 ELIGIBILITY LOGIC      40;E1,245 MUMPS

IBDDAT ; Fee Service to inactivate

 ;;CC URGENT CARE (OPT) CANCEL;CAN CCUC;CC URGENT CARE;BUSINESS OFFICE;CANCEL;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;;CC URGENT CARE (OPT) NEW;;OPT COPAY

 ;;CC URGENT CARE (OPT) UPDATE;UPD CCUC;CC URGENT CARE;BUSINESS OFFICE;UPDATE;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;;CC URGENT CARE (OPT) NEW;;OPT COPAY

 ;;CC URGENT CARE (OPT) NEW;CCUC CO;CC URGENT CARE;BUSINESS OFFICE;NEW;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE;CC URGENT CARE (OPT) NEW;1;OPT COPAY;IBSL2

 ;;END

IBSET ; SET LOGIC

 ;;CC (OPT) NEW;CC OPT COPAY

 ;;CHOICE (OPT) NEW;CHOICE OPT COPAY

 ;;CCN (OPT) NEW;CCN OPT COPAY

 ;;CC MTF (OPT) NEW;CC MTF OPT COPAY

 ;;END

UPDACT ; Update the Action Type Fields for the new Action Types

 N IBDATA,IBLOOP,IBIEN,IBACTNM

 N X,Y,DIE,DA,DR,DTOUT,DATA    ;^DIE variables

 D MES^XPDUTL("     -> Updating the Action Type Fields in file 350.1 ...")

 F IBLOOP=2:1 S IBDATA=$T(UPDDAT+IBLOOP) Q:IBDATA=" ;;END"  D

 . S IBACTNM=$P(IBDATA,";",3)   ;Name of the Action Type

 . ;Retrieve the IEN.

 . S IBIEN=$O(^IBE(350.1,"B",IBACTNM,""))

 . I IBIEN="" D MES^XPDUTL("          -> Action Type "_IBACTNM_" Is not in the Action Type file.") Q

 . ;File the update

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

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

 . S DR=DR_".09///"_$P(IBDATA,";",6)

 . Q:DR=""

 . S DIE="^IBE(350.1,",DA=IBIEN

 . D ^DIE

 . K DR   ;Clear update array before next use

 D MES^XPDUTL("     -> Update completed ...")

 ;Clear the array

UPDDAT ;

 ;;Action Type;Cancellation Action;Update Action;New Action

 ;;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) NEW

 ;;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) NEW

 ;;CC URGENT CARE (OPT) NEW;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) NEW

 ;;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 Reasons 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

 ;350.3,.01    3 NAME                   0;1 FREE TEXT (Required)

 ;350.3,.02    4 ABBREVIATION           0;2 FREE TEXT

 ;350.3,.03    5 LIMIT                  0;3 Code (3 - Generic)

REASDAT ; Fee Service to inactivate

 ;;UC - ENTERED IN ERROR;UCERROR;3

 ;;UC - CHANGE IN ELIGIBILITY;UCEC;3

 ;;END

SRVUPD ; Update the SERVICE/SECTION Pointer for any CC Action Type to either the MAS SERVICE POINTER IB Site Parameter

 ;       or to the PHARMACY Service (for RXs).

 N IBI,IBSTART,IBEND,IBSERVIC,IBSRV,IBDATA,IBPHARM,IBSTORE,IBERROR

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

 ;Retrieve the first CC Action type IEN

 S IBSTART=$O(^IBE(350.1,"B","CHOICE (INPT) CANCEL",""))

 ;Retrieve the last Non Urgent Care CC Action Type

 S IBEND=$O(^IBE(350.1,"B","LTC CHOICE OPT RESPITE UPDATE",""))

 ;Get the MAS SERVICE IEN POINTER

 S IBSERVIC=$$GET1^DIQ(350.9,"1,",1.14,"I")

 ;Get the PHARMACY service IEN

 S IBERROR=""

 S IBPHARM=$$FIND1^DIC(49,,"X","PHARMACY","B",,"IBERROR")

 ;Loop through and update any entry that has a NULL Service to be the MAS SERVICE POINTER (1.14) in the IB SITE PARAMETER File (350.9)

 F IBI=IBSTART:1:IBEND D

 . S IBDATA=$G(^IBE(350.1,IBI,0)),IBSRV=$P(IBDATA,U,4)

 . S IBSTORE=$S($P(IBDATA,U,11)=5:IBPHARM,1:IBSERVIC)

 . S DR=".04////"_IBSTORE   ; Set the service

. ;

 . S DIE="^IBE(350.1,",DA=IBI

 . D ^DIE

. ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P656   9199     printed  Mar 13, 2025@21:09:05                                                                                                                                                                                                    Page 2

IB20P656  ;/Albany - IB*2.0*656 POST INSTALL;07/25/19 2:10pm

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

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

 +3       ; Reference to ^DIC(49 supported by IA# 10093

 +4       ; Reference to ^PRCA(430.2 supported by IA# 594

 +5        QUIT

 +6       ;

POSTINIT  ;Post Install for IB*2.0*656

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

 +2       ; Adding AR CATEGORIES and REVENUE SOURCE CODES

 +3       ; Update ^IBE fields

           DO UPDIB

 +4        DO IBUPD

 +5        DO UPDACT

 +6        DO UPDDGFEE

 +7        DO DGSET

 +8        DO NEWCREAS

 +9        DO SRVUPD

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

 +11       QUIT

 +12      ;

UPDIB     ; Update IBE field(s)

 +1        NEW IBSL2,IBSL2TXT

 +2        NEW LOOP,LIEN,IBDATA

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

 +4        FOR LOOP=1:1

               SET IBDATA=$TEXT(IBSET+LOOP)

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

                   QUIT

               Begin DoDot:1

 +5       ;Extract the new ACTION TYPE

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

                   if IBDATA=""

                       QUIT

 +7                SET LIEN=$ORDER(^IBE(350.1,"B",$PIECE(IBDATA,";",3),""))

 +8                SET DR=""

 +9                SET IBSL2TXT=$PIECE(IBDATA,";",4)

 +10               SET IBSL2="S IBDESC="_$CHAR(34)_IBSL2TXT_$CHAR(34)

 +11               SET DR=DR_"20///"_IBSL2

 +12               SET DIE="^IBE(350.1,"

                   SET DA=LIEN

 +13               DO ^DIE

               End DoDot:1

 +14      ;Clear update array before next use

           KILL DR

 +15       QUIT

 +16      ;

UPDDGFEE  ; Deactivate FEE Service Entry (inactivate flag to YES)

 +1       ;DG FEE SERVICE (OPT) NEW

 +2       ; LOOKUP - FEE SERVICE/OUTPATIENT

 +3       ; LOGIC - S IBDESC="FEE OPT COPAYMENT"

 +4        NEW DG,DGN,DGU,DGC,DR,LIEN

 +5        SET DGN="DG FEE SERVICE (OPT) NEW"

 +6        SET DGC="DG FEE SERVICE (OPT) CANCEL"

 +7        SET DGU="DG FEE SERVICE (OPT) UPDATE"

 +8        FOR DG=DGC,DGU,DGN

               SET LIEN=$ORDER(^IBE(350.1,"B",DG,""))

               Begin DoDot:1

 +9                SET DR=".12////1;"

 +10      ; USER LOOKUP NAME

                   if DG=DGN

                       SET DR=DR_".08///FEE SERVICE/OUTPATIENT"

 +11               SET DIE="^IBE(350.1,"

                   SET DA=LIEN

 +12               DO ^DIE

               End DoDot:1

 +13       QUIT

 +14      ;

DGSET     ; SET LOGIC

 +1        NEW DR,LIEN

 +2        NEW IBSL2,IBSL2TXT

 +3        SET IBSL2TXT="FEE OPT COPAYMENT"

 +4        SET IBSL2="S IBDESC="_$CHAR(34)_IBSL2TXT_$CHAR(34)

 +5        SET LIEN=$ORDER(^IBE(350.1,"B","DG FEE SERVICE (OPT) NEW",""))

 +6        SET DR="20///"_IBSL2

 +7        SET DIE="^IBE(350.1,"

           SET DA=LIEN

 +8        DO ^DIE

 +9       ;Clear update array before next use

           KILL DR

 +10       SET DR=""

 +11       QUIT

 +12      ;

IBUPD     ; CC URGENT CARE Category

 +1        NEW LOOP,LIEN,IBDATA,IBSERVIC

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

 +3       ;

 +4        NEW IBSL2,IBSL2TXT

 +5        NEW CANIEN,UPDIEN,SVCIEN,CHGIEN

 +6       ;

 +7       ;Get the MAS SERVICE IEN POINTER

 +8        SET IBSERVIC=$$GET1^DIQ(350.9,"1,",1.14,"I")

 +9       ;

 +10       SET IBSL2TXT="CC URGENT OPT COPAY"

 +11       SET IBSL2="S IBDESC="_$CHAR(34)_IBSL2TXT_$CHAR(34)

 +12      ;

 +13      ; Grab all of the entries to update

 +14       DO MES^XPDUTL("     -> Adding new CC URGENT CARE Action Types (file 350.1).")

 +15       SET Y=-1

 +16       FOR LOOP=1:1

               SET IBDATA=$TEXT(IBDDAT+LOOP)

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

                   QUIT

               Begin DoDot:1

 +17      ; CHARGE CATEGORY -> IEN (used as pointer)

                   SET CHGIEN=$ORDER(^PRCA(430.2,"B",$PIECE(IBDATA,";",5),""))

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

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

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

                   if IBDATA=""

                       QUIT

 +21      ;

 +22               SET LIEN=$ORDER(^IBE(350.1,"B",$PIECE(IBDATA,";",3),""))

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

 +24               SET DLAYGO=350.1

                   SET DIC="^IBE(350.1,"

                   SET DIC(0)="L"

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

 +25               IF '+LIEN

                       DO FILE^DICN

                       SET LIEN=+Y

                       KILL DIC,DINUM,DLAYGO

 +26      ; ABBREVIATION

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

 +27      ; CHARGE CATEGORY

                   SET DR=DR_";.03///"_$GET(CHGIEN)

 +28      ; SERVICE

                   SET DR=DR_";.04////"_IBSERVIC

 +29      ; SEQ. #

                   SET DR=DR_";.05///"_$PIECE(IBDATA,";",7)

 +30      ; CANCEL ACTION TYPE

                   SET DR=DR_";.06///"_$PIECE(IBDATA,";",8)

 +31      ; UPDATE ACTION TYPE

                   SET DR=DR_";.07///"_$PIECE(IBDATA,";",9)

 +32      ; USER LOOKUP NAME

                   SET DR=DR_";.08///"_$PIECE(IBDATA,";",10)

 +33      ; NEW ACTION TYPE

                   SET DR=DR_";.09////"_$PIECE(IBDATA,";",11)

 +34      ; PLACE ON HOLD

                   SET DR=DR_";.1///"_$PIECE(IBDATA,";",12)

 +35      ; BILLING GROUP

                   SET DR=DR_";.11///"_$PIECE(IBDATA,";",13)

 +36      ;SET LOGIC

                   if $PIECE(IBDATA,";",14)="IBSL2"

                       SET DR=DR_";20////"_IBSL2

 +37      ;

 +38               SET DIE="^IBE(350.1,"

                   SET DA=LIEN

 +39               DO ^DIE

 +40      ;<re-index new entry here>

 +41               SET DA=LIEN

                   SET DIK="^IBE(350.1,"

                   DO IX^DIK

 +42               SET DR=""

               End DoDot:1

 +43       QUIT

 +44      ;

 +45      ;350.1,.01    3 NAME                   0;1 FREE TEXT (Required)

 +46      ;350.1,.02    4 ABBREVIATION           0;2 FREE TEXT

 +47      ;350.1,.03    5 CHARGE CATEGORY        0;3 POINTER TO ACCOUNTS RECEIVABLE CATEGORY FILE (#430.2)

 +48      ;350.1,.04    6 SERVICE                0;4 POINTER TO DIC FILE (#49)

 +49      ;350.1,.05    7 SEQUENCE NUMBER        0;5 SET

 +50      ;350.1,.06    8 CANCELLATION ACTION TYPE 0;6 POINTER TO IB ACTION TYPE FILE (#350.1)

 +51      ;350.1,.07    9 UPDATE ACTION TYPE     0;7 POINTER TO IB ACTION TYPE FILE (#350.1)

 +52      ;350.1,.08   10 USER LOOKUP NAME       0;8 FREE TEXT

 +53      ;350.1,.09   11 NEW ACTION TYPE        0;9 POINTER TO IB ACTION TYPE FILE (#350.1

 +54      ;350.1,.1    12 PLACE ON HOLD          0;10 SET

 +55      ;350.1,.11   13 BILLING GROUP          0;11 SET

 +56      ;350.1,10    14 PARENT TRACE LOGIC     10;E1,245 MUMPS

 +57      ;350.1,20    15 SET LOGIC              20;E1,245 MUMPS

 +58      ;350.1,30    16 FULL PROFILE LOGIC     30;E1,245 MUMPS

 +59      ;350.1,40    17 ELIGIBILITY LOGIC      40;E1,245 MUMPS

 +60      ;

IBDDAT    ; Fee Service to inactivate

 +1       ;;CC URGENT CARE (OPT) CANCEL;CAN CCUC;CC URGENT CARE;BUSINESS OFFICE;CANCEL;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;;CC URGENT CARE (OPT) NEW;;OPT COPAY

 +2       ;;CC URGENT CARE (OPT) UPDATE;UPD CCUC;CC URGENT CARE;BUSINESS OFFICE;UPDATE;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;;CC URGENT CARE (OPT) NEW;;OPT COPAY

 +3       ;;CC URGENT CARE (OPT) NEW;CCUC CO;CC URGENT CARE;BUSINESS OFFICE;NEW;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE;CC URGENT CARE (OPT) NEW;1;OPT COPAY;IBSL2

 +4       ;;END

IBSET     ; SET LOGIC

 +1       ;;CC (OPT) NEW;CC OPT COPAY

 +2       ;;CHOICE (OPT) NEW;CHOICE OPT COPAY

 +3       ;;CCN (OPT) NEW;CCN OPT COPAY

 +4       ;;CC MTF (OPT) NEW;CC MTF OPT COPAY

 +5       ;;END

UPDACT    ; Update the Action Type Fields for the new Action Types

 +1       ;

 +2        NEW IBDATA,IBLOOP,IBIEN,IBACTNM

 +3       ;^DIE variables

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

 +4        DO MES^XPDUTL("     -> Updating the Action Type Fields in file 350.1 ...")

 +5        FOR IBLOOP=2:1

               SET IBDATA=$TEXT(UPDDAT+IBLOOP)

               if IBDATA=" ;;END"

                   QUIT

               Begin DoDot:1

 +6       ;Name of the Action Type

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

 +7       ;Retrieve the IEN.

 +8                SET IBIEN=$ORDER(^IBE(350.1,"B",IBACTNM,""))

 +9                IF IBIEN=""

                       DO MES^XPDUTL("          -> Action Type "_IBACTNM_" Is not in the Action Type file.")

                       QUIT

 +10      ;File the update

 +11               SET DR=".06///"_$PIECE(IBDATA,";",4)_";"

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

 +13               SET DR=DR_".09///"_$PIECE(IBDATA,";",6)

 +14               if DR=""

                       QUIT

 +15               SET DIE="^IBE(350.1,"

                   SET DA=IBIEN

 +16               DO ^DIE

 +17      ;Clear update array before next use

                   KILL DR

               End DoDot:1

 +18       DO MES^XPDUTL("     -> Update completed ...")

 +19      ;Clear the array

 +20       QUIT

 +21      ;

UPDDAT    ;

 +1       ;;Action Type;Cancellation Action;Update Action;New Action

 +2       ;;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) NEW

 +3       ;;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) NEW

 +4       ;;CC URGENT CARE (OPT) NEW;CC URGENT CARE (OPT) CANCEL;CC URGENT CARE (OPT) UPDATE;CC URGENT CARE (OPT) NEW

 +5       ;;END

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 Reasons 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      ;

 +30      ;350.3,.01    3 NAME                   0;1 FREE TEXT (Required)

 +31      ;350.3,.02    4 ABBREVIATION           0;2 FREE TEXT

 +32      ;350.3,.03    5 LIMIT                  0;3 Code (3 - Generic)

 +33      ;

REASDAT   ; Fee Service to inactivate

 +1       ;;UC - ENTERED IN ERROR;UCERROR;3

 +2       ;;UC - CHANGE IN ELIGIBILITY;UCEC;3

 +3       ;;END

 +4        QUIT

 +5       ;

SRVUPD    ; Update the SERVICE/SECTION Pointer for any CC Action Type to either the MAS SERVICE POINTER IB Site Parameter

 +1       ;       or to the PHARMACY Service (for RXs).

 +2       ;

 +3        NEW IBI,IBSTART,IBEND,IBSERVIC,IBSRV,IBDATA,IBPHARM,IBSTORE,IBERROR

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

 +5       ;

 +6       ;Retrieve the first CC Action type IEN

 +7        SET IBSTART=$ORDER(^IBE(350.1,"B","CHOICE (INPT) CANCEL",""))

 +8       ;

 +9       ;Retrieve the last Non Urgent Care CC Action Type

 +10       SET IBEND=$ORDER(^IBE(350.1,"B","LTC CHOICE OPT RESPITE UPDATE",""))

 +11      ;

 +12      ;Get the MAS SERVICE IEN POINTER

 +13       SET IBSERVIC=$$GET1^DIQ(350.9,"1,",1.14,"I")

 +14      ;

 +15      ;Get the PHARMACY service IEN

 +16       SET IBERROR=""

 +17       SET IBPHARM=$$FIND1^DIC(49,,"X","PHARMACY","B",,"IBERROR")

 +18      ;

 +19      ;Loop through and update any entry that has a NULL Service to be the MAS SERVICE POINTER (1.14) in the IB SITE PARAMETER File (350.9)

 +20       FOR IBI=IBSTART:1:IBEND

               Begin DoDot:1

 +21               SET IBDATA=$GET(^IBE(350.1,IBI,0))

                   SET IBSRV=$PIECE(IBDATA,U,4)

 +22               SET IBSTORE=$SELECT($PIECE(IBDATA,U,11)=5:IBPHARM,1:IBSERVIC)

 +23      ; Set the service

                   SET DR=".04////"_IBSTORE

 +24      ;

 +25               SET DIE="^IBE(350.1,"

                   SET DA=IBI

 +26               DO ^DIE

 +27      ;

               End DoDot:1

 +28       QUIT

IB20P656.m