IB20P443 ;ALB/CXW - UPDATE MCCR UTILITY/REVENUE CODE/PLACE OF SERVICE; 11/02/10
;;2.0;INTEGRATED BILLING;**443**;21-MAR-94;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
POST ;
N U S U="^"
D VAC,OUC,COC,COCE,RVC,POS
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 Code..")
F IBI=1:1 S IBX=$P($T(VACF+IBI),";;",2) Q: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 D ^DIE K DIE,DA,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,2))
D MES^XPDUTL("")
Q
OUC ;Update occurrence codes in file 399.1 (field .11/piece 4)
N DIE,DA,DR,X,Y,IBI,IBX,IBFN
D MES^XPDUTL("Updating Occurrence Code..")
F IBI=1:1 S IBX=$P($T(OUOF+IBI),";;",2) Q:IBX="" D
. S IBFN=+$$EXCODE($P(IBX,U,1),4) 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 Code..")
F IBI=1:1 S IBX=$P($T(CONF+IBI),";;",2) Q: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))
D MES^XPDUTL("")
Q
;
COCE ;Update condition codes
N DIE,DA,DR,X,Y,IBI,IBX,IBFN
D MES^XPDUTL("Updating Condition Code..")
F IBI=1:1 S IBX=$P($T(COOF+IBI),";;",2) Q: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 (fd 1/piece 2, fd 3/piece 4)
N IBI,IBX,IBY,IBZ,DIE,DA,DR,X,Y
D MES^XPDUTL("Adding Revenue Code..")
F IBI=1:1 S IBX=$P($T(RVCF+IBI),";;",2) Q: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
;
POS ;Update place of service in file 353.1 (fd .02/piece 2, fd .03/piece 3)
N IBI,IBX,IBY,IBZ,DIE,DA,DR,X,Y
D MES^XPDUTL("Updating Place of Service Code..")
F IBI=1:1 S IBX=$P($T(POSF+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 DA=+IBY,DIE="^IBE(353.1,",DR=".02///"_$P(IBX,U,2)_";.03///"_$P(IBX,U,3) D ^DIE K DA,DIE,DR,X,Y
. D MES^XPDUTL(" Code# "_$P(IBX,U,1)_" - "_$P(IBX,U,2))
D MES^XPDUTL("")
Q
;
RVCF ; - new revenue codes
;;392^PROCESSING AND STORAGE^PROCESSING AND STORAGE
;;860^MAGNETOENCEPHALOGRAHY (MEG)^GENERAL CLASSIFICATION
;;861^MEG^MAGNETOENCEPHALOGRAHY (MEG)
;;948^PULMONARY REHABILITATION^PULMONARY REHABILITATION
;
VACF ; - new value code
;;D5^LAST KT/V READING
;
OUOF ; - update occurrence codes
;;50^ASSESSMENT DATE
;;51^DATE OF LAST KT/V READING
;;52^MEDICAL CERTIFICATION/RECERTIFICATION DATE
;;54^PHYSICIAN FOLLOW-UP DATE
;
CONF ; - new condition codes
;;30^NON-RESEARCH SERV PROV TO PTS ENROLL IN QUAL CLINIC TRIAL
;;44^INPATIENT ADMISSION CHANGED TO OUTPATIENT
;;45^AMBIGUOUS GENDER CATEGORY
;;47^TRANSFER FROM ANOTHER HOME HEALTH AGENCY
;;59^NON-PRIMARY ESRD FACILITY
;;80^HOME DIALYSIS-NURSING FACILITY
;;AA^ABORTION PERFORMED DUE TO RAPE
;;AB^ABORTION PERFORMED DUE TO INCEST
;;AC^ABORT PERF DUE TO SERIOUS FETAL GENE DEFCT, DEFORM OR ABNORM
;;AD^ABORT PERF DUE TO LIFE ENDANGERING PHYSICAL CONDITION
;;AE^ABORT PERF DUE TO PHYS HLTH OF MOTHER THAT NOT LIFE ENDANGER
;;AF^ABORT PERF DUE TO EMOTIONAL/PSYCHOLOGICAL HLTH OF THE MOTHER
;;AG^ABORTION PERFORMED DUE TO SOCIAL OR ECONOMIC REASONS
;;AH^ELECTIVE ABORTION
;;AI^STERILIZATION
;;AJ^PAYER RESPONSIBLE FOR COPAYMENT
;;AK^AIR AMBULANCE REQUIRED
;;AL^SPECIALIZED TRMT/BED UNAVAILABLE-ALTERNATE FAC TRANSPORT
;;AM^NON-EMERGENCY MEDICALLY NECESSARY STRETCHER TRANSPORT REQ
;;AN^PREADMISSION SCREENING NOT REQUIRED
;;B4^ADMISSION UNRELATED TO DISCHARGE ON SAME DAY
;;P7^DIRECT INPATIENT ADMISSION FROM EMERGENCY ROOM
;;DR^DISASTER RELATED
;;H0^DELAYED FILING, STATEMENT OF INTENT SUBMITTED
;;H3^GI BLEED
;;H4^BACTERIAL PNEUMONIA
;;H5^PERICARDITIS
;;W2^DUPLICATE OF ORIGINAL BILL
;;W3^LEVEL I APPEAL
;;W4^LEVEL II APPEAL
;;W5^LEVEL III APPEAL
;
COOF ; - update condition codes
;;17^PATIENT IS HOMELESS
;;A7^RZD FOR NATIONAL ASSIGNMENT
;;A8^RZD FOR NATIONAL ASSIGNMENT
;;D4^CHANGE IN CLINICAL CODES (ICD) FOR DX AND/OR PROCEDURE CODES
;;D5^CANCEL TO CORRECT INSURED OR PROVIDER ID
;
POSF ; - update place of service code
;;99^OTHER PLACE OF SERVICE^OTHER PLACE OF SERV
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P443 5362 printed Apr 09, 2024@21:32:34 Page 2
IB20P443 ;ALB/CXW - UPDATE MCCR UTILITY/REVENUE CODE/PLACE OF SERVICE; 11/02/10
+1 ;;2.0;INTEGRATED BILLING;**443**;21-MAR-94;Build 9
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
POST ;
+1 NEW U
SET U="^"
+2 DO VAC
DO OUC
DO COC
DO COCE
DO RVC
DO POS
+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 Code..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(VACF+IBI),";;",2)
if IBX=""
QUIT
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
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 DO MES^XPDUTL("")
+9 QUIT
OUC ;Update occurrence codes in file 399.1 (field .11/piece 4)
+1 NEW DIE,DA,DR,X,Y,IBI,IBX,IBFN
+2 DO MES^XPDUTL("Updating Occurrence Code..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(OUOF+IBI),";;",2)
if IBX=""
QUIT
Begin DoDot:1
+4 SET IBFN=+$$EXCODE($PIECE(IBX,U,1),4)
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 Code..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(CONF+IBI),";;",2)
if IBX=""
QUIT
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 DO MES^XPDUTL("")
+9 QUIT
+10 ;
COCE ;Update condition codes
+1 NEW DIE,DA,DR,X,Y,IBI,IBX,IBFN
+2 DO MES^XPDUTL("Updating Condition Code..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(COOF+IBI),";;",2)
if IBX=""
QUIT
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 (fd 1/piece 2, fd 3/piece 4)
+1 NEW IBI,IBX,IBY,IBZ,DIE,DA,DR,X,Y
+2 DO MES^XPDUTL("Adding Revenue Code..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(RVCF+IBI),";;",2)
if IBX=""
QUIT
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 ;
POS ;Update place of service in file 353.1 (fd .02/piece 2, fd .03/piece 3)
+1 NEW IBI,IBX,IBY,IBZ,DIE,DA,DR,X,Y
+2 DO MES^XPDUTL("Updating Place of Service Code..")
+3 FOR IBI=1:1
SET IBX=$PIECE($TEXT(POSF+IBI),";;",2)
if IBX=""
QUIT
Begin DoDot:1
+4 SET IBY=$PIECE(IBX,U,1)
+5 SET IBY=$ORDER(^IBE(353.1,"B",$PIECE(IBX,U,1),0))
if 'IBY
QUIT
+6 SET DA=+IBY
SET DIE="^IBE(353.1,"
SET DR=".02///"_$PIECE(IBX,U,2)_";.03///"_$PIECE(IBX,U,3)
DO ^DIE
KILL DA,DIE,DR,X,Y
+7 DO MES^XPDUTL(" Code# "_$PIECE(IBX,U,1)_" - "_$PIECE(IBX,U,2))
End DoDot:1
+8 DO MES^XPDUTL("")
+9 QUIT
+10 ;
RVCF ; - new revenue codes
+1 ;;392^PROCESSING AND STORAGE^PROCESSING AND STORAGE
+2 ;;860^MAGNETOENCEPHALOGRAHY (MEG)^GENERAL CLASSIFICATION
+3 ;;861^MEG^MAGNETOENCEPHALOGRAHY (MEG)
+4 ;;948^PULMONARY REHABILITATION^PULMONARY REHABILITATION
+5 ;
VACF ; - new value code
+1 ;;D5^LAST KT/V READING
+2 ;
OUOF ; - update occurrence codes
+1 ;;50^ASSESSMENT DATE
+2 ;;51^DATE OF LAST KT/V READING
+3 ;;52^MEDICAL CERTIFICATION/RECERTIFICATION DATE
+4 ;;54^PHYSICIAN FOLLOW-UP DATE
+5 ;
CONF ; - new condition codes
+1 ;;30^NON-RESEARCH SERV PROV TO PTS ENROLL IN QUAL CLINIC TRIAL
+2 ;;44^INPATIENT ADMISSION CHANGED TO OUTPATIENT
+3 ;;45^AMBIGUOUS GENDER CATEGORY
+4 ;;47^TRANSFER FROM ANOTHER HOME HEALTH AGENCY
+5 ;;59^NON-PRIMARY ESRD FACILITY
+6 ;;80^HOME DIALYSIS-NURSING FACILITY
+7 ;;AA^ABORTION PERFORMED DUE TO RAPE
+8 ;;AB^ABORTION PERFORMED DUE TO INCEST
+9 ;;AC^ABORT PERF DUE TO SERIOUS FETAL GENE DEFCT, DEFORM OR ABNORM
+10 ;;AD^ABORT PERF DUE TO LIFE ENDANGERING PHYSICAL CONDITION
+11 ;;AE^ABORT PERF DUE TO PHYS HLTH OF MOTHER THAT NOT LIFE ENDANGER
+12 ;;AF^ABORT PERF DUE TO EMOTIONAL/PSYCHOLOGICAL HLTH OF THE MOTHER
+13 ;;AG^ABORTION PERFORMED DUE TO SOCIAL OR ECONOMIC REASONS
+14 ;;AH^ELECTIVE ABORTION
+15 ;;AI^STERILIZATION
+16 ;;AJ^PAYER RESPONSIBLE FOR COPAYMENT
+17 ;;AK^AIR AMBULANCE REQUIRED
+18 ;;AL^SPECIALIZED TRMT/BED UNAVAILABLE-ALTERNATE FAC TRANSPORT
+19 ;;AM^NON-EMERGENCY MEDICALLY NECESSARY STRETCHER TRANSPORT REQ
+20 ;;AN^PREADMISSION SCREENING NOT REQUIRED
+21 ;;B4^ADMISSION UNRELATED TO DISCHARGE ON SAME DAY
+22 ;;P7^DIRECT INPATIENT ADMISSION FROM EMERGENCY ROOM
+23 ;;DR^DISASTER RELATED
+24 ;;H0^DELAYED FILING, STATEMENT OF INTENT SUBMITTED
+25 ;;H3^GI BLEED
+26 ;;H4^BACTERIAL PNEUMONIA
+27 ;;H5^PERICARDITIS
+28 ;;W2^DUPLICATE OF ORIGINAL BILL
+29 ;;W3^LEVEL I APPEAL
+30 ;;W4^LEVEL II APPEAL
+31 ;;W5^LEVEL III APPEAL
+32 ;
COOF ; - update condition codes
+1 ;;17^PATIENT IS HOMELESS
+2 ;;A7^RZD FOR NATIONAL ASSIGNMENT
+3 ;;A8^RZD FOR NATIONAL ASSIGNMENT
+4 ;;D4^CHANGE IN CLINICAL CODES (ICD) FOR DX AND/OR PROCEDURE CODES
+5 ;;D5^CANCEL TO CORRECT INSURED OR PROVIDER ID
+6 ;
POSF ; - update place of service code
+1 ;;99^OTHER PLACE OF SERVICE^OTHER PLACE OF SERV
+2 ;
