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
Q
;
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")
Q
;
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
Q
;
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
Q
;
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=""
Q
;
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=""
Q
;
;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
Q
;
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
Q
;
;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
Q
;
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
. ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P656 9199 printed Oct 16, 2024@18:05:01 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
