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

DG1074P.m

Go to the documentation of this file.
  1. DG1074P ;MNTVBB/RS - TREATING SPECIALTIES UPDATE ; 1/12/2022 11:10am
  1. ;;5.3;Registration;**1074**;Aug 13, 1993;Build 4
  1. ;
  1. Q
  1. EN ;Add Treating Specialties to the SPECIALTY file (#42.4)
  1. N DGI,DGERR,DGSPEC,DGIFN,DGQUES
  1. S DGIFN=0
  1. ;add new treating specialties
  1. F DGI=1:1 S DGSPEC=$P($T(TRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
  1. .D TSPEC
  1. .S DGQUES=$P(DGSPEC,U,9)
  1. .D FAC
  1. .Q
  1. Q
  1. TSPEC ;Add treating specialty to SPECIALTY File (#42.4)
  1. D BMES^XPDUTL(">>>"_$P(DGSPEC,U,2)_">>>")
  1. N DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
  1. S DIC="^DIC(42.4,"
  1. S DIC(0)="LX"
  1. S DINUM=$P(DGSPEC,U)
  1. S X=$P(DGSPEC,U,2)
  1. S DLAYGO=42.4
  1. D ^DIC
  1. S (DGIFN,DGDA1)=DGSPEC
  1. I +DGIFN=-1 D Q
  1. .D MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
  1. .D MES^XPDUTL(" Please contact Customer Service for assistance.")
  1. .Q
  1. D MES^XPDUTL(" Entry added to SPECIALTY File (#42.4).")
  1. D MES^XPDUTL(" Updating SPECIALTY File fields.")
  1. S DIE=DIC
  1. S DR=".01///"_$P(DGSPEC,U,2)_";1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)_";7///"_$P(DGSPEC,U,10)
  1. S DA=+DGIFN
  1. D ^DIE
  1. S DGFILE=42.4
  1. S DGMULT=10
  1. S DIC="^DIC(42.4,"_+DGIFN_",""E"","
  1. D MULT
  1. Q
  1. FAC ;Add treating specialty to Facility Treating Specialty file (#45.7)
  1. N DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
  1. S DIC="^DIC(45.7,"
  1. S DIC(0)="LXZ"
  1. S DLAYGO=45.7
  1. S X=$P(DGSPEC,U,2)
  1. D ^DIC
  1. S DGDA1=Y
  1. I +DGDA1=-1 D BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).") Q
  1. I $P(DGDA1,U,3)'=1&($P(Y(0),U,2)'=$P(DGSPEC,U)) D Q
  1. .D BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
  1. .D MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
  1. .D MES^XPDUTL(" Please review entry.")
  1. .Q
  1. D BMES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
  1. D MES^XPDUTL(" Updating SPECIALTY field...")
  1. S DIE=DIC
  1. S DA=+DGDA1
  1. S DR="1////"_$P(DGSPEC,U)
  1. D ^DIE
  1. S DGFILE=45.7
  1. S DGMULT=100
  1. S DIC="^DIC(45.7,"_+DGDA1_",""E"","
  1. D MULT
  1. Q
  1. MULT ;Add Effective Date
  1. N DA,DIE,DR
  1. S DA(1)=+DGDA1
  1. S DIC(0)="LX"
  1. S DIC("P")=$P(^DD(DGFILE,DGMULT,0),"^",2)
  1. S X=3221001
  1. D ^DIC
  1. S DA=+Y
  1. I +Y=-1 D MES^XPDUTL(" Effective date not added.") Q
  1. D MES^XPDUTL(" Effective date added.")
  1. S DIE=DIC
  1. S DR=".02///Y"
  1. D ^DIE
  1. Q
  1. TRSP ;PTF CODE^SPECIALTY^PRINT NAME^SERVICE^ASK PSYCH^BILLING BEDSECTION^CDR/MPCR^^QUES#^AUSTIN PTF CODE
  1. ;;113^SPINAL CORD INJURY LTC CENTER^SCI LTC CENTER^SPINAL CORD INJURY^N^SPINAL CORD INJURY CARE^1116^^^1O
  1. ;;QUIT