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