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