IB20P618 ;SAB/Albany - IB*2.0*618 POST INSTALL;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.
Q
;
POSTINIT ;Post Install for IB*2.0*618
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*618 ")
; Adding AR CATEGORIES and REVENUE SOURCE CODES
D RTADD
D RTUPD
D ADDRS
D IBUPD^IBP618A
D ADDACT^IBP618A
D UPDACT^IBP618B
D ADDACTCH^IBP618B
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*618")
Q
;
RTADD ;Add New rate types to the Rate type File
;
N LOOP,FDA,FDAIEN,DATA,BRF,ARCAT,CHK
;
D MES^XPDUTL(" -> Adding new Rate Type entries to file 399.3 ...")
; Add new Rate Types
F LOOP=2:1 S DATA=$T(RTDATA+LOOP) Q:$P(DATA,";",3)="END" D
. ;Clear the array
. K FDA
. ;Check to insure that the rate type doesn't exist already
. S CHK="" ; Initialized the check variable
. S CHK=$O(^DGCR(399.3,"B",$P(DATA,";",3),""))
. Q:CHK'=""
. ;Store in array for adding to the file (#399.3).
. S FDA(399.3,"+1,",.01)=$P(DATA,";",3) ;Rate Type Name
. S FDA(399.3,"+1,",.02)=$P(DATA,";",4) ;Bill Name
. S FDA(399.3,"+1,",.03)=$P(DATA,";",5) ;Inactive Flag
. S FDA(399.3,"+1,",.04)=$P(DATA,";",6) ;Abbreviation
. S FDA(399.3,"+1,",.05)=$P(DATA,";",7) ;Third Party?
. S ARCAT=$P(DATA,";",8) ;AR Cat
. S:ARCAT'="" ARCAT=$O(^PRCA(430.2,"AC",ARCAT,"")) ;Find local IEN for AR Cat
. S FDA(399.3,"+1,",.06)=ARCAT ;AR Cat
. S FDA(399.3,"+1,",.07)=$P(DATA,";",9) ;Responsible?
. S FDA(399.3,"+1,",.08)=$P(DATA,";",10) ;Reimbursable
. S FDA(399.3,"+1,",.09)=$P(DATA,";",11) ;NSC Statement
. S FDA(399.3,"+1,",.1)=$P(DATA,";",12) ;Electronic Transmit
. S BRF=$P(DATA,";",13) ;Bill Resulting From (BRF) (430.6)
. S:BRF'="" BRF=$O(^PRCA(430.6,"B",BRF,"")) ;Find local IEN for BRF
. S FDA(399.3,"+1,",.11)=BRF
. S FDA(399.3,"+1,",.12)=$P(DATA,";",14) ;Collect?
. ;Add to the file.
. D UPDATE^DIE(,"FDA","FDAIEN")
. S FDAIEN=FDAIEN(1) K FDAIEN(1)
D MES^XPDUTL(" New Rate Types added.")
Q
;
RTDATA ; New RATE TYPE data. (Internal data format
;;name;billname;inactive; abbreviation;thirdparty;AR Cat #;resp;reimb;nsc;etransmit;billfrom;collect?
;;CC WORKERS' COMP;CC WORKERS' COMP;;CC WC;1;59;i;1;1;1;;
;;CC NO-FAULT AUTO;CC NO-FAULT AUTO;;CC NF;1;60;i;1;1;1;;
;;CC TORT FEASOR;CC TORT FEASOR;;CC TF;1;61;i;1;1;1;;
;;CHOICE WORKERS' COMP;CHOICE WORKERS' COMP;;CCC WC;1;62;i;1;1;1;;
;;CHOICE NO-FAULT AUTO;CHOICE NO-FAULT AUTO;;CCC NF;1;54;i;1;1;1;;
;;CHOICE TORT FEASOR;CHOICE TORT FEASOR;;CCC TF;1;55;i;1;1;1;;
;;CCN WORKERS' COMP;CCN WORKERS' COMP;;CCN WC;1;56;i;1;1;1;;
;;CCN NO-FAULT AUTO;CCN NO-FAULT AUTO;;CCN NF;1;57;i;1;1;1;;
;;CCN TORT FEASOR;CCN TORT FEASOR;;CCN TF;1;58;i;1;1;1;;
;;CHOICE REIMB INS;CHOICE REIMB INS;;CCC REIM;1;50;i;1;1;1;HI;1
;;CC REIMB INS;CC REIMB INS;;CC REIM;1;51;i;1;1;1;HI;1
;;CCN REIMB INS;CCN REIMB INS;;CCN REIM;1;52;i;1;1;1;HI;1
;;CC MTF REIMB INS;CC MTF REIMB INS;;CCD REIM;1;53;i;1;1;1;HI;1
;;DOD DISABILITY EVALUATION;DOD DISABILITY EVALUATION;;TR IDES;1;77;i;1;1;1;HI;1
;;DOD SPINAL CORD INJURY;DOD SPINAL CORD INJURY;;TRSPINAL;1;78;i;1;1;1;HI;1
;;DOD TRAUMATIC BRAIN INJURY;DOD TRAUMATIC BRAIN INJURY;;TR TBI;1;79;i;1;1;1;HI;1
;;DOD BLIND REHABILITATION;DOD BLIND REHABILITATION;;TRREHAB;1;80;i;1;1;1;HI;1
;;TRICARE DENTAL;TRICARE DENTAL;;TR DENTAL;1;81;i;1;1;1;HI;1
;;TRICARE PHARMACY;TRICARE PHARMACY;;TR RX;1;82;i;1;1;1;HI;1
;;END
;
RTUPD ; Update the FEE REIMB INS entry in the Rate Type File (399.3) to inactivate
N LIEN,X,Y,DIE,DA,DR,DTOUT,DATA
;
D MES^XPDUTL(" -> Inactivating the FEE REIMB INS Rate Type...")
S LIEN=$O(^DGCR(399.3,"B","FEE REIMB INS",""))
Q:'LIEN
; File the update
S DR=".03////1;"
S DIE="^DGCR(399.3,",DA=LIEN
D ^DIE
;
Q
ADDRS ; Add Rate Schedules (363) for FEE REIMB INS
D MES^XPDUTL(" -> Adding new Rate Schedules to file 363 ...")
N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
N DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT
S IBCNT=0
F IBI=2:1 S IBLN=$P($T(RSF+IBI),";;",2) Q:IBLN="END" I $E(IBLN)?1A D
. ;Check for problems
. S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS ;Billable service invalid
. S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
.. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
.. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created")
. ;No problems found, so create entry
. K DD,DO
. S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1)
. D FILE^DICN K DIC,DINUM,DLAYGO
. I Y<1 K X,Y Q
. S IBFN=+Y,IBCNT=IBCNT+1
. S IBCPNM=$P(IBLN,U,5),IBEDT=$P(IBLN,U,6)
. S RXDT=$$RXDT(IBCPNM,IBEDT)
. S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
. S DR=DR_";.05////"_$P(RXDT,U)
. I $P(RXDT,U,2) S DR=DR_";.06////"_$P(RXDT,U,2)
. I ($P(IBLN,U,1)["RX"),($G(IBDISP)]"") S DR=DR_";1.01///"_IBDISP
. I ($P(IBLN,U,1)["RX"),($G(IBADMIN)]"") S DR=DR_";1.02////"_IBADMIN
. S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
. S IBCNTCS=0
. ; Retrieve name of Charge Set to copy
. I IBRT="" D MSG(" **** Rate Type "_$P(IBLN,U,2)_" missing Charge Set Information, RS "_$P(IBLN,U,1)_" not created") Q
. ; add all Reasonable Charges Charge Sets to the Rate Schedule.
. S IBCNTCS=$$RSCS(IBFN,IBCPNM,$P(RXDT,U))
. D MES^XPDUTL(" Total Reasonable Charge Set"_$S(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$P(IBLN,U,1)_".")
D MES^XPDUTL(" Rate Schedules completed.")
Q ;ADDRS
;
RSCS(IBFN,IBCPNM,RXDT) ; add existing Charge Sets to FR
; copy the Charge Sets from the corresponding RI RS (v2)
; IBFN - Rate Schedule IEN
; IBCPNM - Charge Set to copy
; RXDT - last effective date of charge set being copied.
N IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
S (IBCNT,IBCOPY)=0
S IBNRS=$G(^IBE(363,+$G(IBFN),0)),IBRSNM=$P(IBNRS,"^",1)
S IBTY=$P(IBNRS,"^",3)
S IBVDT=RXDT
Q:IBVDT="" 0
S IBCOPY=+$$RSEXISTS(IBVDT,IBCPNM)
I 'IBCOPY G RSCSQ
I +$P($G(^IBE(363,+IBCOPY,0)),U,3)=IBTY D
. S IBXFN=0 F S IBXFN=$O(^IBE(363,IBCOPY,11,IBXFN)) Q:'IBXFN D
.. S IBCS=$G(^IBE(363,IBCOPY,11,IBXFN,0)),IBCSFN=+IBCS
.. I +$$RSCSFILE(IBFN,$P($G(^IBE(363.1,IBCSFN,0)),U,1),$P(IBCS,U,2)) S IBCNT=IBCNT+1
RSCSQ Q IBCNT
;
;
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
N IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN S IBX=0
I $G(^IBE(363,+$G(IBFN),0))="" G RSCSFQ
I $G(IBCSNM)="" G RSCSFQ
S IBCSFN=$O(^IBE(363.1,"B",IBCSNM,0)) I 'IBCSFN G RSCSFQ
I $O(^IBE(363,IBFN,11,"B",IBCSFN,0)) G RSCSFQ
S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L"
S X=IBCSNM,DIC("DR")=".02///"_$G(IBCSAA),DIC("P")="363.0011P"
D ^DIC S:+Y IBX=1
RSCSFQ Q IBX
;
;
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
N IBX,IBRSFN,IBRS0 S IBX=0
S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D I IBX Q
. S IBRS0=$G(^IBE(363,IBRSFN,0))
. I $P(IBRS0,U,1)=IBNAME,$P(IBRS0,U,5)=IBVDT S IBX=IBRSFN
Q IBX
;
MSG(X) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q ;MSG
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
N IBX,IBY S IBY=""
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
Q IBY
;
RXDT(IBCPNM,IBEDT) ;Copy the active charge schedule from charge set being copied.
; update Fee information if Pharmacy.
N IBEFLG,IBD
S IBEDT=$G(IBEDT) ; Set to NULL if not passed in
S IBCS=""
;If no Effective Date sent, get the latest entry.
I IBEDT="" S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1)
;If Effective date sent, loop through the entries to find the entry
; with the correct effective date.
I IBEDT'="" D
. S IBEFLG=0
. F S IBCS=$O(^IBE(363,"B",IBCPNM,IBCS),-1) Q:'IBCS D Q:IBEFLG
.. S IBD=$G(^IBE(363,IBCS,0))
.. I $P(IBD,U,5)=IBEDT S IBEFLG=1
Q:IBCS="" ""
S IBCS0=^IBE(363,IBCS,0)
I IBCPNM["RX" S IBDISP=$P($G(^IBE(363,IBCS,1)),U,1),IBADMIN=$G(^IBE(363,IBCS,10))
Q $P(IBCS0,U,5,6) ;return effective and end dates
;
RSF ;Rate Schedules (363) for the new Community Care Rate Types.
;;Rate Schedule Name^Rate Type^Bill Type^Billable Service^Rate Schedule to copy for Charge Sets
;;CCC-NF-INPT^CHOICE NO-FAULT AUTO^1^^NF-INPT
;;CCC-NF-SNF^CHOICE NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
;;CCC-NF-OPT^CHOICE NO-FAULT AUTO^3^^NF-OPT
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3140101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3150101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3160101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3170101
;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3180101
;;CC-NF-INPT^CC NO-FAULT AUTO^1^^NF-INPT
;;CC-NF-SNF^CC NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
;;CC-NF-OPT^CC NO-FAULT AUTO^3^^NF-OPT
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3140101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3150101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3160101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3170101
;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3180101
;;CCN-NF-INPT^CCN NO-FAULT AUTO^1^^NF-INPT
;;CCN-NF-SNF^CCN NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
;;CCN-NF-OPT^CCN NO-FAULT AUTO^3^^NF-OPT
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3140101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3150101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3160101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3170101
;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3180101
;;CCC-RI-INPT^CHOICE REIMB INS^1^^RI-INPT
;;CCC-RI-SNF^CHOICE REIMB INS^1^SKILLED NURSING^RI-SNF
;;CCC-RI-OPT^CHOICE REIMB INS^3^^RI-OPT
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3140101
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3150101
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3160101
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3170101
;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3180101
;;CC-RI-INPT^CC REIMB INS^1^^RI-INPT
;;CC-RI-SNF^CC REIMB INS^1^SKILLED NURSING^RI-SNF
;;CC-RI-OPT^CC REIMB INS^3^^RI-OPT
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3140101
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3150101
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3160101
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3170101
;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3180101
;;CCN-RI-INPT^CCN REIMB INS^1^^RI-INPT
;;CCN-RI-SNF^CCN REIMB INS^1^SKILLED NURSING^RI-SNF
;;CCN-RI-OPT^CCN REIMB INS^3^^RI-OPT
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3140101
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3150101
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3160101
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3170101
;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3180101
;;CC-DOD-INPT^CC MTF REIMB INS^1^INPATIENT^RI-INPT
;;CC-DOD-SNF^CC MTF REIMB INS^1^SKILLED NURSING^RI-SNF
;;CC-DOD-OPT^CC MTF REIMB INS^3^OUTPATIENT VISIT^RI-OPT
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3140101
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3150101
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3160101
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3170101
;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3180101
;;CCC-TF-INPT^CHOICE TORT FEASOR^1^^TF-INPT
;;CCC-TF-SNF^CHOICE TORT FEASOR^1^SKILLED NURSING^TF-SNF
;;CCC-TF-OPT^CHOICE TORT FEASOR^3^^TF-OPT
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3140101
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3150101
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3160101
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3170101
;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3180101
;;CC-TF-INPT^CC TORT FEASOR^1^^TF-INPT
;;CC-TF-SNF^CC TORT FEASOR^1^SKILLED NURSING^TF-SNF
;;CC-TF-OPT^CC TORT FEASOR^3^^TF-OPT
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3140101
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3150101
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3160101
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3170101
;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3180101
;;CCN-TF-INPT^CCN TORT FEASOR^1^^TF-INPT
;;CCN-TF-SNF^CCN TORT FEASOR^1^SKILLED NURSING^TF-SNF
;;CCN-TF-OPT^CCN TORT FEASOR^3^^TF-OPT
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3140101
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3150101
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3160101
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3170101
;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3180101
;;CCC-WC-INPT^CHOICE WORKERS' COMP^1^^WC-INPT
;;CCC-WC-SNF^CHOICE WORKERS' COMP^1^SKILLED NURSING^WC-SNF
;;CCC-WC-OPT^CHOICE WORKERS' COMP^3^^WC-OPT
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3140101
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3150101
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3160101
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3170101
;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3180101
;;CC-WC-INPT^CC WORKERS' COMP^1^^WC-INPT
;;CC-WC-SNF^CC WORKERS' COMP^1^SKILLED NURSING^WC-SNF
;;CC-WC-OPT^CC WORKERS' COMP^3^^WC-OPT
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3140101
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3150101
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3160101
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3170101
;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3180101
;;CCN-WC-INPT^CCN WORKERS' COMP^1^^WC-INPT
;;CCN-WC-SNF^CCN WORKERS' COMP^1^SKILLED NURSING^WC-SNF
;;CCN-WC-OPT^CCN WORKERS' COMP^3^^WC-OPT
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3140101
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3150101
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3160101
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3170101
;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3180101
;;DOD-DIS EXAM-OPT^DOD DISABILITY EVALUATION^3^OUTPATIENT VISIT^RI-OPT
;;DOD-SCI-INPT^DOD SPINAL CORD INJURY^1^INPATIENT^RI-INPT
;;DOD-SCI-OPT^DOD SPINAL CORD INJURY^3^OUTPATIENT VISIT^RI-OPT
;;DOD-SCI-SNF^DOD SPINAL CORD INJURY^1^SKILLED NURSING^RI-SNF
;;DOD-TBI-INPT^DOD TRAUMATIC BRAIN INJURY^1^INPATIENT^RI-INPT
;;DOD-TBI-OPT^DOD TRAUMATIC BRAIN INJURY^3^OUTPATIENT VISIT^RI-OPT
;;DOD-TBI-SNF^DOD TRAUMATIC BRAIN INJURY^1^SKILLED NURSING^RI-SNF
;;DOD-BR-INPT^DOD BLIND REHABILITATION^1^INPATIENT^RI-INPT
;;DOD-BR-OPT^DOD BLIND REHABILITATION^3^OUTPATIENT VISIT^RI-OPT
;;DOD-BR-SNF^DOD BLIND REHABILITATION^1^SKILLED NURSING^RI-SNF
;;TR-DENTAL^TRICARE DENTAL^3^OUTPATIENT VISIT^RI-OPT
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3140101
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3150101
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3160101
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3170101
;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3180101
;;END
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P618 14590 printed Sep 23, 2025@19:40:13 Page 2
IB20P618 ;SAB/Albany - IB*2.0*618 POST INSTALL;12/11/17 2:10pm
+1 ;;2.0;Integrated Billing;**618**;Mar 20, 1995;Build 61
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POSTINIT ;Post Install for IB*2.0*618
+1 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*618 ")
+2 ; Adding AR CATEGORIES and REVENUE SOURCE CODES
+3 DO RTADD
+4 DO RTUPD
+5 DO ADDRS
+6 DO IBUPD^IBP618A
+7 DO ADDACT^IBP618A
+8 DO UPDACT^IBP618B
+9 DO ADDACTCH^IBP618B
+10 DO BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*618")
+11 QUIT
+12 ;
RTADD ;Add New rate types to the Rate type File
+1 ;
+2 NEW LOOP,FDA,FDAIEN,DATA,BRF,ARCAT,CHK
+3 ;
+4 DO MES^XPDUTL(" -> Adding new Rate Type entries to file 399.3 ...")
+5 ; Add new Rate Types
+6 FOR LOOP=2:1
SET DATA=$TEXT(RTDATA+LOOP)
if $PIECE(DATA,";",3)="END"
QUIT
Begin DoDot:1
+7 ;Clear the array
+8 KILL FDA
+9 ;Check to insure that the rate type doesn't exist already
+10 ; Initialized the check variable
SET CHK=""
+11 SET CHK=$ORDER(^DGCR(399.3,"B",$PIECE(DATA,";",3),""))
+12 if CHK'=""
QUIT
+13 ;Store in array for adding to the file (#399.3).
+14 ;Rate Type Name
SET FDA(399.3,"+1,",.01)=$PIECE(DATA,";",3)
+15 ;Bill Name
SET FDA(399.3,"+1,",.02)=$PIECE(DATA,";",4)
+16 ;Inactive Flag
SET FDA(399.3,"+1,",.03)=$PIECE(DATA,";",5)
+17 ;Abbreviation
SET FDA(399.3,"+1,",.04)=$PIECE(DATA,";",6)
+18 ;Third Party?
SET FDA(399.3,"+1,",.05)=$PIECE(DATA,";",7)
+19 ;AR Cat
SET ARCAT=$PIECE(DATA,";",8)
+20 ;Find local IEN for AR Cat
if ARCAT'=""
SET ARCAT=$ORDER(^PRCA(430.2,"AC",ARCAT,""))
+21 ;AR Cat
SET FDA(399.3,"+1,",.06)=ARCAT
+22 ;Responsible?
SET FDA(399.3,"+1,",.07)=$PIECE(DATA,";",9)
+23 ;Reimbursable
SET FDA(399.3,"+1,",.08)=$PIECE(DATA,";",10)
+24 ;NSC Statement
SET FDA(399.3,"+1,",.09)=$PIECE(DATA,";",11)
+25 ;Electronic Transmit
SET FDA(399.3,"+1,",.1)=$PIECE(DATA,";",12)
+26 ;Bill Resulting From (BRF) (430.6)
SET BRF=$PIECE(DATA,";",13)
+27 ;Find local IEN for BRF
if BRF'=""
SET BRF=$ORDER(^PRCA(430.6,"B",BRF,""))
+28 SET FDA(399.3,"+1,",.11)=BRF
+29 ;Collect?
SET FDA(399.3,"+1,",.12)=$PIECE(DATA,";",14)
+30 ;Add to the file.
+31 DO UPDATE^DIE(,"FDA","FDAIEN")
+32 SET FDAIEN=FDAIEN(1)
KILL FDAIEN(1)
End DoDot:1
+33 DO MES^XPDUTL(" New Rate Types added.")
+34 QUIT
+35 ;
RTDATA ; New RATE TYPE data. (Internal data format
+1 ;;name;billname;inactive; abbreviation;thirdparty;AR Cat #;resp;reimb;nsc;etransmit;billfrom;collect?
+2 ;;CC WORKERS' COMP;CC WORKERS' COMP;;CC WC;1;59;i;1;1;1;;
+3 ;;CC NO-FAULT AUTO;CC NO-FAULT AUTO;;CC NF;1;60;i;1;1;1;;
+4 ;;CC TORT FEASOR;CC TORT FEASOR;;CC TF;1;61;i;1;1;1;;
+5 ;;CHOICE WORKERS' COMP;CHOICE WORKERS' COMP;;CCC WC;1;62;i;1;1;1;;
+6 ;;CHOICE NO-FAULT AUTO;CHOICE NO-FAULT AUTO;;CCC NF;1;54;i;1;1;1;;
+7 ;;CHOICE TORT FEASOR;CHOICE TORT FEASOR;;CCC TF;1;55;i;1;1;1;;
+8 ;;CCN WORKERS' COMP;CCN WORKERS' COMP;;CCN WC;1;56;i;1;1;1;;
+9 ;;CCN NO-FAULT AUTO;CCN NO-FAULT AUTO;;CCN NF;1;57;i;1;1;1;;
+10 ;;CCN TORT FEASOR;CCN TORT FEASOR;;CCN TF;1;58;i;1;1;1;;
+11 ;;CHOICE REIMB INS;CHOICE REIMB INS;;CCC REIM;1;50;i;1;1;1;HI;1
+12 ;;CC REIMB INS;CC REIMB INS;;CC REIM;1;51;i;1;1;1;HI;1
+13 ;;CCN REIMB INS;CCN REIMB INS;;CCN REIM;1;52;i;1;1;1;HI;1
+14 ;;CC MTF REIMB INS;CC MTF REIMB INS;;CCD REIM;1;53;i;1;1;1;HI;1
+15 ;;DOD DISABILITY EVALUATION;DOD DISABILITY EVALUATION;;TR IDES;1;77;i;1;1;1;HI;1
+16 ;;DOD SPINAL CORD INJURY;DOD SPINAL CORD INJURY;;TRSPINAL;1;78;i;1;1;1;HI;1
+17 ;;DOD TRAUMATIC BRAIN INJURY;DOD TRAUMATIC BRAIN INJURY;;TR TBI;1;79;i;1;1;1;HI;1
+18 ;;DOD BLIND REHABILITATION;DOD BLIND REHABILITATION;;TRREHAB;1;80;i;1;1;1;HI;1
+19 ;;TRICARE DENTAL;TRICARE DENTAL;;TR DENTAL;1;81;i;1;1;1;HI;1
+20 ;;TRICARE PHARMACY;TRICARE PHARMACY;;TR RX;1;82;i;1;1;1;HI;1
+21 ;;END
+22 ;
RTUPD ; Update the FEE REIMB INS entry in the Rate Type File (399.3) to inactivate
+1 NEW LIEN,X,Y,DIE,DA,DR,DTOUT,DATA
+2 ;
+3 DO MES^XPDUTL(" -> Inactivating the FEE REIMB INS Rate Type...")
+4 SET LIEN=$ORDER(^DGCR(399.3,"B","FEE REIMB INS",""))
+5 if 'LIEN
QUIT
+6 ; File the update
+7 SET DR=".03////1;"
+8 SET DIE="^DGCR(399.3,"
SET DA=LIEN
+9 DO ^DIE
+10 ;
+11 QUIT
ADDRS ; Add Rate Schedules (363) for FEE REIMB INS
+1 DO MES^XPDUTL(" -> Adding new Rate Schedules to file 363 ...")
+2 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBCNTCS,IBDISP,IBJ,IBLNCS,IBCS,IBCSFN,IBADMIN,DD,DO
+3 NEW DLAYGO,DIC,DIE,DA,DR,RXDT,X,Y,IBCPNM,IBEDT
+4 SET IBCNT=0
+5 FOR IBI=2:1
SET IBLN=$PIECE($TEXT(RSF+IBI),";;",2)
if IBLN="END"
QUIT
IF $EXTRACT(IBLN)?1A
Begin DoDot:1
+6 ;Check for problems
+7 ;Billable service invalid
SET IBBS=$PIECE(IBLN,U,4)
IF IBBS'=""
SET IBBS=$$MCCRUTL(IBBS,13)
if 'IBBS
QUIT
+8 SET IBRT=$PIECE(IBLN,U,2)
SET IBRT=$ORDER(^DGCR(399.3,"B",IBRT,0))
Begin DoDot:2
+9 IF 'IBRT
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not defined, RS "_$PIECE(IBLN,U,1)_" not created")
+10 IF +$PIECE($GET(^DGCR(399.3,+IBRT,0)),U,3)
SET IBRT=0
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not Active, RS "_$PIECE(IBLN,U,1)_" not created")
End DoDot:2
if 'IBRT
QUIT
+11 ;No problems found, so create entry
+12 KILL DD,DO
+13 SET DLAYGO=363
SET DIC="^IBE(363,"
SET DIC(0)="L"
SET X=$PIECE(IBLN,U,1)
+14 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+15 IF Y<1
KILL X,Y
QUIT
+16 SET IBFN=+Y
SET IBCNT=IBCNT+1
+17 SET IBCPNM=$PIECE(IBLN,U,5)
SET IBEDT=$PIECE(IBLN,U,6)
+18 SET RXDT=$$RXDT(IBCPNM,IBEDT)
+19 SET DR=".02////"_IBRT_";.03////"_$PIECE(IBLN,U,3)
IF +IBBS
SET DR=DR_";.04////"_IBBS
+20 SET DR=DR_";.05////"_$PIECE(RXDT,U)
+21 IF $PIECE(RXDT,U,2)
SET DR=DR_";.06////"_$PIECE(RXDT,U,2)
+22 IF ($PIECE(IBLN,U,1)["RX")
IF ($GET(IBDISP)]"")
SET DR=DR_";1.01///"_IBDISP
+23 IF ($PIECE(IBLN,U,1)["RX")
IF ($GET(IBADMIN)]"")
SET DR=DR_";1.02////"_IBADMIN
+24 SET DIE="^IBE(363,"
SET DA=+Y
DO ^DIE
KILL DIE,DA,DR,X,Y
+25 SET IBCNTCS=0
+26 ; Retrieve name of Charge Set to copy
+27 IF IBRT=""
DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" missing Charge Set Information, RS "_$PIECE(IBLN,U,1)_" not created")
QUIT
+28 ; add all Reasonable Charges Charge Sets to the Rate Schedule.
+29 SET IBCNTCS=$$RSCS(IBFN,IBCPNM,$PIECE(RXDT,U))
+30 DO MES^XPDUTL(" Total Reasonable Charge Set"_$SELECT(IBCNTCS=1:" ",1:"s ")_IBCNTCS_" added to Rate Schedule "_$PIECE(IBLN,U,1)_".")
End DoDot:1
+31 DO MES^XPDUTL(" Rate Schedules completed.")
+32 ;ADDRS
QUIT
+33 ;
RSCS(IBFN,IBCPNM,RXDT) ; add existing Charge Sets to FR
+1 ; copy the Charge Sets from the corresponding RI RS (v2)
+2 ; IBFN - Rate Schedule IEN
+3 ; IBCPNM - Charge Set to copy
+4 ; RXDT - last effective date of charge set being copied.
+5 NEW IBCNT,IBNRS,IBRSNM,IBTY,IBVDT,IBCOPY,IBCS,IBCS0,IBXFN,IBCSFN,IBCSNM,IBCSAA,IBNAME
+6 SET (IBCNT,IBCOPY)=0
+7 SET IBNRS=$GET(^IBE(363,+$GET(IBFN),0))
SET IBRSNM=$PIECE(IBNRS,"^",1)
+8 SET IBTY=$PIECE(IBNRS,"^",3)
+9 SET IBVDT=RXDT
+10 if IBVDT=""
QUIT 0
+11 SET IBCOPY=+$$RSEXISTS(IBVDT,IBCPNM)
+12 IF 'IBCOPY
GOTO RSCSQ
+13 IF +$PIECE($GET(^IBE(363,+IBCOPY,0)),U,3)=IBTY
Begin DoDot:1
+14 SET IBXFN=0
FOR
SET IBXFN=$ORDER(^IBE(363,IBCOPY,11,IBXFN))
if 'IBXFN
QUIT
Begin DoDot:2
+15 SET IBCS=$GET(^IBE(363,IBCOPY,11,IBXFN,0))
SET IBCSFN=+IBCS
+16 IF +$$RSCSFILE(IBFN,$PIECE($GET(^IBE(363.1,IBCSFN,0)),U,1),$PIECE(IBCS,U,2))
SET IBCNT=IBCNT+1
End DoDot:2
End DoDot:1
RSCSQ QUIT IBCNT
+1 ;
+2 ;
RSCSFILE(IBFN,IBCSNM,IBCSAA) ; Add Charge Set to a Rate Schedule
+1 NEW IBX,DD,DO,DLAYGO,DIC,DA,DR,X,Y,IBCSFN
SET IBX=0
+2 IF $GET(^IBE(363,+$GET(IBFN),0))=""
GOTO RSCSFQ
+3 IF $GET(IBCSNM)=""
GOTO RSCSFQ
+4 SET IBCSFN=$ORDER(^IBE(363.1,"B",IBCSNM,0))
IF 'IBCSFN
GOTO RSCSFQ
+5 IF $ORDER(^IBE(363,IBFN,11,"B",IBCSFN,0))
GOTO RSCSFQ
+6 SET DLAYGO=363
SET DA(1)=+IBFN
SET DIC="^IBE(363,"_DA(1)_",11,"
SET DIC(0)="L"
+7 SET X=IBCSNM
SET DIC("DR")=".02///"_$GET(IBCSAA)
SET DIC("P")="363.0011P"
+8 DO ^DIC
if +Y
SET IBX=1
RSCSFQ QUIT IBX
+1 ;
+2 ;
RSEXISTS(IBVDT,IBNAME) ; return RS IFN if Rate Schedule exists for Effective Date
+1 NEW IBX,IBRSFN,IBRS0
SET IBX=0
+2 SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+3 SET IBRS0=$GET(^IBE(363,IBRSFN,0))
+4 IF $PIECE(IBRS0,U,1)=IBNAME
IF $PIECE(IBRS0,U,5)=IBVDT
SET IBX=IBRSFN
End DoDot:1
IF IBX
QUIT
+5 QUIT IBX
+6 ;
MSG(X) ;
+1 NEW IBX
SET IBX=$ORDER(IBA(999999),-1)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=$GET(X)
+3 ;MSG
QUIT
+4 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+3 QUIT IBY
+4 ;
RXDT(IBCPNM,IBEDT) ;Copy the active charge schedule from charge set being copied.
+1 ; update Fee information if Pharmacy.
+2 NEW IBEFLG,IBD
+3 ; Set to NULL if not passed in
SET IBEDT=$GET(IBEDT)
+4 SET IBCS=""
+5 ;If no Effective Date sent, get the latest entry.
+6 IF IBEDT=""
SET IBCS=$ORDER(^IBE(363,"B",IBCPNM,IBCS),-1)
+7 ;If Effective date sent, loop through the entries to find the entry
+8 ; with the correct effective date.
+9 IF IBEDT'=""
Begin DoDot:1
+10 SET IBEFLG=0
+11 FOR
SET IBCS=$ORDER(^IBE(363,"B",IBCPNM,IBCS),-1)
if 'IBCS
QUIT
Begin DoDot:2
+12 SET IBD=$GET(^IBE(363,IBCS,0))
+13 IF $PIECE(IBD,U,5)=IBEDT
SET IBEFLG=1
End DoDot:2
if IBEFLG
QUIT
End DoDot:1
+14 if IBCS=""
QUIT ""
+15 SET IBCS0=^IBE(363,IBCS,0)
+16 IF IBCPNM["RX"
SET IBDISP=$PIECE($GET(^IBE(363,IBCS,1)),U,1)
SET IBADMIN=$GET(^IBE(363,IBCS,10))
+17 ;return effective and end dates
QUIT $PIECE(IBCS0,U,5,6)
+18 ;
RSF ;Rate Schedules (363) for the new Community Care Rate Types.
+1 ;;Rate Schedule Name^Rate Type^Bill Type^Billable Service^Rate Schedule to copy for Charge Sets
+2 ;;CCC-NF-INPT^CHOICE NO-FAULT AUTO^1^^NF-INPT
+3 ;;CCC-NF-SNF^CHOICE NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
+4 ;;CCC-NF-OPT^CHOICE NO-FAULT AUTO^3^^NF-OPT
+5 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3140101
+6 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3150101
+7 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3160101
+8 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3170101
+9 ;;CCC-NF-RX^CHOICE NO-FAULT AUTO^3^^NF-RX^3180101
+10 ;;CC-NF-INPT^CC NO-FAULT AUTO^1^^NF-INPT
+11 ;;CC-NF-SNF^CC NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
+12 ;;CC-NF-OPT^CC NO-FAULT AUTO^3^^NF-OPT
+13 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3140101
+14 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3150101
+15 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3160101
+16 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3170101
+17 ;;CC-NF-RX^CC NO-FAULT AUTO^3^^NF-RX^3180101
+18 ;;CCN-NF-INPT^CCN NO-FAULT AUTO^1^^NF-INPT
+19 ;;CCN-NF-SNF^CCN NO-FAULT AUTO^1^SKILLED NURSING^NF-SNF
+20 ;;CCN-NF-OPT^CCN NO-FAULT AUTO^3^^NF-OPT
+21 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3140101
+22 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3150101
+23 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3160101
+24 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3170101
+25 ;;CCN-NF-RX^CCN NO-FAULT AUTO^3^^NF-RX^3180101
+26 ;;CCC-RI-INPT^CHOICE REIMB INS^1^^RI-INPT
+27 ;;CCC-RI-SNF^CHOICE REIMB INS^1^SKILLED NURSING^RI-SNF
+28 ;;CCC-RI-OPT^CHOICE REIMB INS^3^^RI-OPT
+29 ;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3140101
+30 ;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3150101
+31 ;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3160101
+32 ;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3170101
+33 ;;CCC-RI-RX^CHOICE REIMB INS^3^^RI-RX^3180101
+34 ;;CC-RI-INPT^CC REIMB INS^1^^RI-INPT
+35 ;;CC-RI-SNF^CC REIMB INS^1^SKILLED NURSING^RI-SNF
+36 ;;CC-RI-OPT^CC REIMB INS^3^^RI-OPT
+37 ;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3140101
+38 ;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3150101
+39 ;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3160101
+40 ;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3170101
+41 ;;CC-RI-RX^CC REIMB INS^3^^RI-RX^3180101
+42 ;;CCN-RI-INPT^CCN REIMB INS^1^^RI-INPT
+43 ;;CCN-RI-SNF^CCN REIMB INS^1^SKILLED NURSING^RI-SNF
+44 ;;CCN-RI-OPT^CCN REIMB INS^3^^RI-OPT
+45 ;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3140101
+46 ;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3150101
+47 ;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3160101
+48 ;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3170101
+49 ;;CCN-RI-RX^CCN REIMB INS^3^^RI-RX^3180101
+50 ;;CC-DOD-INPT^CC MTF REIMB INS^1^INPATIENT^RI-INPT
+51 ;;CC-DOD-SNF^CC MTF REIMB INS^1^SKILLED NURSING^RI-SNF
+52 ;;CC-DOD-OPT^CC MTF REIMB INS^3^OUTPATIENT VISIT^RI-OPT
+53 ;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3140101
+54 ;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3150101
+55 ;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3160101
+56 ;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3170101
+57 ;;CC-DOD-RX^CC MTF REIMB INS^3^^RI-RX^3180101
+58 ;;CCC-TF-INPT^CHOICE TORT FEASOR^1^^TF-INPT
+59 ;;CCC-TF-SNF^CHOICE TORT FEASOR^1^SKILLED NURSING^TF-SNF
+60 ;;CCC-TF-OPT^CHOICE TORT FEASOR^3^^TF-OPT
+61 ;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3140101
+62 ;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3150101
+63 ;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3160101
+64 ;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3170101
+65 ;;CCC-TF-RX^CHOICE TORT FEASOR^3^^TF-RX^3180101
+66 ;;CC-TF-INPT^CC TORT FEASOR^1^^TF-INPT
+67 ;;CC-TF-SNF^CC TORT FEASOR^1^SKILLED NURSING^TF-SNF
+68 ;;CC-TF-OPT^CC TORT FEASOR^3^^TF-OPT
+69 ;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3140101
+70 ;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3150101
+71 ;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3160101
+72 ;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3170101
+73 ;;CC-TF-RX^CC TORT FEASOR^3^^TF-RX^3180101
+74 ;;CCN-TF-INPT^CCN TORT FEASOR^1^^TF-INPT
+75 ;;CCN-TF-SNF^CCN TORT FEASOR^1^SKILLED NURSING^TF-SNF
+76 ;;CCN-TF-OPT^CCN TORT FEASOR^3^^TF-OPT
+77 ;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3140101
+78 ;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3150101
+79 ;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3160101
+80 ;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3170101
+81 ;;CCN-TF-RX^CCN TORT FEASOR^3^^TF-RX^3180101
+82 ;;CCC-WC-INPT^CHOICE WORKERS' COMP^1^^WC-INPT
+83 ;;CCC-WC-SNF^CHOICE WORKERS' COMP^1^SKILLED NURSING^WC-SNF
+84 ;;CCC-WC-OPT^CHOICE WORKERS' COMP^3^^WC-OPT
+85 ;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3140101
+86 ;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3150101
+87 ;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3160101
+88 ;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3170101
+89 ;;CCC-WC-RX^CHOICE WORKERS' COMP^3^^WC-RX^3180101
+90 ;;CC-WC-INPT^CC WORKERS' COMP^1^^WC-INPT
+91 ;;CC-WC-SNF^CC WORKERS' COMP^1^SKILLED NURSING^WC-SNF
+92 ;;CC-WC-OPT^CC WORKERS' COMP^3^^WC-OPT
+93 ;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3140101
+94 ;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3150101
+95 ;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3160101
+96 ;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3170101
+97 ;;CC-WC-RX^CC WORKERS' COMP^3^^WC-RX^3180101
+98 ;;CCN-WC-INPT^CCN WORKERS' COMP^1^^WC-INPT
+99 ;;CCN-WC-SNF^CCN WORKERS' COMP^1^SKILLED NURSING^WC-SNF
+100 ;;CCN-WC-OPT^CCN WORKERS' COMP^3^^WC-OPT
+101 ;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3140101
+102 ;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3150101
+103 ;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3160101
+104 ;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3170101
+105 ;;CCN-WC-RX^CCN WORKERS' COMP^3^^WC-RX^3180101
+106 ;;DOD-DIS EXAM-OPT^DOD DISABILITY EVALUATION^3^OUTPATIENT VISIT^RI-OPT
+107 ;;DOD-SCI-INPT^DOD SPINAL CORD INJURY^1^INPATIENT^RI-INPT
+108 ;;DOD-SCI-OPT^DOD SPINAL CORD INJURY^3^OUTPATIENT VISIT^RI-OPT
+109 ;;DOD-SCI-SNF^DOD SPINAL CORD INJURY^1^SKILLED NURSING^RI-SNF
+110 ;;DOD-TBI-INPT^DOD TRAUMATIC BRAIN INJURY^1^INPATIENT^RI-INPT
+111 ;;DOD-TBI-OPT^DOD TRAUMATIC BRAIN INJURY^3^OUTPATIENT VISIT^RI-OPT
+112 ;;DOD-TBI-SNF^DOD TRAUMATIC BRAIN INJURY^1^SKILLED NURSING^RI-SNF
+113 ;;DOD-BR-INPT^DOD BLIND REHABILITATION^1^INPATIENT^RI-INPT
+114 ;;DOD-BR-OPT^DOD BLIND REHABILITATION^3^OUTPATIENT VISIT^RI-OPT
+115 ;;DOD-BR-SNF^DOD BLIND REHABILITATION^1^SKILLED NURSING^RI-SNF
+116 ;;TR-DENTAL^TRICARE DENTAL^3^OUTPATIENT VISIT^RI-OPT
+117 ;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3140101
+118 ;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3150101
+119 ;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3160101
+120 ;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3170101
+121 ;;TR-PHARM^TRICARE PHARMACY^3^^RI-RX^3180101
+122 ;;END
+123 ;
