- 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 Feb 18, 2025@23:29:47 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 ;