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

DG53418P.m

Go to the documentation of this file. 
  1. DG53418P ;ALB/GRR(EDS) - Add new Intermediae Medicine - LTC Treating Specialty;1/21/02
  1.  ;;5.3;Registration;**418**;Aug 13, 1993
  1.  ;
  1.  ;
  1. EN ;Add Intermediate Medicine - LTC Treating Specialties to the SPECIALITY file (#42.4)
  1.  N DGI,DGERR,DGSPEC,DGIFN,DGQUES
  1.  S DGIFN=0
  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. EN2 N DGI,DGMO
  1.  D BMES^XPDUTL("     Selected MAS MOVEMENT TYPES will now be renamed")
  1.  F DGI=1:1 S DGMO=$P($T(MVED+DGI),";;",2) Q:DGMO="QUIT"  D
  1.  .D MOVEMT ;Edit movement type names
  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 DGERR=0
  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)=Y
  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.  I $P(DGIFN,U,3)'=1&(+DGIFN'=$P(DGSPEC,U)) D  Q
  1.  .D MES^XPDUTL("     Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
  1.  .D MES^XPDUTL("     No further updating will occur.  Please review entry.")
  1.  .S DGERR=1
  1.  .Q 
  1.  D MES^XPDUTL("     Entry "_$S($P(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
  1.  D MES^XPDUTL("     Updating SPECIALTY File fields.")
  1.  S DIE=DIC
  1.  S DR="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)
  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.  I $G(XPDQUES(DGQUES))'=1 D  Q
  1.  .D BMES^XPDUTL("     Answered NO to install question.  Specialty will not be added to FACILITY")
  1.  .D MES^XPDUTL("     TREATING SPECIALTY File (#45.7).")
  1.  .Q
  1.  I +DGIFN<0 D  Q
  1.  .D BMES^XPDUTL("     Treating specialty not found in SPECIALTY File (#42.4).  Cannot")
  1.  .D MES^XPDUTL("     be added to FACILITY TREATING SPECIALTY File (#45.7).")
  1.  .Q
  1.  I DGERR=1 D  Q
  1.  .D BMES^XPDUTL("      Answered YES to install question.  SPECIALITY File (#42.4) does not")
  1.  .D MES^XPDUTL("     contain the expected PTF Code #.  Cannot update FACILITY TREATING")
  1.  .D MES^XPDUTL("     SPECIALTY File (#45.7).")
  1.  .Q
  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=3020101
  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. MOVEMT ;Edit Mas Movement Type Names
  1.  N DGFILE,DGIEN,DGON,DGNN,FDAROOT
  1.  S DGFILE=405.2
  1.  S DGON=$P(DGMO,"^",1) ;Old Name
  1.  S DGNN=$P(DGMO,"^",2) ;New Name
  1.  S DGIEN=$$FIND1^DIC(DGFILE,,"QX",DGNN)
  1.  I DGIEN>0 Q  ;New name already in file
  1.  S DGIEN=$$FIND1^DIC(DGFILE,,"QX",DGON) ;Old Name
  1.  I DGIEN'>0 D  ;Didn't find it in file
  1.  .D BMES^XPDUTL("     Mas Movement Type '"_DGON_"' not found!")
  1.  .D MES^XPDUTL("     Contact the Help Desk.")
  1.  I DGIEN>0 D  ;entry found
  1.  .S FDAROOT(DGFILE,DGIEN_",",.01)=DGNN
  1.  .D FILE^DIE("","FDAROOT")
  1.  .D BMES^XPDUTL("'"_DGON_"' renamed '"_DGNN_"'")
  1.  Q
  1. TRSP ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#
  1.  ;;95^INTERMEDIATE MEDICINE - LTC^IM - LTC^I^N^INTERMEDIATE CARE^1415^^POS1
  1.  ;;QUIT
  1. MVED ;Original Movement Name^New Movement Name
  1.  ;;READMISSION TO NHCU/DOMICILIARY^READMISSION TO IMLTC/NHCU/DOMICILIARY
  1.  ;;TO NHCU FROM HOSP^TO IMLTC/NHCU FROM HOSP
  1.  ;;TO NHCU FROM DOM^TO IMLTC/NHCU FROM DOM
  1.  ;;VA NHCU TO CNH^VA IMLTC/NHCU TO CNH
  1.  ;;DISCHARGE FROM NHCU/DOM WHILE ASIH^DISCHARGE FROM IMLTC/NHCU/DOM WHILE ASIH
  1.  ;;QUIT
  1.  Q