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

DG53P952.m

Go to the documentation of this file. 
  1. DG53P952 ;SLC/SS - POST-INIT ;02/25/2019
  1.  ;;5.3;Registration;**952**;Aug 13, 1993;Build 160
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;DG*5.3*952 post - install entry point
  1.  ;
  1.  ;ICRs Used:
  1.  ;DBIA #10141 XPDUTL
  1.  ;DBIA #2053 Data Base Server API: Editing Utilities
  1. EN ;
  1.  D REIDX($$PATCH^XPDUTL("DG*5.3*952")),ADDELIG,POSADD,ADD38P6,POSTOTH
  1.  Q
  1.  ;
  1. REIDX(REINST) ; rebuild AEXPMH index on field 2/.5501 and remove blank ^DPT(DFN,.55), if necessary
  1.  N CNT,DFN,DIK
  1.  D BMES^XPDUTL("Checking if we need to rebuild AEXPMH index in PATIENT file (#2)...")
  1.  I 'REINST D MES^XPDUTL("This is the first installation of the patch - skipping.") Q
  1.  D MES^XPDUTL("This is a re-installation of the patch - proceeding.")
  1.  D BMES^XPDUTL("Cleaning up field 2/.5501...")
  1.  ; remove unneeded ^DPT(DFN,.55) global nodes
  1.  S (CNT,DFN)=0 F  S DFN=+$O(^DPT(DFN)) Q:'DFN  D
  1.  .S CNT=CNT+1 I '$D(ZTQUEUED),'(CNT#100) W "."
  1.  .; remove .55 node if it's blank and there's no entry in file 33 for this patient
  1.  .I $G(^DPT(DFN,.55))="",+$O(^DGOTH(33,"B",DFN,""))'>0 K ^DPT(DFN,.55)
  1.  .Q
  1.  D MES^XPDUTL("Done.")
  1.  ; rebuild AEXPMH index in file 2
  1.  D BMES^XPDUTL("Rebuilding AEXPMH index in PATIENT file")
  1.  S DIK="^DPT(",DIK(1)=".5501^AEXPMH"
  1.  D ENALL2^DIK,ENALL^DIK
  1.  D MES^XPDUTL("Done.")
  1.  Q
  1.  ;
  1. ADDELIG ;Adds the EXPANDED MH CARE NON-ENROLLEE eligibility to the ELIGIBILITY CODE file (#8)
  1.  N DA,DIK
  1.  D BMES^XPDUTL("Checking for existence of the EXPANDED MH CARE NON-ENROLLEE eligibility in the ELIGIBILITY CODE file (#8)")
  1.  S DA=$O(^DIC(8,"B","EXPANDED MH CARE NON-ENROLLEE",0)) I DA D  Q
  1.  .D MES^XPDUTL("EXPANDED MH CARE NON-ENROLLEE eligibility already exists - skipping.")
  1.  ;
  1.  ;Add the new eligibility to the file #8
  1.  N DGVALS,DGIEN
  1.  D BMES^XPDUTL("Adding EXPANDED MH CARE NON-ENROLLEE eligibility entry to file #8")
  1.  S DGVALS(.01)="EXPANDED MH CARE NON-ENROLLEE"
  1.  S DGVALS(1)="RED"
  1.  S DGVALS(2)="MHNV"
  1.  S DGVALS(3)=11
  1.  S DGVALS(4)="N"
  1.  S DGVALS(5)="EXPANDED MH NON-ENROLLEE"
  1.  S DGVALS(8)="EXPANDED MH CARE NON-ENROLLEE"
  1.  S DGVALS(9)="VA STANDARD"
  1.  S DGVALS(11)="VA"
  1.  S DGIEN=$$INSREC(8,"",.DGVALS,,"E",,,1)
  1.  I DGIEN<0 D
  1.  . D BMES^XPDUTL("Error:")
  1.  . D BMES^XPDUTL("  The EXPANDED MH CARE NON-ENROLLEE eligibility was not added to the file #8: ")
  1.  . D MES^XPDUTL("  "_$P(DGIEN,U,2))
  1.  ;
  1.  I $O(^DIC(8,"B","EXPANDED MH CARE NON-ENROLLEE",0))>0 D  Q
  1.  .D BMES^XPDUTL("The EXPANDED MH CARE NON-ENROLLEE eligibility has been added to the file #8 successfully.")
  1.  Q
  1.  ;
  1.  ;
  1.  ;/**
  1.  ;Creates a new entry (or node for multiple with .01 field)
  1.  ;
  1.  ;DGFILE - file/subfile number
  1.  ;DGIEN - ien of the parent file entry in which the new subfile entry will be inserted
  1.  ;DGZFDA - array with values for the fields
  1.  ; format for DGZFDA:
  1.  ; DGZFDA(.01)=value for #.01 field
  1.  ; DGZFDA(3)=value for #3 field
  1.  ;DGRECNO -(optional) specify IEN if you want specific value
  1.  ; Note: "" then the system will assign the entry number itself.
  1.  ;DGFLGS - FLAGS parameter for UPDATE^DIE
  1.  ;DGLCKGL - fully specified global reference to lock
  1.  ;DGLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file 
  1.  ;DGNEWRE - optional, flag = if 1 then allow to create a new top level record 
  1.  ;  
  1.  ;output :
  1.  ; positive number - record # created
  1.  ; <=0 - failure^error message
  1.  ;
  1.  ;Example:
  1.  ;S DGVALS(.01)="OTHD" W $$INSREC^DG53952(8.1,"",.DGVALS,,,,,1)
  1. INSREC(DGFILE,DGIEN,DGZFDA,DGRECNO,DGFLGS,DGLCKGL,DGLCKTM,DGNEWRE) ;*/
  1.  I ('$G(DGFILE)) Q "0^Invalid parameter"
  1.  I +$G(DGNEWRE)=0 I $G(DGRECNO)>0,'$G(DGIEN) Q "0^Invalid parameter"
  1.  N DGSSI,DGIENS,DGERR,DGFDA,DIERR
  1.  N DGLOCK S DGLOCK=0
  1.  I '$G(DGRECNO) N DGRECNO S DGRECNO=$G(DGRECNO)
  1.  I DGIEN'="" S DGIENS="+1,"_DGIEN_"," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
  1.  I DGIEN="" S DGIENS="+1," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
  1.  M DGFDA(DGFILE,DGIENS)=DGZFDA
  1.  I $L($G(DGLCKGL)) L +@DGLCKGL:(+$G(DGLCKTM)) S DGLOCK=$T I 'DGLOCK Q -2  ;lock failure
  1.  D UPDATE^DIE($G(DGFLGS),"DGFDA","DGSSI","DGERR")
  1.  I DGLOCK L -@DGLCKGL
  1.  I $D(DGERR) Q "-1^"_$G(DGERR("DIERR",1,"TEXT",1),"Update Error")
  1.  Q +$G(DGSSI(1))
  1.  ;
  1. ADD38P6 ;Add an entry to file #38.6 (INCONSISTENT DATA ELEMENTs) in DINUM positions 89 and 90
  1.  ;for two new inconsistence checks on Primary Eligibility and Patient Type
  1.  N DA,DGX,DIC,DINUM,DTOUT,DUOUT,X,Y
  1.  K DO
  1.  D BMES^XPDUTL("Checking for existence of the PAT TYPE/OTH ELIG INCONSISTENT consistency check..")
  1.  S DGX=$D(^DGIN(38.6,"B","PAT TYPE/OTH ELIG INCONSISTENT")) D:DGX MES^XPDUTL("Consistency check for PAT TYPE/OTH ELIG INCONSISTENT already exists - skipping.")
  1.  D:'DGX
  1.  . D MES^XPDUTL("Adding inconsistency check PAT TYPE/OTH ELIG INCONSISTENT to")
  1.  . D MES^XPDUTL("file #38.6 (INCONSISTENT DATA ELEMENTS) at DINUM position 89")
  1.  . S DIC="^DGIN(38.6,",DIC(0)="FZ",X="PAT TYPE/OTH ELIG INCONSISTENT",DINUM=89
  1.  . S DIC("DR")="2///PATIENT TYPE IS INCOMPATIBLE WITH PRIMARY ELIGIBILITY;3///0;4///1;5///0;6///0;"
  1.  . S DIC("DR")=DIC("DR")_"50///Patient Type is incompatible with Primary Eligibility of Expanded MH Care Non-Enrollee"
  1.  . D FILE^DICN
  1.  . D MES^XPDUTL("...added.")
  1.  Q
  1.  ;
  1. POSADD ;Add EXPANDED MH CARE NON-ENROLLEE eligibility to entries in file #21 (Period Of Service)
  1.  ;                                                                            sub-file (#21.01)
  1.  ;
  1.  N DGPHEC    ;EXPANDED MH CARE NON-ENROLLEE - Eligibility Code actual name
  1.  N DGPHIEN   ;EXPANDED MH CARE NON-ENROLLEE - IEN in file #8
  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.  D BMES^XPDUTL("**Updating entries in file #21, with EXPANDED MH CARE NON-ENROLLEE.")
  1.  S DGPHEC="EXPANDED MH CARE NON-ENROLLEE",DGPHIEN=$$FIND1^DIC(8,"","MX",DGPHEC,"","","DGERR")
  1.  I 'DGPHIEN!$D(DGERR) D  Q
  1.  .D BMES^XPDUTL("*EXPANDED MH CARE NON-ENROLLEE not found in file #8.")
  1.  .D BMES^XPDUTL("** Unable to update PERIOD OF SERVICE file (#21).")
  1.  .Q
  1.  ;
  1.  S DGPOSIEN=$$FIND1^DIC(21,"","MX","OTHER NON-VETERANS","","","DGERR") I 'DGPOSIEN!$D(DGERR) Q
  1.  I $$FIND1^DIC(21.01,","_DGPOSIEN_",","MX",DGPHIEN,"","","DGERR") D  Q
  1.  .D BMES^XPDUTL("*EXPANDED MH CARE NON-ENROLLEE already exists in OTHER NON-VETERANS entry.")
  1.  .Q
  1.  S DGFDA(21.01,"+1,"_DGPOSIEN_",",.01)=DGPHEC
  1.  D UPDATE^DIE("E","DGFDA","","DGERR")
  1.  I $D(DGERR) D BMES^XPDUTL("** Unable to update PERIOD OF SERVICE file (#21).") Q
  1.  D BMES^XPDUTL("*EXPANDED MH CARE NON-ENROLLEE successfully added to file #21.")
  1.  Q
  1.  ;
  1. POSTOTH  ;  Run a background job to print possible OTH patients 4 days after install at 10:00 PM
  1.  N RUNDT,XMDUZ,XMSUB,XMY,DIFROM
  1.  D BMES^XPDUTL("**Attempting to run the POST Install for 'Potential OTH patients'")
  1.  S ZTDESC="Potential OTH Patients Report "_$$FMTE^XLFDT(DT),ZTRTN="OTHRPT^DG53P952"
  1.  S RUNDT=$$FMADD^XLFDT(DT,+4)_".2200"     ;Queue to today +4 at 2200
  1.  S ZTDTH=$$FMTH^XLFDT(RUNDT)
  1.  S (XMDUZ,XMSUB)="Potential OTH Pts since Executive order 13822",XMDUZ=".5",XMY(DUZ)="",XMY(XMDUZ)=""
  1.  S XMY("G.DGEN ELIGIBILITY ALERT")="",XMY("G.DGEN ELIGIBILITY ALERT",0)="IN"
  1.  S ZTSAVE("ZTREQ")="@",ZTIO=""
  1.  D ^%ZTLOAD
  1.  I $G(ZTSK) S X="**'Potential OTH Pts' Report - Queued to Task #"_$G(ZTSK) D BMES^XPDUTL(X)
  1.  Q
  1. OTHRPT ;
  1.  N DIC,X,Y,SDPCF,IOP,ECXPCF,ECX,REP,DIFROM,POP,PMESS
  1.  S XMSUB="Potential OTH Pts since Executive order 13822"
  1.  S PMESS=$O(^%ZIS(1,"B","P-MESSAGE")) I $E(PMESS,1,9)'="P-MESSAGE" D POSTERR Q  ;Stop if p-message device doesn't exist
  1.  S Y=$O(^%ZIS(1,"B",PMESS,""))
  1.  I 'Y D POSTERR  Q                        ;Stop if p-message device doesn't exist
  1.  S IOP="`"_+Y                             ;Set IOP to p-message device
  1.  D ^%ZIS
  1.  I POP G POSTERR                          ;Stop if there is a problem with p-message device
  1.  D ENQUE^DGOTHRP6
  1.  K XMY
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. POSTERR ;
  1.  N MESS
  1.  S MESS(1)="------------------------------------------------------------------------"
  1.  S MESS(2)="***A queued Post Install report for 'Potential OTH Pts since Executive"
  1.  S MESS(3)=" Order #13822', failed. Please run it manually - 'D EN^DGOTHRP6', Que"
  1.  S MESS(4)="  the output for Today+4 (off normal hours), use device 'P-MESSAGE',"
  1.  S MESS(5)="            send to the mail group 'G.DGEN ELIGIBILITY ALERT'"
  1.  S MESS(6)="------------------------------------------------------------------------"
  1.  D BMES^XPDUTL(.MESS)
  1.  Q