IB20P515 ;ALB/CXW - UPDATE MCCR UTILITY & REVENUE & POS ; 01/02/2013
;;2.0;INTEGRATED BILLING;**515**;21-MAR-94;Build 15
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
POST ;
; Update value/occurrence/condition codes in mccr utility file 399.1
; Update revenue codes in revenue code file 399.2
; Update pos code in place of service file 353.1
N U S U="^"
D MES^XPDUTL("Patch Post-Install starts")
D MCR,RVC,POS
D MES^XPDUTL("Patch Post-Install is complete.")
Q
;
MCR ; 3 types of codes
N IBCNT,IBCOD,IBPE,IBFD,IBFD2,IBI,IBX S IBFD2=""
; Value code flag in field #.18/piece 11
S IBCNT=0,IBPE=11,IBFD=.18
D MES^XPDUTL(" >>>Value Codes")
F IBI=1:1 S IBX=$P($T(VALU+IBI),";;",2) Q:IBX="" D MFILE
;
; Condition code flag in field #.22/piece 15
S IBPE=15,IBFD=.22
D MES^XPDUTL(" >>>Condition Codes")
F IBI=1:1 S IBX=$P($T(CONU+IBI),";;",2) Q:IBX="" D MFILE
;
; Occurrence span code flag in fields #.11/piece 4, #.17/piece 10
S IBPE=4,IBFD=.17,IBFD2=.11
D MES^XPDUTL(" >>>Occurrence Span Code")
F IBI=1:1 S IBX=$P($T(OCCPU+IBI),";;",2) Q:IBX="" D MFILE
;
D MES^XPDUTL("Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the MCCR Utility file (#399.1)")
D MES^XPDUTL("")
Q
;
MFILE ; store in mccr utility file
N IBFN,IBFLG,IBMS,IBX3,DLAYGO,DIC,DIE,DIK,DA,DD,DO,DR,X,Y
S IBMS="",IBFN=+$$EXCODE($P(IBX,U),IBPE),IBFLG=$P(IBX,U,3)
I 'IBFLG,'IBFN D
. K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBX,U,2) D FILE^DICN I Y<1 D MES^XPDUTL("Error: Unable to add "_$S(IBPE=11:"Value",IBPE=15:"Condition",1:"Occurrence Span")_" Code #"_$P(IBX,U)) Q
. S IBMS="added",DA=+Y,DIE=DIC,DR=".02///"_$P(IBX,U,1)_";"_IBFD_"///"_1 D ^DIE
I 'IBFLG,IBFN S IBX3=$G(^DGCR(399.1,IBFN,0)) D
. I $P(IBX3,U,1)=$P(IBX,U,2),$P(IBX3,U,2)=$P(IBX,U,1) Q
. S IBMS="updated",DIE="^DGCR(399.1,",DA=IBFN,DR=".01///"_$P(IBX,U,2) D ^DIE
I IBFLG,IBFN D
. S IBMS="removed",DIK="^DGCR(399.1,",DA=IBFN D ^DIK
I IBMS'="" S IBCNT=IBCNT+1 D MES^XPDUTL(" #"_$P(IBX,U)_" "_$P(IBX,U,2)_" "_IBMS)
Q
;
EXCODE(IBCOD,IBPE) ; Returns IEN if code found in the IBPE piece
N IBX,IBY S IBY=""
I $G(IBCOD)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"C",IBCOD,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(IBPE)) S IBY=IBX
Q IBY
;
RVC ; Revenue code in fields #1/piece 2, #3/piece 4
N IBCNT,IBFLG,IBRES,IBI,IBJ,IBX,IBY,IBZ,IBX3
S IBCNT=0,(IBX3,IBFLG)=""
D MES^XPDUTL(" >>>Revenue Codes")
F IBI=1:1 S IBX=$P($T(RVCU+IBI),";;",2) Q:IBX="" D
. S IBY=$P(IBX,U),IBFLG=$P(IBX,U,4)
. S IBZ=$O(^DGCR(399.2,"B",IBY,0)) Q:'IBZ
. S IBX3=$G(^DGCR(399.2,+IBZ,0))
. ; quit if being updated
. I $P(IBX3,U,2)=$P(IBX,U,2),$P(IBX3,U,4)=$P(IBX,U,3) Q
. D RFILE
;
S IBFLG=1 F IBI=1:1 S IBX=$P($T(RVCA+IBI),";;",2) Q:IBX="" D
. F IBJ=1:1 S IBY=$P(IBX,";",IBJ) Q:IBY="" D
.. S IBZ=$O(^DGCR(399.2,"B",IBY,0)) Q:'IBZ
.. S IBX3=$G(^DGCR(399.2,+IBZ,0))
.. ; quit if being reserved or activated
.. Q:$P(IBX3,U,2)="*RESERVED"
.. Q:+$P(IBX3,U,3)
.. S IBX3=$P(IBX3,U,4)
.. D RFILE
D MES^XPDUTL("Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the Revenue file (#399.2)")
D MES^XPDUTL("")
Q
;
RFILE ; Revenue file
N IBMS,DIE,DA,DD,DO,DR,X,Y S IBMS=""
I 'IBFLG S IBMS="updated",DR="1///"_$P(IBX,U,2)_";3///"_$P(IBX,U,3)_";2///1"
I IBFLG S IBMS="activated",DR="2///1"
S DIE="^DGCR(399.2,",DA=+IBZ D ^DIE
I IBMS'="" S IBCNT=IBCNT+1 D MES^XPDUTL(" #"_IBY_" "_$S(IBFLG=1:IBX3,1:$P(IBX,U,3))_" "_IBMS)
Q
;
POS ; Place Of Service in fields #.01/piece 1, #.02/piece 2, #.03/piece 3
N IBFLG,IBI,IBX,IBY,DA,DIK
S IBCNT=0
D MES^XPDUTL(" >>>Place of Service Code")
F IBI=1:1 S IBX=$P($T(POSU+IBI),";;",2) Q:IBX="" D
. S IBY=$P(IBX,U,1)
. S IBY=$O(^IBE(353.1,"B",$P(IBX,U,1),0)) Q:'IBY
. S IBFLG=$P(IBX,U,4) Q:'IBFLG
. S DIK="^IBE(353.1," S DA=+IBY D ^DIK
. S IBCNT=IBCNT+1 D MES^XPDUTL("#"_$P(IBX,U,1)_" "_$P(IBX,U,2)_" removed")
D MES^XPDUTL("Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the Place of Service file (#353.1)")
Q
;
RVCU ; Revenue code^abbreviation^name (1)
;;953^CHEMICAL DEPENDENCY (DRUG AND ALCOHOL)^CHEMICAL DEPENDENCY (DRUG AND ALCOHOL)
;
RVCA ; Revenue code delimited by semi-colon for activation (143)
;;022;110;111;112;113;114;115;116;117;118;119;120;121;122;123;124;125
;;126;127;128;129;130;131;132;133;134;135;136;137;138;140;141;142;143
;;144;145;146;147;148;149;150;151;152;153;154;155;156;157;158;159;175
;;180;183;185;189;201;202;249;253;254;256;261;262;263;269;280;289;291
;;293;314;319;330;339;349;379;380;390;391;400;409;422;423;429;432;433
;;434;439;449;469;550;559;599;600;602;603;604;621;624;630;661;680;700
;;710;739;769;779;789;790;815;816;817;829;830;832;833;839;840;841;842
;;843;849;850;852;853;859;880;890;891;892;893;899;911;919;925;941;944
;;945;949;961;969;972;983;988
;
VALU ; Value code^name^remove (9)
;;25^OFFSET TO THE PATIENT-PAYMENT AMOUN-PRESCRIPTION DRUGS
;;26^OFFSET TO THE PATIENT-PAYMENT AMOUNT-HEARING & EAR SERVICES
;;27^OFFSET TO THE PATIENT-PAYMENT AMOUNT-VISION & EYE SERVICES
;;28^OFFSET TO THE PATIENT-PAYMENT AMOUNT-DENTAL SERVICES
;;29^OFFSET TO THE PATIENT-PAYMENT AMOUNT-CHIROPRACTIC SERVICES
;;33^OFFSET TO THE PATIENT-PAYMENT AMOUNT-PODIATRIC SERVICES
;;34^OFFSET TO THE PATIENT-PAYMENT AMOUNT-OTHER MEDICAL SERVICES
;;84^LIFE TIME RESERVE AMOUNT IN THE THIRD GREATER CALENDAR YEAR^1
;;85^COINSURANCE AMOUNT IN THE THIRD OR GREATER CALENDAR YEAR^1
;
OCCPU ; Occurrence span code^name (1)
;;M0^QIO/UR APPROVED STAY DATES
;
CONU ; Condition code^name (3)
;;81^C-SECT/INDUCTIONS PERF AT LESS THAN 39 WKS GEST FOR MED NEC
;;82^C-SECT/INDUCTIONS PERF AT LESS THAN 39 WEEKS GEST ELECTIVELY
;;83^C-SECT/INDUCTIONS PERFORMED AT 39 WKS GESTATION OR GREATER
;
POSU ; Place of Service code^name^abbreviation^remove (1)
;;18^PLACE OF EMPLOYMENT/WORKSITE^PLACE OF EMPLOYMENT^1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P515 5954 printed Dec 13, 2024@02:03:24 Page 2
IB20P515 ;ALB/CXW - UPDATE MCCR UTILITY & REVENUE & POS ; 01/02/2013
+1 ;;2.0;INTEGRATED BILLING;**515**;21-MAR-94;Build 15
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
POST ;
+1 ; Update value/occurrence/condition codes in mccr utility file 399.1
+2 ; Update revenue codes in revenue code file 399.2
+3 ; Update pos code in place of service file 353.1
+4 NEW U
SET U="^"
+5 DO MES^XPDUTL("Patch Post-Install starts")
+6 DO MCR
DO RVC
DO POS
+7 DO MES^XPDUTL("Patch Post-Install is complete.")
+8 QUIT
+9 ;
MCR ; 3 types of codes
+1 NEW IBCNT,IBCOD,IBPE,IBFD,IBFD2,IBI,IBX
SET IBFD2=""
+2 ; Value code flag in field #.18/piece 11
+3 SET IBCNT=0
SET IBPE=11
SET IBFD=.18
+4 DO MES^XPDUTL(" >>>Value Codes")
+5 FOR IBI=1:1
SET IBX=$PIECE($TEXT(VALU+IBI),";;",2)
if IBX=""
QUIT
DO MFILE
+6 ;
+7 ; Condition code flag in field #.22/piece 15
+8 SET IBPE=15
SET IBFD=.22
+9 DO MES^XPDUTL(" >>>Condition Codes")
+10 FOR IBI=1:1
SET IBX=$PIECE($TEXT(CONU+IBI),";;",2)
if IBX=""
QUIT
DO MFILE
+11 ;
+12 ; Occurrence span code flag in fields #.11/piece 4, #.17/piece 10
+13 SET IBPE=4
SET IBFD=.17
SET IBFD2=.11
+14 DO MES^XPDUTL(" >>>Occurrence Span Code")
+15 FOR IBI=1:1
SET IBX=$PIECE($TEXT(OCCPU+IBI),";;",2)
if IBX=""
QUIT
DO MFILE
+16 ;
+17 DO MES^XPDUTL("Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the MCCR Utility file (#399.1)")
+18 DO MES^XPDUTL("")
+19 QUIT
+20 ;
MFILE ; store in mccr utility file
+1 NEW IBFN,IBFLG,IBMS,IBX3,DLAYGO,DIC,DIE,DIK,DA,DD,DO,DR,X,Y
+2 SET IBMS=""
SET IBFN=+$$EXCODE($PIECE(IBX,U),IBPE)
SET IBFLG=$PIECE(IBX,U,3)
+3 IF 'IBFLG
IF 'IBFN
Begin DoDot:1
+4 KILL DD,DO
SET DLAYGO=399.1
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=$PIECE(IBX,U,2)
DO FILE^DICN
IF Y<1
DO MES^XPDUTL("Error: Unable to add "_$SELECT(IBPE=11:"Value",IBPE=15:"Condition",1:"Occurrence Span")_" Code #"_$PIECE(IBX,U))
QUIT
+5 SET IBMS="added"
SET DA=+Y
SET DIE=DIC
SET DR=".02///"_$PIECE(IBX,U,1)_";"_IBFD_"///"_1
DO ^DIE
End DoDot:1
+6 IF 'IBFLG
IF IBFN
SET IBX3=$GET(^DGCR(399.1,IBFN,0))
Begin DoDot:1
+7 IF $PIECE(IBX3,U,1)=$PIECE(IBX,U,2)
IF $PIECE(IBX3,U,2)=$PIECE(IBX,U,1)
QUIT
+8 SET IBMS="updated"
SET DIE="^DGCR(399.1,"
SET DA=IBFN
SET DR=".01///"_$PIECE(IBX,U,2)
DO ^DIE
End DoDot:1
+9 IF IBFLG
IF IBFN
Begin DoDot:1
+10 SET IBMS="removed"
SET DIK="^DGCR(399.1,"
SET DA=IBFN
DO ^DIK
End DoDot:1
+11 IF IBMS'=""
SET IBCNT=IBCNT+1
DO MES^XPDUTL(" #"_$PIECE(IBX,U)_" "_$PIECE(IBX,U,2)_" "_IBMS)
+12 QUIT
+13 ;
EXCODE(IBCOD,IBPE) ; Returns IEN if code found in the IBPE piece
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(IBCOD)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"C",IBCOD,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(IBPE))
SET IBY=IBX
+3 QUIT IBY
+4 ;
RVC ; Revenue code in fields #1/piece 2, #3/piece 4
+1 NEW IBCNT,IBFLG,IBRES,IBI,IBJ,IBX,IBY,IBZ,IBX3
+2 SET IBCNT=0
SET (IBX3,IBFLG)=""
+3 DO MES^XPDUTL(" >>>Revenue Codes")
+4 FOR IBI=1:1
SET IBX=$PIECE($TEXT(RVCU+IBI),";;",2)
if IBX=""
QUIT
Begin DoDot:1
+5 SET IBY=$PIECE(IBX,U)
SET IBFLG=$PIECE(IBX,U,4)
+6 SET IBZ=$ORDER(^DGCR(399.2,"B",IBY,0))
if 'IBZ
QUIT
+7 SET IBX3=$GET(^DGCR(399.2,+IBZ,0))
+8 ; quit if being updated
+9 IF $PIECE(IBX3,U,2)=$PIECE(IBX,U,2)
IF $PIECE(IBX3,U,4)=$PIECE(IBX,U,3)
QUIT
+10 DO RFILE
End DoDot:1
+11 ;
+12 SET IBFLG=1
FOR IBI=1:1
SET IBX=$PIECE($TEXT(RVCA+IBI),";;",2)
if IBX=""
QUIT
Begin DoDot:1
+13 FOR IBJ=1:1
SET IBY=$PIECE(IBX,";",IBJ)
if IBY=""
QUIT
Begin DoDot:2
+14 SET IBZ=$ORDER(^DGCR(399.2,"B",IBY,0))
if 'IBZ
QUIT
+15 SET IBX3=$GET(^DGCR(399.2,+IBZ,0))
+16 ; quit if being reserved or activated
+17 if $PIECE(IBX3,U,2)="*RESERVED"
QUIT
+18 if +$PIECE(IBX3,U,3)
QUIT
+19 SET IBX3=$PIECE(IBX3,U,4)
+20 DO RFILE
End DoDot:2
End DoDot:1
+21 DO MES^XPDUTL("Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the Revenue file (#399.2)")
+22 DO MES^XPDUTL("")
+23 QUIT
+24 ;
RFILE ; Revenue file
+1 NEW IBMS,DIE,DA,DD,DO,DR,X,Y
SET IBMS=""
+2 IF 'IBFLG
SET IBMS="updated"
SET DR="1///"_$PIECE(IBX,U,2)_";3///"_$PIECE(IBX,U,3)_";2///1"
+3 IF IBFLG
SET IBMS="activated"
SET DR="2///1"
+4 SET DIE="^DGCR(399.2,"
SET DA=+IBZ
DO ^DIE
+5 IF IBMS'=""
SET IBCNT=IBCNT+1
DO MES^XPDUTL(" #"_IBY_" "_$SELECT(IBFLG=1:IBX3,1:$PIECE(IBX,U,3))_" "_IBMS)
+6 QUIT
+7 ;
POS ; Place Of Service in fields #.01/piece 1, #.02/piece 2, #.03/piece 3
+1 NEW IBFLG,IBI,IBX,IBY,DA,DIK
+2 SET IBCNT=0
+3 DO MES^XPDUTL(" >>>Place of Service Code")
+4 FOR IBI=1:1
SET IBX=$PIECE($TEXT(POSU+IBI),";;",2)
if IBX=""
QUIT
Begin DoDot:1
+5 SET IBY=$PIECE(IBX,U,1)
+6 SET IBY=$ORDER(^IBE(353.1,"B",$PIECE(IBX,U,1),0))
if 'IBY
QUIT
+7 SET IBFLG=$PIECE(IBX,U,4)
if 'IBFLG
QUIT
+8 SET DIK="^IBE(353.1,"
SET DA=+IBY
DO ^DIK
+9 SET IBCNT=IBCNT+1
DO MES^XPDUTL("#"_$PIECE(IBX,U,1)_" "_$PIECE(IBX,U,2)_" removed")
End DoDot:1
+10 DO MES^XPDUTL("Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the Place of Service file (#353.1)")
+11 QUIT
+12 ;
RVCU ; Revenue code^abbreviation^name (1)
+1 ;;953^CHEMICAL DEPENDENCY (DRUG AND ALCOHOL)^CHEMICAL DEPENDENCY (DRUG AND ALCOHOL)
+2 ;
RVCA ; Revenue code delimited by semi-colon for activation (143)
+1 ;;022;110;111;112;113;114;115;116;117;118;119;120;121;122;123;124;125
+2 ;;126;127;128;129;130;131;132;133;134;135;136;137;138;140;141;142;143
+3 ;;144;145;146;147;148;149;150;151;152;153;154;155;156;157;158;159;175
+4 ;;180;183;185;189;201;202;249;253;254;256;261;262;263;269;280;289;291
+5 ;;293;314;319;330;339;349;379;380;390;391;400;409;422;423;429;432;433
+6 ;;434;439;449;469;550;559;599;600;602;603;604;621;624;630;661;680;700
+7 ;;710;739;769;779;789;790;815;816;817;829;830;832;833;839;840;841;842
+8 ;;843;849;850;852;853;859;880;890;891;892;893;899;911;919;925;941;944
+9 ;;945;949;961;969;972;983;988
+10 ;
VALU ; Value code^name^remove (9)
+1 ;;25^OFFSET TO THE PATIENT-PAYMENT AMOUN-PRESCRIPTION DRUGS
+2 ;;26^OFFSET TO THE PATIENT-PAYMENT AMOUNT-HEARING & EAR SERVICES
+3 ;;27^OFFSET TO THE PATIENT-PAYMENT AMOUNT-VISION & EYE SERVICES
+4 ;;28^OFFSET TO THE PATIENT-PAYMENT AMOUNT-DENTAL SERVICES
+5 ;;29^OFFSET TO THE PATIENT-PAYMENT AMOUNT-CHIROPRACTIC SERVICES
+6 ;;33^OFFSET TO THE PATIENT-PAYMENT AMOUNT-PODIATRIC SERVICES
+7 ;;34^OFFSET TO THE PATIENT-PAYMENT AMOUNT-OTHER MEDICAL SERVICES
+8 ;;84^LIFE TIME RESERVE AMOUNT IN THE THIRD GREATER CALENDAR YEAR^1
+9 ;;85^COINSURANCE AMOUNT IN THE THIRD OR GREATER CALENDAR YEAR^1
+10 ;
OCCPU ; Occurrence span code^name (1)
+1 ;;M0^QIO/UR APPROVED STAY DATES
+2 ;
CONU ; Condition code^name (3)
+1 ;;81^C-SECT/INDUCTIONS PERF AT LESS THAN 39 WKS GEST FOR MED NEC
+2 ;;82^C-SECT/INDUCTIONS PERF AT LESS THAN 39 WEEKS GEST ELECTIVELY
+3 ;;83^C-SECT/INDUCTIONS PERFORMED AT 39 WKS GESTATION OR GREATER
+4 ;
POSU ; Place of Service code^name^abbreviation^remove (1)
+1 ;;18^PLACE OF EMPLOYMENT/WORKSITE^PLACE OF EMPLOYMENT^1
+2 ;
