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

DG53P524.m

Go to the documentation of this file. 
  1. DG53P524 ;ALB/TMD - Patch DG*5.3*524 Install Utility Routine ; 7/17/03 8:48am
  1.  ;;5.3;Registration;**524**;AUG 13, 1993
  1.  ;
  1.  ;
  1. ENV ;Main entry point for Environment check point.
  1.  ;
  1.  S XPDABORT=""
  1.  D PROGCHK(.XPDABORT) ;checks programmer variables
  1.  I XPDABORT="" K XPDABORT
  1.  Q
  1.  ;
  1.  ;
  1. PRE ;Main entry point for Pre-init items.
  1.  Q
  1.  ;
  1.  ;
  1. POST ;Main entry point for Post-init items.
  1.  ;
  1.  D POST1
  1.  D POST2
  1.  D POST3
  1.  Q
  1.  ;
  1.  ;
  1. PROGCHK(XPDABORT) ;checks for necessary programmer variables
  1.  ;
  1.  I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
  1.  .D BMES^XPDUTL("*****")
  1.  .D MES^XPDUTL("Your programming variables are not set up properly.")
  1.  .D MES^XPDUTL("Installation aborted.")
  1.  .D MES^XPDUTL("*****")
  1.  .S XPDABORT=2
  1.  Q
  1.  ;
  1.  ;
  1. POST1 ;Change Brief Description (#20) for SPANISH AMERICAN (number 3) in PERIOD OF SERVICE file (#21).
  1.  ;
  1.  N DGBDESC   ;Brief Description
  1.  N DGPOS     ;Period of Service
  1.  N DGPOSIEN  ;Period of Service IEN in file #21
  1.  N DGFDA     ;FDA for DBS call
  1.  N DGERR     ;Error array for DBS call
  1.  ;
  1.  S DGPOS="SPANISH AMERICAN"
  1.  S DGBDESC="(4/21/1898-7/4/1902)"
  1.  D BMES^XPDUTL("** Updating PERIOD OF SERVICE file (#21) with new BRIEF DESCRIPTION field (#20) value for "_DGPOS_".")
  1.  S DGPOSIEN=$$FIND1^DIC(21,"","MX",DGPOS,"","","DGERR") D
  1.  .I 'DGPOSIEN!$D(DGERR) Q
  1.  .S DGFDA(21,DGPOSIEN_",",20)=DGBDESC
  1.  .D FILE^DIE("ET","DGFDA","DGERR")
  1.  I $G(DGERR)'="" D BMES^XPDUTL("** Update of "_DGPOS_" Period of Service was NOT successful.") Q
  1.  D BMES^XPDUTL("** BRIEF DESCRIPTION for "_DGPOS_" Period of Service changed to "_DGBDESC_".")
  1.  ;
  1.  Q
  1.  ;
  1. POST2 ; Change Input Transform for Claim Number field (#.313) in Patient file (#2) to disallow length>10 (pseudo SSNs)
  1.  ;
  1.  N DGCODE  ; Changed input transform
  1.  N DGINTP  ; Input template name
  1.  N DGERR   ; Error flag
  1.  N DMAX    ; Maximum Routine Size
  1.  N DGFIRST ; First four pieces of DD node containing input transform
  1.  N X,Y
  1.  ;
  1.  I '$D(^DD(2,.313,0)) D BMES^XPDUTL("** Unable to locate DD node to update input transform for CLAIM NUMBER field (#.313) of the PATIENT file (#2)") Q
  1.  S DGFIRST=$P(^DD(2,.313,0),U,1,4)
  1.  S DGCODE="S DFN=DA D EV^DGLOCK I $D(X) S L=$S($D(^DPT(DA,0)):$P(^(0),U,9),1:X) W:X?1""SS"".E ""  "",L S:X?1""SS"".E X=L"
  1.  S DGCODE=DGCODE_" K:$L(X)>9 X Q:'$D(X)  I X'=L K:$L(X)>8!($L(X)<7)!'(X?.N) X"
  1.  S ^DD(2,.313,0)=DGFIRST_"^"_DGCODE
  1.  D BMES^XPDUTL("** Input transform of the CLAIM NUMBER field (#.313) of the PATIENT file (#2) changed to:")
  1.  D BMES^XPDUTL(DGCODE)
  1.  ; Recompile Input Templates
  1.  F DGINTP="DG LOAD EDIT SCREEN 7","DVBHINQ UPDATE" S Y=$O(^DIE("B",DGINTP,0)) S DGERR=0 D  I DGERR D BMES^XPDUTL("** "_DGINTP_" input template could not be updated")
  1.  .I 'Y S DGERR=1 Q
  1.  .S X=$P($G(^DIE(Y,"ROU")),U,2) I X="" S DGERR=1 Q
  1.  .S DMAX=$$ROUSIZE^DILF D EN^DIEZ
  1.  Q
  1. POST3 ;
  1.  ;N DGHELP  ;New help prompt text
  1.  ;
  1.  I '$D(^DD(2,.313,3)) D BMES^XPDUTL("** Unable to locate DD node to update Help Prompt for CLAIM NUMBER field (#.313) of the PATIENT file (#2)") Q
  1.  S DGHELP="Enter this patient's claim number as 7-8 numerics or enter SS if the claim number is the same as his/her SSN.  Pseudo SSNs are not allowed."
  1.  S ^DD(2,.313,3)=DGHELP
  1.  D BMES^XPDUTL("** Help Prompt text for the CLAIM NUMBER field (#.313) of the PATIENT file (#2) changed to: ")
  1.  D BMES^XPDUTL(DGHELP)
  1.  Q
  1.  ;