IB20P242 ;WOIFO/SS-FY04 OPC COPAY IB*2.0*242 POST INIT ;10-SEP-03
;;2.0;INTEGRATED BILLING;**242**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
POST ;
I $$PATCH^XPDUTL("IB*2.0*242") D BMES^XPDUTL(" Skipping since the patch was previously installed.") Q
N X,Y,IBEFFDT
S IBEFFDT=3031001 ;effective date OCT 1, 2003
D START,FADD(IBEFFDT),FDESCR(IBEFFDT),FINISH
;
; FADD - add additional codes to file 352.5
; FDESCR - add description updates for codes to file 352.5
Q
;
START ;
D MESS(" FY04 OPC COPAY, Post-Install Starting")
Q
;
FINISH ;
D MESS(" FY04 OPC COPAY, Post-Install Complete")
Q
;
;add new entries in file 352.5
FADD(IBEFFDT) ;
N IBC,IBT,IBX,IBCODE,IBTYPE,IBOVER
D MESS(" Adding new codes to file 352.5")
S IBC=0
F IBX=1:1 S IBT=$P($T(ADDREG+IBX),";",3) Q:'$L(IBT) D
. S IBCODE=+$P(IBT,"^",1)
. S IBTYPE=$P(IBT,"^",3)
. S IBOVER=+$P(IBT,"^",4)
. S Y=+$$ADD3525(IBCODE,IBEFFDT,IBTYPE,$E($P(IBT,"^",2),1,30),IBOVER) S:Y>0 IBC=IBC+1
D MESS(" "_IBC_" entries added to 352.5")
Q
;
;update description (add a new entry with new description if old one exists)
FDESCR(IBEFFDT) ;
N IBC,IBT,IBX,IBCODE,IBTYPE,IBOVER
N IBLSTDT,IB1
D MESS(" Updating descriptions in file 352.5")
S IBC=0
F IBX=1:1 S IBT=$P($T(DESCR+IBX),";",3) Q:'$L(IBT) D
. S IBCODE=+$P(IBT,"^",1)
. S IBLSTDT=$O(^IBE(352.5,"AEFFDT",IBCODE,-9999999))
. I +IBLSTDT=0 D Q
. . D BMES^XPDUTL(" Code "_IBCODE_" not found for description update.")
. S IB1=$O(^IBE(352.5,"AEFFDT",IBCODE,IBLSTDT,0))
. I +IB1=0 D Q
. . D BMES^XPDUTL(" Code "_IBCODE_" not found for description update.")
. S IBTYPE=+$P($G(^IBE(352.5,IB1,0)),"^",3)
. S IBOVER=+$P($G(^IBE(352.5,IB1,0)),"^",5)
. S Y=+$$ADD3525(IBCODE,IBEFFDT,IBTYPE,$E($P(IBT,"^",2),1,30),IBOVER) S:Y>0 IBC=IBC+1
D MESS(" "_IBC_" updates added to 352.5")
Q
;
;add a new entry
ADD3525(IBCODE,IBEFFDT,IBTYPE,IBDECR,IBOVER) ;
D BMES^XPDUTL(" "_IBCODE_" "_IBDECR)
N IBIENS,IBFDA,IBER,IBRET,IBSEEKDT,IBLSTDT,IBOFL,IB1
S IBIENS="+1,"
S IBFDA(352.5,IBIENS,.01)=IBCODE
S IBFDA(352.5,IBIENS,.02)=IBEFFDT
S IBFDA(352.5,IBIENS,.03)=IBTYPE
S IBFDA(352.5,IBIENS,.04)=IBDECR
I IBOVER=1 S IBFDA(352.5,IBIENS,.05)=1
D UPDATE^DIE("","IBFDA","IBRET","IBER")
I $D(IBER) D BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))
Q $G(IBRET(1))
;
;output the message
MESS(IBSTR) ;
N IBA
S IBA(2)=IBSTR
S (IBA(1),IBA(3))=""
D MES^XPDUTL(.IBA)
Q
;
;data section
ADDREG ;; non-override (regular) codes
;;221^PHONE/VISUAL IMPAIRMENT (VIST)^0^0
;;348^PRIMARY CARE GROUP^1^0
;;371^CCS EVALUATION^0^0
;;394^MED SPECIALTY GROUP^2^0
;;674^ADMIN PT ORIENT NON-CNT MAS^0^0
;;685^CARE OF CCS PROGRAM PATIENTS^0^1
;;686^CCS TELEPHONE (ETC.) CARE^0^0
;;690^TELEMEDICINE 2ND ONLY^0^1
;;717^PPD CLINIC (2ND ONLY)^0^1
;;179^REAL-TIME VIDEO CARE 2ND ONLY^0^1
;;684^HM THLTH NOVIDEO INTRVN 2 ONLY^0^1
;;
;
DESCR ;; description updates
;;317^ANTI-COAGULATION CLINIC^
;;512^MENTAL HEALTH CONSULTATION^
;;527^MENTAL HEALTH PHONE PRI ONLY^
;;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P242 3132 printed Dec 13, 2024@02:01:58 Page 2
IB20P242 ;WOIFO/SS-FY04 OPC COPAY IB*2.0*242 POST INIT ;10-SEP-03
+1 ;;2.0;INTEGRATED BILLING;**242**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
POST ;
+1 IF $$PATCH^XPDUTL("IB*2.0*242")
DO BMES^XPDUTL(" Skipping since the patch was previously installed.")
QUIT
+2 NEW X,Y,IBEFFDT
+3 ;effective date OCT 1, 2003
SET IBEFFDT=3031001
+4 DO START
DO FADD(IBEFFDT)
DO FDESCR(IBEFFDT)
DO FINISH
+5 ;
+6 ; FADD - add additional codes to file 352.5
+7 ; FDESCR - add description updates for codes to file 352.5
+8 QUIT
+9 ;
START ;
+1 DO MESS(" FY04 OPC COPAY, Post-Install Starting")
+2 QUIT
+3 ;
FINISH ;
+1 DO MESS(" FY04 OPC COPAY, Post-Install Complete")
+2 QUIT
+3 ;
+4 ;add new entries in file 352.5
FADD(IBEFFDT) ;
+1 NEW IBC,IBT,IBX,IBCODE,IBTYPE,IBOVER
+2 DO MESS(" Adding new codes to file 352.5")
+3 SET IBC=0
+4 FOR IBX=1:1
SET IBT=$PIECE($TEXT(ADDREG+IBX),";",3)
if '$LENGTH(IBT)
QUIT
Begin DoDot:1
+5 SET IBCODE=+$PIECE(IBT,"^",1)
+6 SET IBTYPE=$PIECE(IBT,"^",3)
+7 SET IBOVER=+$PIECE(IBT,"^",4)
+8 SET Y=+$$ADD3525(IBCODE,IBEFFDT,IBTYPE,$EXTRACT($PIECE(IBT,"^",2),1,30),IBOVER)
if Y>0
SET IBC=IBC+1
End DoDot:1
+9 DO MESS(" "_IBC_" entries added to 352.5")
+10 QUIT
+11 ;
+12 ;update description (add a new entry with new description if old one exists)
FDESCR(IBEFFDT) ;
+1 NEW IBC,IBT,IBX,IBCODE,IBTYPE,IBOVER
+2 NEW IBLSTDT,IB1
+3 DO MESS(" Updating descriptions in file 352.5")
+4 SET IBC=0
+5 FOR IBX=1:1
SET IBT=$PIECE($TEXT(DESCR+IBX),";",3)
if '$LENGTH(IBT)
QUIT
Begin DoDot:1
+6 SET IBCODE=+$PIECE(IBT,"^",1)
+7 SET IBLSTDT=$ORDER(^IBE(352.5,"AEFFDT",IBCODE,-9999999))
+8 IF +IBLSTDT=0
Begin DoDot:2
+9 DO BMES^XPDUTL(" Code "_IBCODE_" not found for description update.")
End DoDot:2
QUIT
+10 SET IB1=$ORDER(^IBE(352.5,"AEFFDT",IBCODE,IBLSTDT,0))
+11 IF +IB1=0
Begin DoDot:2
+12 DO BMES^XPDUTL(" Code "_IBCODE_" not found for description update.")
End DoDot:2
QUIT
+13 SET IBTYPE=+$PIECE($GET(^IBE(352.5,IB1,0)),"^",3)
+14 SET IBOVER=+$PIECE($GET(^IBE(352.5,IB1,0)),"^",5)
+15 SET Y=+$$ADD3525(IBCODE,IBEFFDT,IBTYPE,$EXTRACT($PIECE(IBT,"^",2),1,30),IBOVER)
if Y>0
SET IBC=IBC+1
End DoDot:1
+16 DO MESS(" "_IBC_" updates added to 352.5")
+17 QUIT
+18 ;
+19 ;add a new entry
ADD3525(IBCODE,IBEFFDT,IBTYPE,IBDECR,IBOVER) ;
+1 DO BMES^XPDUTL(" "_IBCODE_" "_IBDECR)
+2 NEW IBIENS,IBFDA,IBER,IBRET,IBSEEKDT,IBLSTDT,IBOFL,IB1
+3 SET IBIENS="+1,"
+4 SET IBFDA(352.5,IBIENS,.01)=IBCODE
+5 SET IBFDA(352.5,IBIENS,.02)=IBEFFDT
+6 SET IBFDA(352.5,IBIENS,.03)=IBTYPE
+7 SET IBFDA(352.5,IBIENS,.04)=IBDECR
+8 IF IBOVER=1
SET IBFDA(352.5,IBIENS,.05)=1
+9 DO UPDATE^DIE("","IBFDA","IBRET","IBER")
+10 IF $DATA(IBER)
DO BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))
+11 QUIT $GET(IBRET(1))
+12 ;
+13 ;output the message
MESS(IBSTR) ;
+1 NEW IBA
+2 SET IBA(2)=IBSTR
+3 SET (IBA(1),IBA(3))=""
+4 DO MES^XPDUTL(.IBA)
+5 QUIT
+6 ;
+7 ;data section
ADDREG ;; non-override (regular) codes
+1 ;;221^PHONE/VISUAL IMPAIRMENT (VIST)^0^0
+2 ;;348^PRIMARY CARE GROUP^1^0
+3 ;;371^CCS EVALUATION^0^0
+4 ;;394^MED SPECIALTY GROUP^2^0
+5 ;;674^ADMIN PT ORIENT NON-CNT MAS^0^0
+6 ;;685^CARE OF CCS PROGRAM PATIENTS^0^1
+7 ;;686^CCS TELEPHONE (ETC.) CARE^0^0
+8 ;;690^TELEMEDICINE 2ND ONLY^0^1
+9 ;;717^PPD CLINIC (2ND ONLY)^0^1
+10 ;;179^REAL-TIME VIDEO CARE 2ND ONLY^0^1
+11 ;;684^HM THLTH NOVIDEO INTRVN 2 ONLY^0^1
+12 ;;
+13 ;
DESCR ;; description updates
+1 ;;317^ANTI-COAGULATION CLINIC^
+2 ;;512^MENTAL HEALTH CONSULTATION^
+3 ;;527^MENTAL HEALTH PHONE PRI ONLY^
+4 ;;
+5 ;
