Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IB20P599

IB20P599.m

Go to the documentation of this file.
  1. IB20P599 ;ALB/TFW - IB*2.0*599; DSS CLINIC STOP CODES ;7/18/17 1:43pm
  1. ;;2.0;INTEGRATED BILLING;**599**;21-MAR-94;Build 3
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. EN ;
  1. N IBEFFDT
  1. D START,ADD,UPDATE,FINISH
  1. Q
  1. ;
  1. START D BMES^XPDUTL("DSS Clinic Stop Codes, Post-Install Starting")
  1. Q
  1. ;
  1. FINISH D BMES^XPDUTL("DSS Clinic Stop Codes, Post-Install Complete")
  1. Q
  1. ;
  1. ;
  1. ADD ;add a new code
  1. N Y,IBC,IBT,IBX,IBY,IBCODE,IBTYPE,IBDES,IBOVER
  1. D BMES^XPDUTL(" Adding new codes to file 352.5")
  1. S IBC=0
  1. F IBX=1:1 S IBT=$P($T(NCODE+IBX),";",3) Q:'$L(IBT) D
  1. . S IBCODE=+$P(IBT,U)
  1. . S IBTYPE=$P(IBT,U,2)
  1. . S IBDES=$E($P(IBT,U,3),1,30)
  1. . S IBOVER=$P(IBT,U,4)
  1. . S IBY=$P(IBT,U,5)
  1. . I $D(^IBE(352.5,"AEFFDT",IBCODE,-IBY)) D Q
  1. . . D BMES^XPDUTL(" Duplication of stop code "_IBCODE)
  1. . S Y=+$$ADD3525(IBCODE,IBY,IBTYPE,IBDES,IBOVER) S:Y>0 IBC=IBC+1
  1. D BMES^XPDUTL(" "_IBC_$S(IBC<2:" entry",1:" entries")_" added to 352.5")
  1. Q
  1. ;
  1. UPDATE ;update an old code
  1. N Y,IB1,IBC,IBT,IBX,IBCODE,IBMSG,IBTYPE,IBDES,IBOVER,IBLSTDT
  1. S (IBC,IBMSG(1),IBMSG(2),IBMSG(3))=0
  1. D BMES^XPDUTL(" Updating Stop Code entries in file 352.5")
  1. F IBX=1:1 S IBT=$P($T(OCODE+IBX),";",3) Q:'$L(IBT) D
  1. . S IBCODE=+$P(IBT,U)
  1. . S IBY=$P(IBT,U,5)
  1. . I $D(^IBE(352.5,"AEFFDT",IBCODE,-IBY)) D Q
  1. . . D BMES^XPDUTL(" Duplication of stop code "_IBCODE)
  1. . S IBLSTDT=$O(^IBE(352.5,"AEFFDT",IBCODE,-9999999))
  1. . I +IBLSTDT=0 D Q
  1. . . D BMES^XPDUTL(" Code "_IBCODE_" not found in file 352.5")
  1. . S IB1=$O(^IBE(352.5,"AEFFDT",IBCODE,IBLSTDT,0))
  1. . S IB1=$G(^IBE(352.5,IB1,0))
  1. . S IBTYPE=$S($P(IBT,U,2)'="":$P(IBT,U,2),1:$P(IB1,U,3))
  1. . S IBDES=$S($P(IBT,U,3)'="":$E($P(IBT,U,3),1,30),1:$P(IB1,U,4))
  1. . S IBOVER=$P(IBT,U,4)
  1. . S Y=+$$ADD3525(IBCODE,IBY,IBTYPE,IBDES,IBOVER) S:Y>0 IBC=IBC+1
  1. D BMES^XPDUTL(" "_IBC_$S(IBC<2:" update",1:" updates")_" added to file 352.5")
  1. Q
  1. ;
  1. ADD3525(IBCODE,IBEFFDT,IBTYPE,IBDES,IBOVER) ;
  1. ;add a new entry
  1. D BMES^XPDUTL(" "_IBCODE_" "_IBDES)
  1. N IBIENS,IBFDA,IBER,IBRET
  1. S IBRET=""
  1. S IBIENS="+1,"
  1. S IBFDA(352.5,IBIENS,.01)=IBCODE
  1. S IBFDA(352.5,IBIENS,.02)=IBEFFDT
  1. S IBFDA(352.5,IBIENS,.03)=IBTYPE
  1. S IBFDA(352.5,IBIENS,.04)=IBDES
  1. S:IBOVER IBFDA(352.5,IBIENS,.05)=1
  1. D UPDATE^DIE("","IBFDA","IBRET","IBER")
  1. I $D(IBER) D BMES^XPDUTL(IBER("DIERR",1,"TEXT",1))
  1. Q $G(IBRET(1))
  1. ;
  1. ;new stop codes - ADD
  1. NCODE ;;code^billable type^description^override flag^effective date
  1. ;;486^2^CARDIOTHORACIC SURG^1^3171001
  1. ;;487^2^BARIATRIC SURG^1^3171001
  1. ;;488^2^SURGICAL ONC^1^3171001
  1. ;;489^2^SPINAL SURG^1^3171001
  1. ;
  1. ;existing stop codes - UPDATE
  1. OCODE ;;code^billable type^description^override flag^effective date
  1. ;;145^2^MYOCARDIAL PERFUS STUDIES^1^3171001
  1. ;;403^2^OTOLARYNGOLOGY (ENT)^^3171001
  1. ;;409^2^ORTHOPEDICS/JOINT SURG^^3171001
  1. ;;432^1^PRE-SURG EVAL^^3171001
  1. ;