Routine: IBP618A

IBP618A ;SAB/Albany - IB*2.0*618 POST INSTALL (CONT'D);12/11/17 2:10pm

 ;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 61

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

ADDACT ; Add new ACTION TYPE ENTRIES (350.1)

 N IBLOOP,IBDATA,FDA,IBARCAT,IBSVC,FDAIEN

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

 N IBSL,IBSL1,IBSL1TXT,IBSL2,IBSL2TXT,IBSL3,IBSL3TX1,IBSL3TX2,IBSL3TX3

 N IBIEN,IBLAST,IBBEG,IBEND

 N IBEL,IBEL1,IBEL2,IBEL3,IBDQDASH

 ; Define the Logic field information

 ; Set Logic

 S IBDQDASH=$c(95)_$c(34)_$c(45)_$c(34)_$c(95)

 S IBSL2TXT="FEE OPT COPAYMENT"

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

 S IBSL1TXT="INPT PER DIEM"

 S IBSL1="S IBDESC="_$C(34)_IBSL1TXT_$C(34)

 S IBSL3TX1="S:'$D(^(10)) X="""" I $D(^(10)) X ^(10) S X=$S($D(Y(0)):$P(Y(0),U),1:""UNK"") "

 S IBSL3TX2="I $D(Y(0)) S X=X_""-""_$S($$DRUG^IBRXUTL1(+$P(Y(0),U,6))'="""":$$DRUG^IBRXUTL1(+$P(Y(0),U,6)),1:"_"""UNK DRUG"""_")"

 S IBSL3TX3=",X=$E(X,1,18)_""-""_$S($D(IBUNIT):IBUNIT,$D(IBX):$P(IBX,U,2),1:"""")"

 S IBSL3=IBSL3TX1_IBSL3TX2_IBSL3TX3

 ; Eligibility Logic

 S IBEL1="S X=0,X1="""_",X2="_""""_" "

 S IBEL2="G:'$D(VAEL) 1^IBAERR I VAEL(4),'+VAEL(3),'IBDOM,'$$RXEXMT^IBARXEU0(DFN,DT) "

 S IBEL3="S X=1,X2=$P(^IBE(350.1,DA,0),"_""_"^"_""_",4) D COST^IBAUTL"

 S IBEL=IBEL1_IBEL2_IBEL3

 S IBLAST=1

 S IBIEN="" F  S IBIEN=$O(^IBE(350.1,IBIEN)) Q:IBIEN=""  S:$G(IBIEN) IBLAST=IBIEN

 S IBBEG=IBLAST

 D MES^XPDUTL("     -> Adding new AT entries to file 350.1 ...")

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

 . ;Clear the array

 . K FDA

 . ;Extract the new ACTION TYPE to be added.

 . Q:$D(^IBE(350.1,"B",$P(IBDATA,";",3)))  ; Quit loop if action type exist

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

 . S FDA(350.1,"+1,",.01)=$P(IBDATA,";",3)    ;Name

 . S FDA(350.1,"+1,",.02)=$P(IBDATA,";",4)    ;Abbreviation

 . S IBARCAT=$P(IBDATA,";",5)                   ;AR Cat (Charge Code)

 . S:IBARCAT'="" IBARCAT=$O(^PRCA(430.2,"B",IBARCAT,""))  ;Find local IEN for AR Cat

 . S FDA(350.1,"+1,",.03)=IBARCAT

 . S IBSVC=$P(IBDATA,";",6)                   ;Service

 . S:IBSVC'="" IBSVC=$O(^DIC(49,"B",IBSVC,""))  ;Find local IEN for Service

 . S FDA(350.1,"+1,",.04)=IBSVC

 . S FDA(350.1,"+1,",.05)=$P(IBDATA,";",7)    ;Seq Number

 . S FDA(350.1,"+1,",.08)=$P(IBDATA,";",8)   ;User Lookup Name

 . S FDA(350.1,"+1,",.1)=$P(IBDATA,";",9)    ;Place on Hold

 . S FDA(350.1,"+1,",.11)=$P(IBDATA,";",10)   ;Billing Group

 . I $P(IBDATA,";",11)'="" S FDA(350.1,"+1,",10)=$P(IBDATA,";",11)    ;Parent Logic

 . I $P(IBDATA,";",12)'="" S FDA(350.1,"+1,",20)=@$P(IBDATA,";",12)  ;Set Logic

 . I $P(IBDATA,";",13)'="" S FDA(350.1,"+1,",30)=$P(IBDATA,";",13)    ;Full Logic

 . I $P(IBDATA,";",14)'="" S FDA(350.1,"+1,",40)=@$P(IBDATA,";",14)   ;Eligibility Logic

 . ;Add to the IB file.

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

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

 D MES^XPDUTL("        New ACTION TYPES added.")

ACTDAT ; Data for the new ACTION TYPE fields. (All categories will be updated)

 ;;CHOICE (INPT) CANCEL;CAN CCCI;CHOICE INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CHOICE (INPT) NEW;NEW CCCI;CHOICE INPT;BUSINESS OFFICE;1;CHOICE INPATIENT;1;1;;;;

 ;;CHOICE (INPT) UPDATE;UPD CCCI;CHOICE INPT;BUSINESS OFFICE;3;;1;1;;;;

 ;;CHOICE (PER DIEM) CANCEL;CAN CCCP;CHOICE INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CHOICE (PER DIEM) NEW;NEW CCCP;CHOICE INPT;BUSINESS OFFICE;1;CHOICE PER DIEM;1;3;;IBSL1;;

 ;;CHOICE (PER DIEM) UPDATE;UPD CCCP;CHOICE INPT;BUSINESS OFFICE;3;;1;3;;;;

 ;;CHOICE (OPT) CANCEL;CAN CCCO;CHOICE OPT;BUSINESS OFFICE;2;;;;;;;

 ;;CHOICE (OPT) NEW;NEW CCCO;CHOICE OPT;BUSINESS OFFICE;1;CHOICE OUTPATIENT;1;4;;IBSL2;;

 ;;CHOICE (OPT) UPDATE;UPD CCCO;CHOICE OPT;BUSINESS OFFICE;3;;1;4;;;;

 ;;CHOICE (RX) CANCEL;CAN CCCR;CHOICE RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;CHOICE (RX) NEW;NEW CCCR;CHOICE RX CO-PAYMENT;PHARMACY;1;CHOICE RX;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL

 ;;CHOICE (RX) UPDATE;UPD CCCR;CHOICE RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;CC (INPT) CANCEL;CAN CCIP;CC INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CC (INPT) NEW;NEW CCIP;CC INPT;BUSINESS OFFICE;1;CC INPATIENT;1;1;;;;

 ;;CC (INPT) UPDATE;UPD CCIP;CC INPT;BUSINESS OFFICE;3;;1;1;;;;

 ;;CC (PER DIEM) CANCEL;CAN CCPD;CC INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CC (PER DIEM) NEW;NEW CCPD;CC INPT;BUSINESS OFFICE;1;CC PER DIEM;1;3;;IBSL1;;

 ;;CC (PER DIEM) UPDATE;UPD CCPD;CC INPT;BUSINESS OFFICE;3;;1;3;;;;

 ;;CC (OPT) CANCEL;CAN CCO;CC OPT;BUSINESS OFFICE;2;;;;;;;

 ;;CC (OPT) NEW;NEW CCO;CC OPT;BUSINESS OFFICE;1;CC OUTPATIENT;1;4;;IBSL2;;

 ;;CC (OPT) UPDATE;UPD CCO;CC OPT;BUSINESS OFFICE;3;;1;4;;;;

 ;;CC (RX) CANCEL;CAN CCRX;CC RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;CC (RX) NEW;NEW CCRX;CC RX CO-PAYMENT;PHARMACY;1;CC RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL

 ;;CC (RX) UPDATE;UPD CCRX;CC RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;CCN (INPT) CANCEL;CAN CCNI;CCN INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CCN (INPT) NEW;NEW CCNI;CCN INPT;BUSINESS OFFICE;1;CCN INPATIENT;1;1;;;;

 ;;CCN (INPT) UPDATE;UPD CCNI;CCN INPT;BUSINESS OFFICE;3;;1;1;;;;

 ;;CCN (PER DIEM) CANCEL;CAN CCNP;CCN INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CCN (PER DIEM) NEW;NEW CCNP;CCN INPT;BUSINESS OFFICE;1;CCN PER DIEM;1;3;;IBSL1;;

 ;;CCN (PER DIEM) UPDATE;UPD CCNP;CCN INPT;BUSINESS OFFICE;3;;1;3;;;;

 ;;CCN (OPT) CANCEL;CAN CCNO;CCN OPT;BUSINESS OFFICE;2;;;;;;;

 ;;CCN (OPT) NEW;NEW CCNO;CCN OPT;BUSINESS OFFICE;1;CCN OUTPATIENT;1;4;;IBSL2;;

 ;;CCN (OPT) UPDATE;UPD CCNO;CCN OPT;BUSINESS OFFICE;3;;1;4;;;;

 ;;CCN (RX) CANCEL;CAN CCNR;CCN RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;CCN (RX) NEW;NEW CCNR;CCN RX CO-PAYMENT;PHARMACY;1;CCN RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL

 ;;CCN (RX) UPDATE;UPD CCNR;CCN RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;CC MTF (INPT) CANCEL;CAN CCDI;CC MTF INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CC MTF (INPT) NEW;NEW CCDI;CC MTF INPT;BUSINESS OFFICE;1;CC MTF INPATIENT;1;1;;;;

 ;;CC MTF (INPT) UPDATE;UPD CCDI;CC MTF INPT;BUSINESS OFFICE;3;;1;1;;;;

 ;;CC MTF (PER DIEM) CANCEL;CAN CCDP;CC MTF INPT;BUSINESS OFFICE;2;;;;;;;

 ;;CC MTF (PER DIEM) NEW;NEW CCDP;CC MTF INPT;BUSINESS OFFICE;1;CC MTF PER DIEM;1;3;;IBSL1;;

 ;;CC MTF (PER DIEM) UPDATE;UPD CCDP;CC MTF INPT;BUSINESS OFFICE;3;;1;3;;;;

 ;;CC MTF (OPT) CANCEL;CAN CCDO;CC MTF OPT;BUSINESS OFFICE;2;;;;;;;

 ;;CC MTF (OPT) NEW;NEW CCDO;CC MTF OPT;BUSINESS OFFICE;1;CC MTF OUTPATIENT;1;4;;IBSL2;;

 ;;CC MTF (OPT) UPDATE;UPD CCDO;CC MTF OPT;BUSINESS OFFICE;3;;1;4;;;;

 ;;CC MTF (RX) CANCEL;CAN CCDR;CC MTF RX CO-PAYMENT;PHARMACY;2;;;;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;CC MTF (RX) NEW;NEW CCDR;CC MTF RX CO-PAYMENT;PHARMACY;1;CC MTF RX COPAY;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;IBEL

 ;;CC MTF (RX) UPDATE;UPD CCDR;CC MTF RX CO-PAYMENT;PHARMACY;3;;1;5;D PTL^IBAUTL;IBSL3;I $D(X) D EN^PSOCPVW;

 ;;LTC CC INPT CNH CANCEL;C CCCNH;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CC INPT CNH NEW;N CCCNH;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CC LTC INPT CNH;1;9;;;;

 ;;LTC CC INPT CNH UPDATE;U CCCNH;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;9;;;;

 ;;LTC CC INPT RESPITE CANCEL;C CCIRES;CC RESPITE CARE;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CC INPT RESPITE NEW;N CCIRES;CC RESPITE CARE;BUSINESS OFFICE;1;CC LTC INPT RESPITE;1;9;;;;

 ;;LTC CC INPT RESPITE UPDATE;U CCIRES;CC RESPITE CARE;BUSINESS OFFICE;3;;1;9;;;;

 ;;LTC CC OPT ADHC CANCEL;C CCADHC;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CC OPT ADHC NEW;N CCADHC;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CC LTC OPT ADHC;1;8;;;;

 ;;LTC CC OPT ADHC UPDATE;U CCADHC;CC NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;8;;;;

 ;;LTC CC OPT RESPITE CANCEL;C CCORES;CC RESPITE CARE;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CC OPT RESPITE NEW;N CCORES;CC RESPITE CARE;BUSINESS OFFICE;1;CC LTC OPT RESPITE;1;8;;;;

 ;;LTC CC OPT RESPITE UPDATE;U CCORES;CC RESPITE CARE;BUSINESS OFFICE;3;;1;8;;;;

 ;;LTC CCN INPT CNH CANCEL;C CCNCNH;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CCN INPT CNH NEW;N CCNCNH;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CCN LTC INPT CNH;1;9;;;;

 ;;LTC CCN INPT CNH UPDATE;U CCNCNH;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;9;;;;

 ;;LTC CCN INPT RESPITE CANCEL;C CCNIRS;CCN RESPITE CARE;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CCN INPT RESPITE NEW;N CCNIRS;CCN RESPITE CARE;BUSINESS OFFICE;1;CCN LTC INPT RESPITE;1;9;;;;

 ;;LTC CCN INPT RESPITE UPDATE;U CCNIRS;CCN RESPITE CARE;BUSINESS OFFICE;3;;1;9;;;;

 ;;LTC CCN OPT ADHC CANCEL;C CCNOAD;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CCN OPT ADHC NEW;N CCNOAD;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CCN LTC OPT ADHC;1;8;;;;

 ;;LTC CCN OPT ADHC UPDATE;U CCNOAD;CCN NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;8;;;;

 ;;LTC CCN OPT RESPITE CANCEL;C CCNORS;CCN RESPITE CARE;BUSINESS OFFICE;2;;;;;;;;

 ;;LTC CCN OPT RESPITE NEW;N CCNORS;CCN RESPITE CARE;BUSINESS OFFICE;1;CCN LTC OPT RESPITE;1;8;;;;

 ;;LTC CCN OPT RESPITE UPDATE;U CCNORS;CCN RESPITE CARE;BUSINESS OFFICE;3;;1;8;;;;

 ;;LTC CHOICE INPT CNH CANCEL;C CCCCNH;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CHOICE INPT CNH NEW;N CCCCNH;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CHOICE LTC INPT CNH;1;9;;;;

 ;;LTC CHOICE INPT CNH UPDATE;U CCCCNH;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;9;;;;

 ;;LTC CHOICE INPT RESPITE CANCEL;C CCCIRS;CHOICE RESPITE CARE;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CHOICE INPT RESPITE NEW;N CCCIRS;CHOICE RESPITE CARE;BUSINESS OFFICE;1;CHOICE LTC INP RESPITE;1;9;;;;

 ;;LTC CHOICE INPT RESPITE UPDATE;U CCCIRS;CHOICE RESPITE CARE;BUSINESS OFFICE;3;;1;9;;;;

 ;;LTC CHOICE OPT ADHC CANCEL;C CCCOAD;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CHOICE OPT ADHC NEW;N CCCOAD;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;1;CHOICE LTC OPT ADHC;1;8;;;;

 ;;LTC CHOICE OPT ADHC UPDATE;U CCCOAD;CHOICE NURSING HOME CARE - LTC;BUSINESS OFFICE;3;;1;8;;;;

 ;;LTC CHOICE OPT RESPITE CANCEL;C CCCORS;CHOICE RESPITE CARE;BUSINESS OFFICE;2;;;;;;;

 ;;LTC CHOICE OPT RESPITE NEW;N CCCORS;CHOICE RESPITE CARE;BUSINESS OFFICE;1;CHOICE LTC OPT RESPITE;1;8;;;;

 ;;LTC CHOICE OPT RESPITE UPDATE;U CCCORS;CHOICE RESPITE CARE;BUSINESS OFFICE;3;;1;8;;;;

 ;;END

IBUPD ; Inactivate FEE Service Entries

 N LOOP,LIEN,IBDATA

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

 ; Grab all of the entries to update

 F LOOP=1:1:24 D

 . ;Extract the new ACTION TYPE to be added.

 . S IBDATA=$T(IBDDAT+LOOP)

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

 . ;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",IBDATA,""))  ; find ACTION TYPE entry

 . Q:LIEN=""

. ;

 . ; File the update along with inactivate the ACTION TYPE

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

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

 . D ^DIE

 . K DR   ;Clear update array before next use

 S DR=""

 D MES^XPDUTL("     -> Data added to the ACTION TYPE (350.1) INACTIVE field.")

IBDDAT ; Fee Service to inactivate

 ;;DG FEE SERVICE (INPT) CANCEL

 ;;DG FEE SERVICE (INPT) NEW

 ;;DG FEE SERVICE (INPT) UPDATE

 ;;DG FEE SERVICE (OPT) CANCEL

 ;;DG FEE SERVICE (OPT) NEW

 ;;DG FEE SERVICE (OPT) UPDATE

 ;;DG LTC FEE INPT CNH CANCEL

 ;;DG LTC FEE INPT CNH NEW

 ;;DG LTC FEE INPT CNH UPDATE

 ;;DG LTC FEE INPT RESPITE CANCEL

 ;;DG LTC FEE INPT RESPITE NEW

 ;;DG LTC FEE INPT RESPITE UPDATE

 ;;DG LTC FEE OPT ADHC CANCEL

 ;;DG LTC FEE OPT ADHC NEW

 ;;DG LTC FEE OPT ADHC UPDATE

 ;;DG LTC FEE OPT RESPITE CANCEL

 ;;DG LTC FEE OPT RESPITE NEW

 ;;DG LTC FEE OPT RESPITE UPDATE

 ;;FEE SERV INPT PER DIEM CANCEL

 ;;FEE SERV INPT PER DIEM NEW

 ;;FEE SERV INPT PER DIEM UPDATE

 ;;FEE SERV NSC RX COPAY CANCEL

 ;;FEE SERV NSC RX COPAY NEW

 ;;FEE SERV NSC RX COPAY UPDATE

 ;;END

IBP618A.m