IB20P393 ;ALB/CXW - UPDATE MCCR UTILITY/REVENUE CODE; 06/18/08
;;2.0;INTEGRATED BILLING;**393**;21-MAR-94;Build 4
POST ;
N U S U="^"
D VAC,VACE,OSC,COC,COCE,RVC
Q
;
VAC ;New value codes in 399.1 (field .18/piece 11)
N DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y,IBI,IBX
D MES^XPDUTL("Adding Value Codes..")
F IBI=1:1 S IBX=$P($T(VACF+IBI),";;",2) Q:IBX="" I $E(IBX)'=" " D
. I +$$EXCODE($P(IBX,U,1),11) Q
. K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBX,U,2) D FILE^DICN K DIC,DLAYGO I Y<1 K X,Y Q
. S DA=+Y,DIE="^DGCR(399.1,",DR=".02////"_$P(IBX,U,1)_";.18////1;.19////"_$P(IBX,U,3) D ^DIE K DIE,DA,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,2))
Q
;
VACE ;Old value codes
N DIE,DA,DR,X,Y,IBI,IBX,IBFN
D MES^XPDUTL("Updating Value Codes..")
F IBI=1:1 S IBX=$P($T(VAOF+IBI),";;",2) Q:IBX="" I $E(IBX)'=" " D
. S IBFN=+$$EXCODE($P(IBX,U,1),11) Q:'IBFN
. S DIE="^DGCR(399.1,",DA=IBFN,DR=".01////"_$P(IBX,U,2) D ^DIE K DIE,DA,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,2))
D MES^XPDUTL("")
Q
;
OSC ;Occurrence span codes in 399.1 (field .17/piece 10)
N DIE,DA,DR,X,Y,IBI,IBX,IBFN
D MES^XPDUTL("Updating Occurrence Span Code..")
F IBI=1:1 S IBX=$P($T(OSCF+IBI),";;",2) Q:IBX="" I $E(IBX)'=" " D
. S IBFN=+$$EXCODE($P(IBX,U,1),10) Q:'IBFN
. S DIE="^DGCR(399.1,",DA=IBFN,DR=".01////"_$P(IBX,U,2) D ^DIE K DIE,DA,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,2))
D MES^XPDUTL("")
Q
;
COC ;New condition codes in file 399.1 (field .22/piece 15)
N DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y,IBI,IBX
D MES^XPDUTL("Adding Condition Codes..")
F IBI=1:1 S IBX=$P($T(CONF+IBI),";;",2) Q:IBX="" I $E(IBX)'=" " D
. I +$$EXCODE($P(IBX,U,1),15) Q
. K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBX,U,2) D FILE^DICN K DIC,DLAYGO I Y<1 K X,Y Q
. S DA=+Y,DIE="^DGCR(399.1,",DR=".02////"_$P(IBX,U,1)_";.22////"_1 D ^DIE K DIE,DA,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,2))
Q
;
COCE ;Old condition codes
N DIE,DA,DR,X,Y,IBI,IBX,IBFN
D MES^XPDUTL("Updating Condition Codes..")
F IBI=1:1 S IBX=$P($T(COOF+IBI),";;",2) Q:IBX="" I $E(IBX)'=" " D
. S IBFN=+$$EXCODE($P(IBX,U,1),15) Q:'IBFN
. S DIE="^DGCR(399.1,",DA=IBFN,DR=".01////"_$P(IBX,U,2) D ^DIE K DIE,DA,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,2))
D MES^XPDUTL("")
Q
;
EXCODE(X,P) ;returns IEN if code found in the P piece
N IBX,IBY S IBY=""
I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"C",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
Q IBY
;
RVC ;New revenue codes in file 399.2
N IBI,IBX,IBY,IBZ,DIE,DA,DR,X,Y
D MES^XPDUTL("Adding Revenue Codes..")
F IBI=1:1 S IBX=$P($T(RVCF+IBI),";;",2) Q:IBX="" I $E(IBX)'=" " D
. S IBY=$P(IBX,U,1),IBZ=$G(^DGCR(399.2,+IBY,0)) Q:(+IBY'=+IBZ)!($P(IBZ,U,2)'="*RESERVED")
. S DA=+IBY,DIE="^DGCR(399.2,",DR="1////"_$P(IBX,U,2)_";3////"_$P(IBX,U,3) D ^DIE K DA,DIE,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,3))
D MES^XPDUTL("")
Q
;
RVCF ; - new revenue codes
;;343^DX/RADIOPHARMACEUTICALS^DIAGNOSTIC RADIOPHARMACEUTICALS
;;344^RX/RADIOPHARMACEUTICALS^THERAPEUTIC RADIOPHARMACEUTICALS
;;524^RHC/FQHC PRACTITIONER COVERED VISIT^RHC/FQHC PRACTITIONER COVERED VISIT AT SNF
;;525^RHC/FQHC PRACTITIONER NOT COVERED VISIT^RHC/FQHC PRACTITIONER NOT COVERED SNF/NF/RF VISIT
;;527^RHC/FQHC VISITING NURSE SVS^NURSE SVS TO MEMBER HOME IN SHORTAGE AREA VISIT
;;528^RHC/FQHC PRACTITIONER IN OTHER VISIT^NON RHC/FQHC SITE VISIT
;;583^ASSESSMENT^VISIT/HOME HLTH ASSESSMENT
;;658^NURSING FACILITY^HOSPICE ROOM & BOARD
;;663^DAILY RESPITE CHARGE^DAILY RESPITE CHARGE
;;680^TRAUMA RESPONSE^GENERAL CLASSIFICATION
;;681^TRA/RES LEVEL I^TRAUMA RESPONSE LEVEL I
;;682^TRA/RES LEVEL II^TRAUMA RESPONSE LEVEL II
;;683^TRA/RES LEVEL III^TRAUMA RESPONSE LEVEL III
;;684^TRA/RES LEVEL IV^TRAUMA RESPONSE LEVEL IV
;;689^TRA/RES OTHER^TRAUMA RESPONSE OTHER
;;905^INTENSIVE OPT SVS-PSYCH^INTENSIVE OUTPATIENT SVS PSYCHIATRIC
;;906^INTENSIVE OPT SVS-CHEM/DEP^INTENSIVE OUTPATIENT SVS CHEMICAL DEPENDENCY
;;907^DAY TREATMENT^COMM BEHAVIORAL PROGRAM
;;930^MRDP^MEDICAL REHABILITATION DAY PROGRAM
;;931^MRDP HALF DAY^MRDP HALF DAY
;;932^MRDP FULL DAY^MRDP FULL DAY
;
VACF ; - new value codes
;;A8^PATIENT WEIGHT
;;A9^PATIENT HEIGHT
;;FC^PATIENT PAID AMOUNT^1
;;FD^CREDIT RECEVD FROM MANUFACTURER FOR REPLACED MEDICAL DEVICE^1
;
VAOF ; - old value codes
;;37^UNITS OF BLOOD FURNISHED
;;38^BLOOD DEDUCTIBLE UNITS
;;39^UNITS OF BLOOD REPLACED
;
OSCF ; - old occurrence span code
;;80^PRIOR SAME-SNF STAY DATES FOR PAYMENT BAN PURPOSES
;
CONF ; - new condition codes
;;49^PRODUCT REPLACEMENT WITHIN PRODUCT LIFECYCLE
;;50^PRODUCT REPLACEMENT FOR KNOWN RECALL OF A PRODUCT
;;H2^DISCHARGE BY A HOSPICE PROVIDER FOR CAUSE
;
COOF ; - old condition codes
;;D2^CHANGES IN REVENUE CODES/HCPCS/HIPPS RATE CODES
;;D4^CHANGE IN CLINICAL CODES-ICD FOR DIAGNOSIS AND/OR PROCEDURE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P393 5045 printed Dec 13, 2024@02:02:34 Page 2
IB20P393 ;ALB/CXW - UPDATE MCCR UTILITY/REVENUE CODE; 06/18/08
+1 ;;2.0;INTEGRATED BILLING;**393**;21-MAR-94;Build 4
POST ;
+1 NEW U
SET U="^"
+2 DO VAC
DO VACE
DO OSC
DO COC
DO COCE
DO RVC
+3 QUIT
+4 ;
VAC ;New value codes in 399.1 (field .18/piece 11)
+1 NEW DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y,IBI,IBX
+2 DO MES^XPDUTL("Adding Value Codes..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(VACF+IBI),";;",2)
if IBX=""
QUIT
IF $EXTRACT(IBX)'=" "
Begin DoDot:1
+4 IF +$$EXCODE($PIECE(IBX,U,1),11)
QUIT
+5 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
KILL DIC,DLAYGO
IF Y<1
KILL X,Y
QUIT
+6 SET DA=+Y
SET DIE="^DGCR(399.1,"
SET DR=".02////"_$PIECE(IBX,U,1)_";.18////1;.19////"_$PIECE(IBX,U,3)
DO ^DIE
KILL DIE,DA,DR,X,Y
+7 DO MES^XPDUTL(" Code# "_$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,2))
End DoDot:1
+8 QUIT
+9 ;
VACE ;Old value codes
+1 NEW DIE,DA,DR,X,Y,IBI,IBX,IBFN
+2 DO MES^XPDUTL("Updating Value Codes..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(VAOF+IBI),";;",2)
if IBX=""
QUIT
IF $EXTRACT(IBX)'=" "
Begin DoDot:1
+4 SET IBFN=+$$EXCODE($PIECE(IBX,U,1),11)
if 'IBFN
QUIT
+5 SET DIE="^DGCR(399.1,"
SET DA=IBFN
SET DR=".01////"_$PIECE(IBX,U,2)
DO ^DIE
KILL DIE,DA,DR,X,Y
+6 DO MES^XPDUTL(" Code# "_$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,2))
End DoDot:1
+7 DO MES^XPDUTL("")
+8 QUIT
+9 ;
OSC ;Occurrence span codes in 399.1 (field .17/piece 10)
+1 NEW DIE,DA,DR,X,Y,IBI,IBX,IBFN
+2 DO MES^XPDUTL("Updating Occurrence Span Code..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(OSCF+IBI),";;",2)
if IBX=""
QUIT
IF $EXTRACT(IBX)'=" "
Begin DoDot:1
+4 SET IBFN=+$$EXCODE($PIECE(IBX,U,1),10)
if 'IBFN
QUIT
+5 SET DIE="^DGCR(399.1,"
SET DA=IBFN
SET DR=".01////"_$PIECE(IBX,U,2)
DO ^DIE
KILL DIE,DA,DR,X,Y
+6 DO MES^XPDUTL(" Code# "_$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,2))
End DoDot:1
+7 DO MES^XPDUTL("")
+8 QUIT
+9 ;
COC ;New condition codes in file 399.1 (field .22/piece 15)
+1 NEW DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y,IBI,IBX
+2 DO MES^XPDUTL("Adding Condition Codes..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(CONF+IBI),";;",2)
if IBX=""
QUIT
IF $EXTRACT(IBX)'=" "
Begin DoDot:1
+4 IF +$$EXCODE($PIECE(IBX,U,1),15)
QUIT
+5 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
KILL DIC,DLAYGO
IF Y<1
KILL X,Y
QUIT
+6 SET DA=+Y
SET DIE="^DGCR(399.1,"
SET DR=".02////"_$PIECE(IBX,U,1)_";.22////"_1
DO ^DIE
KILL DIE,DA,DR,X,Y
+7 DO MES^XPDUTL(" Code# "_$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,2))
End DoDot:1
+8 QUIT
+9 ;
COCE ;Old condition codes
+1 NEW DIE,DA,DR,X,Y,IBI,IBX,IBFN
+2 DO MES^XPDUTL("Updating Condition Codes..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(COOF+IBI),";;",2)
if IBX=""
QUIT
IF $EXTRACT(IBX)'=" "
Begin DoDot:1
+4 SET IBFN=+$$EXCODE($PIECE(IBX,U,1),15)
if 'IBFN
QUIT
+5 SET DIE="^DGCR(399.1,"
SET DA=IBFN
SET DR=".01////"_$PIECE(IBX,U,2)
DO ^DIE
KILL DIE,DA,DR,X,Y
+6 DO MES^XPDUTL(" Code# "_$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,2))
End DoDot:1
+7 DO MES^XPDUTL("")
+8 QUIT
+9 ;
EXCODE(X,P) ;returns IEN if code found in the P piece
+1 NEW IBX,IBY
SET IBY=""
+2 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"C",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+3 QUIT IBY
+4 ;
RVC ;New revenue codes in file 399.2
+1 NEW IBI,IBX,IBY,IBZ,DIE,DA,DR,X,Y
+2 DO MES^XPDUTL("Adding Revenue Codes..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(RVCF+IBI),";;",2)
if IBX=""
QUIT
IF $EXTRACT(IBX)'=" "
Begin DoDot:1
+4 SET IBY=$PIECE(IBX,U,1)
SET IBZ=$GET(^DGCR(399.2,+IBY,0))
if (+IBY'=+IBZ)!($PIECE(IBZ,U,2)'="*RESERVED")
QUIT
+5 SET DA=+IBY
SET DIE="^DGCR(399.2,"
SET DR="1////"_$PIECE(IBX,U,2)_";3////"_$PIECE(IBX,U,3)
DO ^DIE
KILL DA,DIE,DR,X,Y
+6 DO MES^XPDUTL(" Code# "_$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,3))
End DoDot:1
+7 DO MES^XPDUTL("")
+8 QUIT
+9 ;
RVCF ; - new revenue codes
+1 ;;343^DX/RADIOPHARMACEUTICALS^DIAGNOSTIC RADIOPHARMACEUTICALS
+2 ;;344^RX/RADIOPHARMACEUTICALS^THERAPEUTIC RADIOPHARMACEUTICALS
+3 ;;524^RHC/FQHC PRACTITIONER COVERED VISIT^RHC/FQHC PRACTITIONER COVERED VISIT AT SNF
+4 ;;525^RHC/FQHC PRACTITIONER NOT COVERED VISIT^RHC/FQHC PRACTITIONER NOT COVERED SNF/NF/RF VISIT
+5 ;;527^RHC/FQHC VISITING NURSE SVS^NURSE SVS TO MEMBER HOME IN SHORTAGE AREA VISIT
+6 ;;528^RHC/FQHC PRACTITIONER IN OTHER VISIT^NON RHC/FQHC SITE VISIT
+7 ;;583^ASSESSMENT^VISIT/HOME HLTH ASSESSMENT
+8 ;;658^NURSING FACILITY^HOSPICE ROOM & BOARD
+9 ;;663^DAILY RESPITE CHARGE^DAILY RESPITE CHARGE
+10 ;;680^TRAUMA RESPONSE^GENERAL CLASSIFICATION
+11 ;;681^TRA/RES LEVEL I^TRAUMA RESPONSE LEVEL I
+12 ;;682^TRA/RES LEVEL II^TRAUMA RESPONSE LEVEL II
+13 ;;683^TRA/RES LEVEL III^TRAUMA RESPONSE LEVEL III
+14 ;;684^TRA/RES LEVEL IV^TRAUMA RESPONSE LEVEL IV
+15 ;;689^TRA/RES OTHER^TRAUMA RESPONSE OTHER
+16 ;;905^INTENSIVE OPT SVS-PSYCH^INTENSIVE OUTPATIENT SVS PSYCHIATRIC
+17 ;;906^INTENSIVE OPT SVS-CHEM/DEP^INTENSIVE OUTPATIENT SVS CHEMICAL DEPENDENCY
+18 ;;907^DAY TREATMENT^COMM BEHAVIORAL PROGRAM
+19 ;;930^MRDP^MEDICAL REHABILITATION DAY PROGRAM
+20 ;;931^MRDP HALF DAY^MRDP HALF DAY
+21 ;;932^MRDP FULL DAY^MRDP FULL DAY
+22 ;
VACF ; - new value codes
+1 ;;A8^PATIENT WEIGHT
+2 ;;A9^PATIENT HEIGHT
+3 ;;FC^PATIENT PAID AMOUNT^1
+4 ;;FD^CREDIT RECEVD FROM MANUFACTURER FOR REPLACED MEDICAL DEVICE^1
+5 ;
VAOF ; - old value codes
+1 ;;37^UNITS OF BLOOD FURNISHED
+2 ;;38^BLOOD DEDUCTIBLE UNITS
+3 ;;39^UNITS OF BLOOD REPLACED
+4 ;
OSCF ; - old occurrence span code
+1 ;;80^PRIOR SAME-SNF STAY DATES FOR PAYMENT BAN PURPOSES
+2 ;
CONF ; - new condition codes
+1 ;;49^PRODUCT REPLACEMENT WITHIN PRODUCT LIFECYCLE
+2 ;;50^PRODUCT REPLACEMENT FOR KNOWN RECALL OF A PRODUCT
+3 ;;H2^DISCHARGE BY A HOSPICE PROVIDER FOR CAUSE
+4 ;
COOF ; - old condition codes
+1 ;;D2^CHANGES IN REVENUE CODES/HCPCS/HIPPS RATE CODES
+2 ;;D4^CHANGE IN CLINICAL CODES-ICD FOR DIAGNOSIS AND/OR PROCEDURE
+3 ;
