GMRA72P ;HDSO/RJH - GMRA*4.0*72 Post-install routine; Feb 5, 2024@16:00
;;4.0;ADVERSE REACTION TRACKING;**72**; 30 Oct 98;Build 5
;
;
; Note: The routine is not deleted after install since it is tasked and the
; BACKOUT functionality needs to remain available. A future patch can
; be used to delete the routine, if needed.
;
Q ; Must be run from a specific tag
;
; ============================================================================
;
EN ; Main entry point
D BMES^XPDUTL(" ")
D BMES^XPDUTL(" The GMRA*4.0*72 Post-Install Routine will scan the PATIENT ALLERGIES file")
D MES^XPDUTL(" file (#120.8) for pointers to inactive drug records in the GMR ALLERGY")
D MES^XPDUTL(" file (#120.82). If found, this patch will attempt to correct those records.")
;
N GMRADUZ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,ZTSK
S ZTRTN="START^GMRA72P"
S ZTDESC="GMRA*4.0*72 Post-Install Routine"
S ZTIO="",ZTDTH=$H
S GMRADUZ=DUZ
S ZTSAVE("GMRADUZ")=""
D ^%ZTLOAD
;
D BMES^XPDUTL(" The GMRA*4.0*72 Post-Install Routine has been tasked.")
D MES^XPDUTL(" Task Number: "_$G(ZTSK))
D MES^XPDUTL(" You will receive MailMan messages when it completes.")
D BMES^XPDUTL(" ")
Q
;
START ; Start the correction process
N GMRASUB,GMRAFROM,GMRATEXT
S GMRANODE="GMRA*4.0*72 POST INSTALL"
;
; Next line in case the patch is installed and backed out multiple times
I $D(^XTMP("GMRA*4.0*72 BACKOUT")) D CHKDUPES
;
S ^XTMP(GMRANODE,0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^GMRA*4.0*72 POST INSTALL"
D GMRA
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
CHKDUPES ; Look for record IDs found in both the FIXED and BACKOUT nodes caused
; by an early version of this functionality
; ^XTMP("GMRA*4.0*72 BACKOUT",0)="3240904^3240606^GMRA*4.0*72 BACKOUT"
; ^XTMP("GMRA*4.0*72 POST INSTALL",0)="3240903^3240605^GMRA*4.0*72 POST INSTALL"
N BKDT,FXDT,RECIEN
S BKDT=$P($G(^XTMP("GMRA*4.0*72 BACKOUT",0)),"^",2)
S FXDT=$P($G(^XTMP("GMRA*4.0*72 POST INSTALL",0)),"^",2)
I BKDT'<FXDT D
. S RECIEN=0
. F S RECIEN=$O(^XTMP("GMRA*4.0*72 BACKOUT",0,RECIEN)) Q:'RECIEN D
.. I $D(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",RECIEN)) K ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",RECIEN)
.. Q
. Q
;
Q
;
GMRA ; Fix records in the PATIENT ALLERGY file (120.8)
; INC30029401 - find inactive GMRA allergies in the Patient Allergy file.
; Search the 120.8 Patient Allergy file to find allergies that are marked as
; inactive in the GMR Allergy file (#120.82)
N ALGIEN,NODE0,PT,GMRALGY,GMRIEN,ALGYNAME,STATUS,ERRMSG,ACTVDT,DTIEN,DTDATA
N DTCNT,PREVSTS,STOP,ERRCNT,RECCNT,GMRCNT,ALGYTYPE,LASTDT,FIXCNT,PT,DEADCNT
N TESTCNT,GMRANODE
;
S GMRANODE="GMRA*4.0*72 POST INSTALL"
S (ALGIEN,RECCNT,ERRCNT,FIXCNT,DEADCNT,TESTCNT)=0
F S ALGIEN=$O(^GMR(120.8,ALGIEN)) Q:'ALGIEN D
. S RECCNT=RECCNT+1
. Q:$D(^GMR(120.8,ALGIEN,"ER")) ; Entered in Error
. ;
. S NODE0=$G(^GMR(120.8,ALGIEN,0)) Q:NODE0=""
. S PT=$P(NODE0,"^",1) Q:PT=""
. I +$P($G(^DPT(PT,.35)),"^",1) S DEADCNT=DEADCNT+1 Q ; Deceased Patient
. I $$TESTPAT^VADPT(PT) S TESTCNT=TESTCNT+1 Q ; Test patient
. ;
. S GMRALGY=$P(NODE0,"^",3) Q:GMRALGY=""
. I GMRALGY'["GMRD(120.82" Q ; GMR Allergies only
. I $$GET1^DIQ(120.8,ALGIEN,3.1)'["DRUG" Q ; Drug allergies only
. ;
. S GMRIEN=$P(GMRALGY,";",1) Q:GMRIEN=""
. I '$D(^GMRD(120.82,GMRIEN)) Q
. I '$D(^GMRD(120.82,GMRIEN,"VUID")) D FIXIT Q
. S STATUS=$$CHKACTV("^GMRD(120.82",GMRIEN)
. I 'STATUS D FIXIT ; Inactive/bad record
. Q
;
D SUMMARY
D REPORT("FIXED",0),REPORT("NOTFIXED",0)
Q
;
FIXIT ; Try to find a matching drug in #50.6 and fix the record
N FIXED,PIEN,FDA,FILEERR,COMMENT
S FIXED=0
S ERRCNT=ERRCNT+1
; Next line - ALGYNAME = REACTANT (File 120.8, field# .02)
S ALGYNAME=$P(NODE0,"^",2) Q:ALGYNAME=""
S PIEN=$O(^PSNDF(50.6,"B",ALGYNAME,"")) I PIEN="" D Q
. S ^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN)=NODE0
. Q
;
S STATUS=$$CHKACTV("^PSNDF(50.6",PIEN)
I STATUS D REBUILD
;
I 'FIXED S ^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN)=NODE0
; Next line in case a site ran a previous version of the patch
I FIXED,$D(^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN)) D
. K ^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN)
. Q
;
K FDA,FILEERR
Q
;
REBUILD ; Rebuild piece 3 of ^GMR(120.8,ien,0) here and add a comment
S FDA(120.8,ALGIEN_",",1)=PIEN_";PSNDF(50.6"_","
D FILE^DIE("","FDA","FILEERR")
I $D(FILEERR) Q
D FNDVADC I 'FIXED S ^GMR(120.8,ALGIEN,0)=NODE0 Q
;
S FIXED=1,FIXCNT=FIXCNT+1
S ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",ALGIEN)=NODE0
;
; Add a comment for this update
S COMMENT="Updated using GMRA*4.0*72 Post-Install routine. Changed inactive "
S COMMENT=COMMENT_"GMRA reactant from file 120.82 to matching active "
S COMMENT=COMMENT_"reactant #"_PIEN_" from file 50.6."
D ADCOM^GMRAFX(ALGIEN,"O",COMMENT) ;Add a comment for this update
Q
;
FNDVADC ; Find the VA Drug Class(es) associated with this drug
N VADC,VADCPTR,VFDA,VFILEERR,VADCFND
S VADCFND=+$P($G(^GMR(120.8,ALGIEN,3,0)),"^",4) ; VA Drug Class counter
S FIXED=$S(VADCFND:1,1:0)
;
I '$D(^PSNDF(50.6,"APRO")) Q
I '$D(^PSNDF(50.6,"APRO",PIEN)) Q
;
S VADC=""
F S VADC=$O(^PSNDF(50.6,"APRO",PIEN,VADC)) Q:'VADC D
. S VADCPTR=$$GET1^DIQ(50.68,VADC,15,"I") ;Pointer to #50.605
. Q:VADCPTR=""
. Q:$D(^GMR(120.8,ALGIEN,3,"B",VADCPTR)) ;Already present
. S STATUS=$$CHKACTV("^PS(50.605",VADCPTR)
. I 'STATUS Q
. S VFDA(120.803,"+1,"_ALGIEN_",",.01)=VADCPTR
. D UPDATE^DIE("","VFDA","","VFILEERR")
. I $D(VFILEERR) K VFDA,VFILEERR Q
. S FIXED=1
. S ^XTMP(GMRANODE,0,"FIXED",ALGIEN,3,VADCPTR)=""
. K VFDA,VFILEERR
. Q
;
Q
;
; ----------------------------------------------------------------------------
CHKACTV(CHKGBL,AIEN) ; Check to see if an item is active
N STRING
S STATUS=0
S STRING="""TERMSTATUS"""_")"
S CHKGBL=CHKGBL_","_AIEN_","_STRING
S LASTDT=$O(@CHKGBL@("B","9999999"),-1) I LASTDT="" Q STATUS
S DTIEN=$O(@CHKGBL@("B",LASTDT,""),-1) I DTIEN="" Q STATUS
S DTDATA=$G(@CHKGBL@(DTIEN,0)) I DTDATA="" Q STATUS
S STATUS=$P(DTDATA,"^",2)
Q STATUS
;
SUMMARY ; Summary of results
S ^XTMP(GMRANODE,0,"SUMMARY",1)=" "
S ^XTMP(GMRANODE,0,"SUMMARY",2)="********** GMRA*4.0*72 Post-Install Routine Summary Report **********"
S ^XTMP(GMRANODE,0,"SUMMARY",3)=" "
S ^XTMP(GMRANODE,0,"SUMMARY",4)=" Process was run by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
S ^XTMP(GMRANODE,0,"SUMMARY",5)=" "
S ^XTMP(GMRANODE,0,"SUMMARY",6)="Total Patient Allergy records examined = "_$J(RECCNT,7)
S ^XTMP(GMRANODE,0,"SUMMARY",7)=" Deceased patient bad records found = "_$J(DEADCNT,7)
S ^XTMP(GMRANODE,0,"SUMMARY",8)=" Test patient bad records found = "_$J(TESTCNT,7)
S ^XTMP(GMRANODE,0,"SUMMARY",9)=" "
S ^XTMP(GMRANODE,0,"SUMMARY",10)=" Total active bad records found = "_$J(ERRCNT,7)
S ^XTMP(GMRANODE,0,"SUMMARY",11)="Bad records that could not be repaired = "_$J(ERRCNT-FIXCNT,7)
S ^XTMP(GMRANODE,0,"SUMMARY",12)=" _______"
S ^XTMP(GMRANODE,0,"SUMMARY",13)=" Bad records fixed = "_$J(FIXCNT,7)
S ^XTMP(GMRANODE,0,"SUMMARY",14)=" "
S ^XTMP(GMRANODE,0,"SUMMARY",15)=" The original version of the corrected records, if any, are stored for"
S ^XTMP(GMRANODE,0,"SUMMARY",16)=" 90 days at ^XTMP(""GMRA*4.0*72 POST INSTALL"",0,""FIXED"",recordID)."
S ^XTMP(GMRANODE,0,"SUMMARY",17)=" "
S ^XTMP(GMRANODE,0,"SUMMARY",18)="*************************** End of Report ****************************"
;
; Send MailMan message to installer and users with GMRA SUPERVISOR or PSNMGR key
S GMRASUB="GMRA*4.0*72 Post-Install Summary Information"
S GMRAFROM="GMRA*4.0*72 Post-Install"
S GMRATEXT="^XTMP(""GMRA*4.0*72 POST INSTALL"",0,""SUMMARY"")"
D MAILMSG(GMRASUB,GMRAFROM,GMRATEXT)
Q
;
; ============================================================================
BACKOUT ; Run this from the programmer's prompt if patch backout is required
W #
N DIR,Y
S DIR("A",1)="This action will back out the file modifications that were performed"
S DIR("A",2)="after the install of GMRA*4.0*72."
S DIR("A",3)=""
S DIR("A")="Are you sure you wish to proceed",DIR("B")="NO",DIR(0)="Y"
D ^DIR
Q:Y<1
;
I '$D(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED")) D Q
. W !!,"No converted records were found that can be backed out. Quitting...",!!
. Q
;
N GMBKNODE,GMRADUZ,GMRBKOK,GMRNOBK,GMRIEN,GMRAREC,GMRATEXT,GMRAMY,GMRASUB,GMRAMIN
N GMRAMZ,GMRAFROM,GMRCNT,GMRCMTDT,GMRCMT,GMRCMTERR
;
S GMBKNODE="GMRA*4.0*72 BACKOUT"
S GMRADUZ=DUZ
S ^XTMP(GMBKNODE,0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^GMRA*4.0*72 BACKOUT"
;
W !!,"Please wait until the backout completes."
W !,"Working...",!
D BKRECS
;
K DIR
N DIR
S DIR("A",1)="A MailMan message has been sent to you as well as holders"
S DIR("A",2)="of the GMRA-SUPERVISOR or PSNMGR security keys."
S DIR("A",3)=""
S DIR("A")="Press any key to continue"
S DIR(0)="E" D ^DIR
Q
;
BKRECS ; Restore the previous (erroneous) records back to ^GMR(120.8,ien,0)
N FDA,FILEERR,VADCPTR,VADCNODE,VFDA,VFILEERR,VADCERR
S (GMRIEN,GMRBKOK,GMRNOBK,GMRCMTERR,VADCERR)=0
;
; ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",ALGIEN)=NODE0
F S GMRIEN=$O(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN)) Q:GMRIEN="" D
. I '$D(^GMR(120.8,GMRIEN)) S GMRNOBK=GMRNOBK+1 Q ; This should never happen
. S ^XTMP(GMBKNODE,0,"BACKOUT",GMRIEN)=^GMR(120.8,GMRIEN,0)
. S ^GMR(120.8,GMRIEN,0)=^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN)
. ;
. ; Back out VA Drug Class(es) added during repair
. I $D(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN,3)) D BKVADC
. ;
. ; Back out the comment added during repair
. S GMRCMTDT=9999999
. K FDA,FILEERR
. F S GMRCMTDT=$O(^GMR(120.8,GMRIEN,26,"B",GMRCMTDT),-1) Q:GMRCMTDT="" D
.. S GMRCNT=$O(^GMR(120.8,GMRIEN,26,"B",GMRCMTDT,"")) Q:GMRCNT=""
.. S GMRCMT=$G(^GMR(120.8,GMRIEN,26,GMRCNT,2,1,0)) Q:GMRCMT=""
.. I GMRCMT["Updated using GMRA*4.0*72" D
... S FDA(120.826,GMRCNT_","_GMRIEN_",",.01)="@"
... D FILE^DIE("","FDA","FILEERR")
... I $D(FILEERR) S ^XTMP(GMBKNODE,0,"BACKOUT",GMRIEN,"CMTERR")="",GMRCMTERR=GMRCMTERR+1
... Q
.. Q
. S GMRBKOK=GMRBKOK+1
. K ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN)
. Q
;
D BKSMRY
Q
;
BKVADC ; Back out the VA Drug Class updates
S VADCPTR=0
F S VADCPTR=$O(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN,3,VADCPTR)) Q:'VADCPTR D
. S VADCNODE=$O(^GMR(120.8,GMRIEN,3,"B",VADCPTR,"")) Q:VADCNODE=""
. S VFDA(120.803,VADCNODE_","_GMRIEN_",",.01)="@"
. D FILE^DIE("","VFDA","VFILEERR")
. I $D(VFILEERR) S ^XTMP(GMBKNODE,0,"BACKOUT",GMRIEN,"VADCERR",VADCPTR)="",VADCERR=VADCERR+1
. K VFDA,VFILEERR
. Q
;
Q
;
BKSMRY ; Summary of the backout results
S ^XTMP(GMBKNODE,0,"SUMMARY",1)=" "
S ^XTMP(GMBKNODE,0,"SUMMARY",2)="**************** GMRA*4.0*72 Rollback Summary Report ****************"
S ^XTMP(GMBKNODE,0,"SUMMARY",3)=" "
S ^XTMP(GMBKNODE,0,"SUMMARY",4)=" Backout was run by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
S ^XTMP(GMBKNODE,0,"SUMMARY",5)=" "
S ^XTMP(GMBKNODE,0,"SUMMARY",6)=" Number of records not rolled back: "_GMRNOBK
S ^XTMP(GMBKNODE,0,"SUMMARY",7)=" Number of records rolled back: "_GMRBKOK
S ^XTMP(GMBKNODE,0,"SUMMARY",8)=" Number of comment backout errors: "_GMRCMTERR
S ^XTMP(GMBKNODE,0,"SUMMARY",9)=" Number of VA Drug Class backout errors: "_VADCERR
S ^XTMP(GMBKNODE,0,"SUMMARY",10)=" "
S ^XTMP(GMBKNODE,0,"SUMMARY",11)=" The previously corrected records will be saved for 90 days at"
S ^XTMP(GMBKNODE,0,"SUMMARY",12)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""BACKOUT"",recordID)."
S ^XTMP(GMBKNODE,0,"SUMMARY",13)=" with errors encountered during comment backout, if any, at"
S ^XTMP(GMBKNODE,0,"SUMMARY",14)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""BACKOUT"",recordID,""CMTERR"")"
S ^XTMP(GMBKNODE,0,"SUMMARY",15)=" and errors encountered during VA Drug Class backout, if any, at"
S ^XTMP(GMBKNODE,0,"SUMMARY",16)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""BACKOUT"",recordID,""VADCERR"")"
S ^XTMP(GMBKNODE,0,"SUMMARY",17)=" "
S ^XTMP(GMBKNODE,0,"SUMMARY",18)=" The text of this message will also be stored for 90 days at"
S ^XTMP(GMBKNODE,0,"SUMMARY",19)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""SUMMARY""."
S ^XTMP(GMBKNODE,0,"SUMMARY",20)=" "
S ^XTMP(GMBKNODE,0,"SUMMARY",21)="*************************** End of Report ****************************"
;
; Send MailMan message with backout info to appropriate group
S GMRASUB="GMRA*4.0*72 Backout Information"
S GMRAFROM="GMRA*4.0*72 BACKOUT"
S GMRATEXT="^XTMP(""GMRA*4.0*72 BACKOUT"",0,""SUMMARY"")"
D MAILMSG(GMRASUB,GMRAFROM,GMRATEXT)
Q
;
; ============================================================================
REPORT(TYPE,LOCAL) ; Common report data
; Local = report run from prompt = 1, otherwise 0
N RPTIEN,RPTDATA,RPTNAME,RPTFILE,RPTFLIEN,RPTPT,RPTPTNM,RPTNODE,RPTSS,RPTLN
N RPTFTR,RPTRECS,RPTCERR,RPTSUB,RPTFROM,RPTTEXT,RPTSTOP,NORECS,DLM
S:$G(TYPE)="" TYPE=""
S:$G(LOCAL)="" LOCAL=1
S RPTSS=$S(TYPE["FIX":"GMRA*4.0*72 POST INSTALL",1:"GMRA*4.0*72 BACKOUT")
S RPTNODE="GMRA*4.0*72 POST INSTALL"
S RPTRECS=$S(TYPE="FIXED":"Fixed",TYPE="NOTFIXED":"Unfixed",1:"Backed Out")_" Records "
S RPTFTR="*************************** End of Report ***************************"
S RPTSUB="GMRA*4.0*72 "_TYPE_" Record Report Information"
S RPTFROM="GMRA*4.0*72 REPORT"
S RPTTEXT="^XTMP(""GMRA*4.0*72 POST INSTALL"",0,""REPORT"")"
S (RPTSTOP,NORECS)=0,DLM="^"
;
I LOCAL D Q:RPTSTOP
. W #
. I $G(TYPE)="" W !!,"GMRA*72 Report Type not specified. Quitting...",!! S RPTSTOP=1 Q
. I (TYPE'="FIXED"),(TYPE'="NOTFIXED"),(TYPE'="BACKOUT") D Q
.. W !!,"GMRA*72 Report type of "_TYPE_" not valid. Quitting...",!!
.. S RPTSTOP=1
.. Q
. ;
. W !!,"GMRA*4.0*72 "_RPTRECS_"Report Results will be sent to you and users"
. W !,"with the GMRA-SUPERVISOR or PSNMGR security key via a MailMan message",!!
. Q
;
K ^XTMP(RPTNODE,0,"REPORT")
D RPTHDR
I '$D(^XTMP(RPTSS,0,TYPE)) D Q
. S NORECS=1,^XTMP(RPTNODE,0,"REPORT",8)=" No "_RPTRECS_"found"
. D RPTFTR(9)
. D MAILMSG(RPTSUB,RPTFROM,RPTTEXT)
. Q
;
S ^XTMP(RPTNODE,0,"REPORT",8)="#120.8 ID"_DLM_"PATIENT NAME"_DLM_"DRUG ALLERGY NAME"
;
S RPTIEN="",RPTLN=9
F S RPTIEN=$O(^XTMP(RPTSS,0,TYPE,RPTIEN)) Q:'RPTIEN D
. S RPTCERR=""
. S RPTDATA=$G(^XTMP(RPTSS,0,TYPE,RPTIEN))
. S RPTPT=$P(RPTDATA,"^",1),RPTPTNM=$$GET1^DIQ(2,RPTPT,.01)
. S RPTNAME=$P(RPTDATA,"^",2),RPTFLIEN=$P($P(RPTDATA,"^",3),";",1)
. I TYPE="BACKOUT" D RPTBKERR
. S ^XTMP(RPTNODE,0,"REPORT",RPTLN)=RPTIEN_RPTCERR_DLM_RPTPTNM_DLM_RPTNAME
. S RPTLN=RPTLN+1
. Q
;
S RPTLN=RPTLN+1 D RPTFTR(RPTLN)
D MAILMSG(RPTSUB,RPTFROM,RPTTEXT)
Q
;
RPTBKERR ; Look for errors during the backout process
N CERR,VERR
S (CERR,VERR)=0
S CERR=$D(^XTMP(RPTSS,0,"BACKOUT",RPTIEN,"CMTERR"))
S VERR=$D(^XTMP(RPTSS,0,"BACKOUT",RPTIEN,"VADCERR"))
S RPTCERR=$S((CERR&VERR):"B",CERR:"C",VERR:"V",1:"")
Q
;
RPTHDR ; Write the report header
S ^XTMP(RPTNODE,0,"REPORT",1)=" "
S ^XTMP(RPTNODE,0,"REPORT",2)="************************* GMRA*4.0*72 Report ************************"
S ^XTMP(RPTNODE,0,"REPORT",3)=" "
S ^XTMP(RPTNODE,0,"REPORT",4)=" "_TYPE_" Report was requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
S ^XTMP(RPTNODE,0,"REPORT",5)=" "
S ^XTMP(RPTNODE,0,"REPORT",6)=" You are receiving this report as a holder of the GMRA-SUPERVISOR or PSNMGR key"
S ^XTMP(RPTNODE,0,"REPORT",7)=" "
Q
;
RPTFTR(LINE) ; Write the report footer
S ^XTMP(RPTNODE,0,"REPORT",LINE)=" "
S LINE=LINE+1
I TYPE="BACKOUT" D
. I 'NORECS D
.. S ^XTMP(RPTNODE,0,"REPORT",LINE)=" Record IDs with a C, V, or B suffix, if any, had backout issues"
.. S LINE=LINE+1
.. Q
. S ^XTMP(RPTNODE,0,"REPORT",LINE)=" "
. S LINE=LINE+1
. Q
;
S ^XTMP(RPTNODE,0,"REPORT",LINE)=RPTFTR
Q
;
; ============================================================================
MAILMSG(MSGSUBJ,MSGFROM,MSGTEXT) ; Build and send a MailMan message
N GMRAREC,GMRAMY,GMRAMIN,GMRAMZ,GMRAKEY
I '$D(GMRADUZ) S GMRADUZ=DUZ
S GMRAMIN("FROM")=MSGFROM
;
; Next line - send to users with specified GMRAKEY. Add more here if needed
F GMRAKEY="GMRA-SUPERVISOR","PSNMGR" D
. S GMRAREC=""
. F S GMRAREC=$O(^XUSEC(GMRAKEY,GMRAREC)) Q:GMRAREC="" S GMRAMY(GMRAREC)=""
. Q
;
S GMRAMY(GMRADUZ)=""
D SENDMSG^XMXAPI(GMRADUZ,MSGSUBJ,MSGTEXT,.GMRAMY,.GMRAMIN,.GMRAMZ,"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRA72P 16872 printed Sep 23, 2025@19:14:41 Page 2
GMRA72P ;HDSO/RJH - GMRA*4.0*72 Post-install routine; Feb 5, 2024@16:00
+1 ;;4.0;ADVERSE REACTION TRACKING;**72**; 30 Oct 98;Build 5
+2 ;
+3 ;
+4 ; Note: The routine is not deleted after install since it is tasked and the
+5 ; BACKOUT functionality needs to remain available. A future patch can
+6 ; be used to delete the routine, if needed.
+7 ;
+8 ; Must be run from a specific tag
QUIT
+9 ;
+10 ; ============================================================================
+11 ;
EN ; Main entry point
+1 DO BMES^XPDUTL(" ")
+2 DO BMES^XPDUTL(" The GMRA*4.0*72 Post-Install Routine will scan the PATIENT ALLERGIES file")
+3 DO MES^XPDUTL(" file (#120.8) for pointers to inactive drug records in the GMR ALLERGY")
+4 DO MES^XPDUTL(" file (#120.82). If found, this patch will attempt to correct those records.")
+5 ;
+6 NEW GMRADUZ,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,ZTSK
+7 SET ZTRTN="START^GMRA72P"
+8 SET ZTDESC="GMRA*4.0*72 Post-Install Routine"
+9 SET ZTIO=""
SET ZTDTH=$HOROLOG
+10 SET GMRADUZ=DUZ
+11 SET ZTSAVE("GMRADUZ")=""
+12 DO ^%ZTLOAD
+13 ;
+14 DO BMES^XPDUTL(" The GMRA*4.0*72 Post-Install Routine has been tasked.")
+15 DO MES^XPDUTL(" Task Number: "_$GET(ZTSK))
+16 DO MES^XPDUTL(" You will receive MailMan messages when it completes.")
+17 DO BMES^XPDUTL(" ")
+18 QUIT
+19 ;
START ; Start the correction process
+1 NEW GMRASUB,GMRAFROM,GMRATEXT
+2 SET GMRANODE="GMRA*4.0*72 POST INSTALL"
+3 ;
+4 ; Next line in case the patch is installed and backed out multiple times
+5 IF $DATA(^XTMP("GMRA*4.0*72 BACKOUT"))
DO CHKDUPES
+6 ;
+7 SET ^XTMP(GMRANODE,0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^GMRA*4.0*72 POST INSTALL"
+8 DO GMRA
+9 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+10 QUIT
+11 ;
CHKDUPES ; Look for record IDs found in both the FIXED and BACKOUT nodes caused
+1 ; by an early version of this functionality
+2 ; ^XTMP("GMRA*4.0*72 BACKOUT",0)="3240904^3240606^GMRA*4.0*72 BACKOUT"
+3 ; ^XTMP("GMRA*4.0*72 POST INSTALL",0)="3240903^3240605^GMRA*4.0*72 POST INSTALL"
+4 NEW BKDT,FXDT,RECIEN
+5 SET BKDT=$PIECE($GET(^XTMP("GMRA*4.0*72 BACKOUT",0)),"^",2)
+6 SET FXDT=$PIECE($GET(^XTMP("GMRA*4.0*72 POST INSTALL",0)),"^",2)
+7 IF BKDT'<FXDT
Begin DoDot:1
+8 SET RECIEN=0
+9 FOR
SET RECIEN=$ORDER(^XTMP("GMRA*4.0*72 BACKOUT",0,RECIEN))
if 'RECIEN
QUIT
Begin DoDot:2
+10 IF $DATA(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",RECIEN))
KILL ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",RECIEN)
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 ;
+14 QUIT
+15 ;
GMRA ; Fix records in the PATIENT ALLERGY file (120.8)
+1 ; INC30029401 - find inactive GMRA allergies in the Patient Allergy file.
+2 ; Search the 120.8 Patient Allergy file to find allergies that are marked as
+3 ; inactive in the GMR Allergy file (#120.82)
+4 NEW ALGIEN,NODE0,PT,GMRALGY,GMRIEN,ALGYNAME,STATUS,ERRMSG,ACTVDT,DTIEN,DTDATA
+5 NEW DTCNT,PREVSTS,STOP,ERRCNT,RECCNT,GMRCNT,ALGYTYPE,LASTDT,FIXCNT,PT,DEADCNT
+6 NEW TESTCNT,GMRANODE
+7 ;
+8 SET GMRANODE="GMRA*4.0*72 POST INSTALL"
+9 SET (ALGIEN,RECCNT,ERRCNT,FIXCNT,DEADCNT,TESTCNT)=0
+10 FOR
SET ALGIEN=$ORDER(^GMR(120.8,ALGIEN))
if 'ALGIEN
QUIT
Begin DoDot:1
+11 SET RECCNT=RECCNT+1
+12 ; Entered in Error
if $DATA(^GMR(120.8,ALGIEN,"ER"))
QUIT
+13 ;
+14 SET NODE0=$GET(^GMR(120.8,ALGIEN,0))
if NODE0=""
QUIT
+15 SET PT=$PIECE(NODE0,"^",1)
if PT=""
QUIT
+16 ; Deceased Patient
IF +$PIECE($GET(^DPT(PT,.35)),"^",1)
SET DEADCNT=DEADCNT+1
QUIT
+17 ; Test patient
IF $$TESTPAT^VADPT(PT)
SET TESTCNT=TESTCNT+1
QUIT
+18 ;
+19 SET GMRALGY=$PIECE(NODE0,"^",3)
if GMRALGY=""
QUIT
+20 ; GMR Allergies only
IF GMRALGY'["GMRD(120.82"
QUIT
+21 ; Drug allergies only
IF $$GET1^DIQ(120.8,ALGIEN,3.1)'["DRUG"
QUIT
+22 ;
+23 SET GMRIEN=$PIECE(GMRALGY,";",1)
if GMRIEN=""
QUIT
+24 IF '$DATA(^GMRD(120.82,GMRIEN))
QUIT
+25 IF '$DATA(^GMRD(120.82,GMRIEN,"VUID"))
DO FIXIT
QUIT
+26 SET STATUS=$$CHKACTV("^GMRD(120.82",GMRIEN)
+27 ; Inactive/bad record
IF 'STATUS
DO FIXIT
+28 QUIT
End DoDot:1
+29 ;
+30 DO SUMMARY
+31 DO REPORT("FIXED",0)
DO REPORT("NOTFIXED",0)
+32 QUIT
+33 ;
FIXIT ; Try to find a matching drug in #50.6 and fix the record
+1 NEW FIXED,PIEN,FDA,FILEERR,COMMENT
+2 SET FIXED=0
+3 SET ERRCNT=ERRCNT+1
+4 ; Next line - ALGYNAME = REACTANT (File 120.8, field# .02)
+5 SET ALGYNAME=$PIECE(NODE0,"^",2)
if ALGYNAME=""
QUIT
+6 SET PIEN=$ORDER(^PSNDF(50.6,"B",ALGYNAME,""))
IF PIEN=""
Begin DoDot:1
+7 SET ^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN)=NODE0
+8 QUIT
End DoDot:1
QUIT
+9 ;
+10 SET STATUS=$$CHKACTV("^PSNDF(50.6",PIEN)
+11 IF STATUS
DO REBUILD
+12 ;
+13 IF 'FIXED
SET ^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN)=NODE0
+14 ; Next line in case a site ran a previous version of the patch
+15 IF FIXED
IF $DATA(^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN))
Begin DoDot:1
+16 KILL ^XTMP("GMRA*4.0*72 POST INSTALL",0,"NOTFIXED",ALGIEN)
+17 QUIT
End DoDot:1
+18 ;
+19 KILL FDA,FILEERR
+20 QUIT
+21 ;
REBUILD ; Rebuild piece 3 of ^GMR(120.8,ien,0) here and add a comment
+1 SET FDA(120.8,ALGIEN_",",1)=PIEN_";PSNDF(50.6"_","
+2 DO FILE^DIE("","FDA","FILEERR")
+3 IF $DATA(FILEERR)
QUIT
+4 DO FNDVADC
IF 'FIXED
SET ^GMR(120.8,ALGIEN,0)=NODE0
QUIT
+5 ;
+6 SET FIXED=1
SET FIXCNT=FIXCNT+1
+7 SET ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",ALGIEN)=NODE0
+8 ;
+9 ; Add a comment for this update
+10 SET COMMENT="Updated using GMRA*4.0*72 Post-Install routine. Changed inactive "
+11 SET COMMENT=COMMENT_"GMRA reactant from file 120.82 to matching active "
+12 SET COMMENT=COMMENT_"reactant #"_PIEN_" from file 50.6."
+13 ;Add a comment for this update
DO ADCOM^GMRAFX(ALGIEN,"O",COMMENT)
+14 QUIT
+15 ;
FNDVADC ; Find the VA Drug Class(es) associated with this drug
+1 NEW VADC,VADCPTR,VFDA,VFILEERR,VADCFND
+2 ; VA Drug Class counter
SET VADCFND=+$PIECE($GET(^GMR(120.8,ALGIEN,3,0)),"^",4)
+3 SET FIXED=$SELECT(VADCFND:1,1:0)
+4 ;
+5 IF '$DATA(^PSNDF(50.6,"APRO"))
QUIT
+6 IF '$DATA(^PSNDF(50.6,"APRO",PIEN))
QUIT
+7 ;
+8 SET VADC=""
+9 FOR
SET VADC=$ORDER(^PSNDF(50.6,"APRO",PIEN,VADC))
if 'VADC
QUIT
Begin DoDot:1
+10 ;Pointer to #50.605
SET VADCPTR=$$GET1^DIQ(50.68,VADC,15,"I")
+11 if VADCPTR=""
QUIT
+12 ;Already present
if $DATA(^GMR(120.8,ALGIEN,3,"B",VADCPTR))
QUIT
+13 SET STATUS=$$CHKACTV("^PS(50.605",VADCPTR)
+14 IF 'STATUS
QUIT
+15 SET VFDA(120.803,"+1,"_ALGIEN_",",.01)=VADCPTR
+16 DO UPDATE^DIE("","VFDA","","VFILEERR")
+17 IF $DATA(VFILEERR)
KILL VFDA,VFILEERR
QUIT
+18 SET FIXED=1
+19 SET ^XTMP(GMRANODE,0,"FIXED",ALGIEN,3,VADCPTR)=""
+20 KILL VFDA,VFILEERR
+21 QUIT
End DoDot:1
+22 ;
+23 QUIT
+24 ;
+25 ; ----------------------------------------------------------------------------
CHKACTV(CHKGBL,AIEN) ; Check to see if an item is active
+1 NEW STRING
+2 SET STATUS=0
+3 SET STRING="""TERMSTATUS"""_")"
+4 SET CHKGBL=CHKGBL_","_AIEN_","_STRING
+5 SET LASTDT=$ORDER(@CHKGBL@("B","9999999"),-1)
IF LASTDT=""
QUIT STATUS
+6 SET DTIEN=$ORDER(@CHKGBL@("B",LASTDT,""),-1)
IF DTIEN=""
QUIT STATUS
+7 SET DTDATA=$GET(@CHKGBL@(DTIEN,0))
IF DTDATA=""
QUIT STATUS
+8 SET STATUS=$PIECE(DTDATA,"^",2)
+9 QUIT STATUS
+10 ;
SUMMARY ; Summary of results
+1 SET ^XTMP(GMRANODE,0,"SUMMARY",1)=" "
+2 SET ^XTMP(GMRANODE,0,"SUMMARY",2)="********** GMRA*4.0*72 Post-Install Routine Summary Report **********"
+3 SET ^XTMP(GMRANODE,0,"SUMMARY",3)=" "
+4 SET ^XTMP(GMRANODE,0,"SUMMARY",4)=" Process was run by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
+5 SET ^XTMP(GMRANODE,0,"SUMMARY",5)=" "
+6 SET ^XTMP(GMRANODE,0,"SUMMARY",6)="Total Patient Allergy records examined = "_$JUSTIFY(RECCNT,7)
+7 SET ^XTMP(GMRANODE,0,"SUMMARY",7)=" Deceased patient bad records found = "_$JUSTIFY(DEADCNT,7)
+8 SET ^XTMP(GMRANODE,0,"SUMMARY",8)=" Test patient bad records found = "_$JUSTIFY(TESTCNT,7)
+9 SET ^XTMP(GMRANODE,0,"SUMMARY",9)=" "
+10 SET ^XTMP(GMRANODE,0,"SUMMARY",10)=" Total active bad records found = "_$JUSTIFY(ERRCNT,7)
+11 SET ^XTMP(GMRANODE,0,"SUMMARY",11)="Bad records that could not be repaired = "_$JUSTIFY(ERRCNT-FIXCNT,7)
+12 SET ^XTMP(GMRANODE,0,"SUMMARY",12)=" _______"
+13 SET ^XTMP(GMRANODE,0,"SUMMARY",13)=" Bad records fixed = "_$JUSTIFY(FIXCNT,7)
+14 SET ^XTMP(GMRANODE,0,"SUMMARY",14)=" "
+15 SET ^XTMP(GMRANODE,0,"SUMMARY",15)=" The original version of the corrected records, if any, are stored for"
+16 SET ^XTMP(GMRANODE,0,"SUMMARY",16)=" 90 days at ^XTMP(""GMRA*4.0*72 POST INSTALL"",0,""FIXED"",recordID)."
+17 SET ^XTMP(GMRANODE,0,"SUMMARY",17)=" "
+18 SET ^XTMP(GMRANODE,0,"SUMMARY",18)="*************************** End of Report ****************************"
+19 ;
+20 ; Send MailMan message to installer and users with GMRA SUPERVISOR or PSNMGR key
+21 SET GMRASUB="GMRA*4.0*72 Post-Install Summary Information"
+22 SET GMRAFROM="GMRA*4.0*72 Post-Install"
+23 SET GMRATEXT="^XTMP(""GMRA*4.0*72 POST INSTALL"",0,""SUMMARY"")"
+24 DO MAILMSG(GMRASUB,GMRAFROM,GMRATEXT)
+25 QUIT
+26 ;
+27 ; ============================================================================
BACKOUT ; Run this from the programmer's prompt if patch backout is required
+1 WRITE #
+2 NEW DIR,Y
+3 SET DIR("A",1)="This action will back out the file modifications that were performed"
+4 SET DIR("A",2)="after the install of GMRA*4.0*72."
+5 SET DIR("A",3)=""
+6 SET DIR("A")="Are you sure you wish to proceed"
SET DIR("B")="NO"
SET DIR(0)="Y"
+7 DO ^DIR
+8 if Y<1
QUIT
+9 ;
+10 IF '$DATA(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED"))
Begin DoDot:1
+11 WRITE !!,"No converted records were found that can be backed out. Quitting...",!!
+12 QUIT
End DoDot:1
QUIT
+13 ;
+14 NEW GMBKNODE,GMRADUZ,GMRBKOK,GMRNOBK,GMRIEN,GMRAREC,GMRATEXT,GMRAMY,GMRASUB,GMRAMIN
+15 NEW GMRAMZ,GMRAFROM,GMRCNT,GMRCMTDT,GMRCMT,GMRCMTERR
+16 ;
+17 SET GMBKNODE="GMRA*4.0*72 BACKOUT"
+18 SET GMRADUZ=DUZ
+19 SET ^XTMP(GMBKNODE,0)=$$FMADD^XLFDT(DT,90)_"^"_DT_"^GMRA*4.0*72 BACKOUT"
+20 ;
+21 WRITE !!,"Please wait until the backout completes."
+22 WRITE !,"Working...",!
+23 DO BKRECS
+24 ;
+25 KILL DIR
+26 NEW DIR
+27 SET DIR("A",1)="A MailMan message has been sent to you as well as holders"
+28 SET DIR("A",2)="of the GMRA-SUPERVISOR or PSNMGR security keys."
+29 SET DIR("A",3)=""
+30 SET DIR("A")="Press any key to continue"
+31 SET DIR(0)="E"
DO ^DIR
+32 QUIT
+33 ;
BKRECS ; Restore the previous (erroneous) records back to ^GMR(120.8,ien,0)
+1 NEW FDA,FILEERR,VADCPTR,VADCNODE,VFDA,VFILEERR,VADCERR
+2 SET (GMRIEN,GMRBKOK,GMRNOBK,GMRCMTERR,VADCERR)=0
+3 ;
+4 ; ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",ALGIEN)=NODE0
+5 FOR
SET GMRIEN=$ORDER(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN))
if GMRIEN=""
QUIT
Begin DoDot:1
+6 ; This should never happen
IF '$DATA(^GMR(120.8,GMRIEN))
SET GMRNOBK=GMRNOBK+1
QUIT
+7 SET ^XTMP(GMBKNODE,0,"BACKOUT",GMRIEN)=^GMR(120.8,GMRIEN,0)
+8 SET ^GMR(120.8,GMRIEN,0)=^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN)
+9 ;
+10 ; Back out VA Drug Class(es) added during repair
+11 IF $DATA(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN,3))
DO BKVADC
+12 ;
+13 ; Back out the comment added during repair
+14 SET GMRCMTDT=9999999
+15 KILL FDA,FILEERR
+16 FOR
SET GMRCMTDT=$ORDER(^GMR(120.8,GMRIEN,26,"B",GMRCMTDT),-1)
if GMRCMTDT=""
QUIT
Begin DoDot:2
+17 SET GMRCNT=$ORDER(^GMR(120.8,GMRIEN,26,"B",GMRCMTDT,""))
if GMRCNT=""
QUIT
+18 SET GMRCMT=$GET(^GMR(120.8,GMRIEN,26,GMRCNT,2,1,0))
if GMRCMT=""
QUIT
+19 IF GMRCMT["Updated using GMRA*4.0*72"
Begin DoDot:3
+20 SET FDA(120.826,GMRCNT_","_GMRIEN_",",.01)="@"
+21 DO FILE^DIE("","FDA","FILEERR")
+22 IF $DATA(FILEERR)
SET ^XTMP(GMBKNODE,0,"BACKOUT",GMRIEN,"CMTERR")=""
SET GMRCMTERR=GMRCMTERR+1
+23 QUIT
End DoDot:3
+24 QUIT
End DoDot:2
+25 SET GMRBKOK=GMRBKOK+1
+26 KILL ^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN)
+27 QUIT
End DoDot:1
+28 ;
+29 DO BKSMRY
+30 QUIT
+31 ;
BKVADC ; Back out the VA Drug Class updates
+1 SET VADCPTR=0
+2 FOR
SET VADCPTR=$ORDER(^XTMP("GMRA*4.0*72 POST INSTALL",0,"FIXED",GMRIEN,3,VADCPTR))
if 'VADCPTR
QUIT
Begin DoDot:1
+3 SET VADCNODE=$ORDER(^GMR(120.8,GMRIEN,3,"B",VADCPTR,""))
if VADCNODE=""
QUIT
+4 SET VFDA(120.803,VADCNODE_","_GMRIEN_",",.01)="@"
+5 DO FILE^DIE("","VFDA","VFILEERR")
+6 IF $DATA(VFILEERR)
SET ^XTMP(GMBKNODE,0,"BACKOUT",GMRIEN,"VADCERR",VADCPTR)=""
SET VADCERR=VADCERR+1
+7 KILL VFDA,VFILEERR
+8 QUIT
End DoDot:1
+9 ;
+10 QUIT
+11 ;
BKSMRY ; Summary of the backout results
+1 SET ^XTMP(GMBKNODE,0,"SUMMARY",1)=" "
+2 SET ^XTMP(GMBKNODE,0,"SUMMARY",2)="**************** GMRA*4.0*72 Rollback Summary Report ****************"
+3 SET ^XTMP(GMBKNODE,0,"SUMMARY",3)=" "
+4 SET ^XTMP(GMBKNODE,0,"SUMMARY",4)=" Backout was run by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
+5 SET ^XTMP(GMBKNODE,0,"SUMMARY",5)=" "
+6 SET ^XTMP(GMBKNODE,0,"SUMMARY",6)=" Number of records not rolled back: "_GMRNOBK
+7 SET ^XTMP(GMBKNODE,0,"SUMMARY",7)=" Number of records rolled back: "_GMRBKOK
+8 SET ^XTMP(GMBKNODE,0,"SUMMARY",8)=" Number of comment backout errors: "_GMRCMTERR
+9 SET ^XTMP(GMBKNODE,0,"SUMMARY",9)=" Number of VA Drug Class backout errors: "_VADCERR
+10 SET ^XTMP(GMBKNODE,0,"SUMMARY",10)=" "
+11 SET ^XTMP(GMBKNODE,0,"SUMMARY",11)=" The previously corrected records will be saved for 90 days at"
+12 SET ^XTMP(GMBKNODE,0,"SUMMARY",12)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""BACKOUT"",recordID)."
+13 SET ^XTMP(GMBKNODE,0,"SUMMARY",13)=" with errors encountered during comment backout, if any, at"
+14 SET ^XTMP(GMBKNODE,0,"SUMMARY",14)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""BACKOUT"",recordID,""CMTERR"")"
+15 SET ^XTMP(GMBKNODE,0,"SUMMARY",15)=" and errors encountered during VA Drug Class backout, if any, at"
+16 SET ^XTMP(GMBKNODE,0,"SUMMARY",16)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""BACKOUT"",recordID,""VADCERR"")"
+17 SET ^XTMP(GMBKNODE,0,"SUMMARY",17)=" "
+18 SET ^XTMP(GMBKNODE,0,"SUMMARY",18)=" The text of this message will also be stored for 90 days at"
+19 SET ^XTMP(GMBKNODE,0,"SUMMARY",19)=" ^XTMP(""GMRA*4.0*72 BACKOUT"",0,""SUMMARY""."
+20 SET ^XTMP(GMBKNODE,0,"SUMMARY",20)=" "
+21 SET ^XTMP(GMBKNODE,0,"SUMMARY",21)="*************************** End of Report ****************************"
+22 ;
+23 ; Send MailMan message with backout info to appropriate group
+24 SET GMRASUB="GMRA*4.0*72 Backout Information"
+25 SET GMRAFROM="GMRA*4.0*72 BACKOUT"
+26 SET GMRATEXT="^XTMP(""GMRA*4.0*72 BACKOUT"",0,""SUMMARY"")"
+27 DO MAILMSG(GMRASUB,GMRAFROM,GMRATEXT)
+28 QUIT
+29 ;
+30 ; ============================================================================
REPORT(TYPE,LOCAL) ; Common report data
+1 ; Local = report run from prompt = 1, otherwise 0
+2 NEW RPTIEN,RPTDATA,RPTNAME,RPTFILE,RPTFLIEN,RPTPT,RPTPTNM,RPTNODE,RPTSS,RPTLN
+3 NEW RPTFTR,RPTRECS,RPTCERR,RPTSUB,RPTFROM,RPTTEXT,RPTSTOP,NORECS,DLM
+4 if $GET(TYPE)=""
SET TYPE=""
+5 if $GET(LOCAL)=""
SET LOCAL=1
+6 SET RPTSS=$SELECT(TYPE["FIX":"GMRA*4.0*72 POST INSTALL",1:"GMRA*4.0*72 BACKOUT")
+7 SET RPTNODE="GMRA*4.0*72 POST INSTALL"
+8 SET RPTRECS=$SELECT(TYPE="FIXED":"Fixed",TYPE="NOTFIXED":"Unfixed",1:"Backed Out")_" Records "
+9 SET RPTFTR="*************************** End of Report ***************************"
+10 SET RPTSUB="GMRA*4.0*72 "_TYPE_" Record Report Information"
+11 SET RPTFROM="GMRA*4.0*72 REPORT"
+12 SET RPTTEXT="^XTMP(""GMRA*4.0*72 POST INSTALL"",0,""REPORT"")"
+13 SET (RPTSTOP,NORECS)=0
SET DLM="^"
+14 ;
+15 IF LOCAL
Begin DoDot:1
+16 WRITE #
+17 IF $GET(TYPE)=""
WRITE !!,"GMRA*72 Report Type not specified. Quitting...",!!
SET RPTSTOP=1
QUIT
+18 IF (TYPE'="FIXED")
IF (TYPE'="NOTFIXED")
IF (TYPE'="BACKOUT")
Begin DoDot:2
+19 WRITE !!,"GMRA*72 Report type of "_TYPE_" not valid. Quitting...",!!
+20 SET RPTSTOP=1
+21 QUIT
End DoDot:2
QUIT
+22 ;
+23 WRITE !!,"GMRA*4.0*72 "_RPTRECS_"Report Results will be sent to you and users"
+24 WRITE !,"with the GMRA-SUPERVISOR or PSNMGR security key via a MailMan message",!!
+25 QUIT
End DoDot:1
if RPTSTOP
QUIT
+26 ;
+27 KILL ^XTMP(RPTNODE,0,"REPORT")
+28 DO RPTHDR
+29 IF '$DATA(^XTMP(RPTSS,0,TYPE))
Begin DoDot:1
+30 SET NORECS=1
SET ^XTMP(RPTNODE,0,"REPORT",8)=" No "_RPTRECS_"found"
+31 DO RPTFTR(9)
+32 DO MAILMSG(RPTSUB,RPTFROM,RPTTEXT)
+33 QUIT
End DoDot:1
QUIT
+34 ;
+35 SET ^XTMP(RPTNODE,0,"REPORT",8)="#120.8 ID"_DLM_"PATIENT NAME"_DLM_"DRUG ALLERGY NAME"
+36 ;
+37 SET RPTIEN=""
SET RPTLN=9
+38 FOR
SET RPTIEN=$ORDER(^XTMP(RPTSS,0,TYPE,RPTIEN))
if 'RPTIEN
QUIT
Begin DoDot:1
+39 SET RPTCERR=""
+40 SET RPTDATA=$GET(^XTMP(RPTSS,0,TYPE,RPTIEN))
+41 SET RPTPT=$PIECE(RPTDATA,"^",1)
SET RPTPTNM=$$GET1^DIQ(2,RPTPT,.01)
+42 SET RPTNAME=$PIECE(RPTDATA,"^",2)
SET RPTFLIEN=$PIECE($PIECE(RPTDATA,"^",3),";",1)
+43 IF TYPE="BACKOUT"
DO RPTBKERR
+44 SET ^XTMP(RPTNODE,0,"REPORT",RPTLN)=RPTIEN_RPTCERR_DLM_RPTPTNM_DLM_RPTNAME
+45 SET RPTLN=RPTLN+1
+46 QUIT
End DoDot:1
+47 ;
+48 SET RPTLN=RPTLN+1
DO RPTFTR(RPTLN)
+49 DO MAILMSG(RPTSUB,RPTFROM,RPTTEXT)
+50 QUIT
+51 ;
RPTBKERR ; Look for errors during the backout process
+1 NEW CERR,VERR
+2 SET (CERR,VERR)=0
+3 SET CERR=$DATA(^XTMP(RPTSS,0,"BACKOUT",RPTIEN,"CMTERR"))
+4 SET VERR=$DATA(^XTMP(RPTSS,0,"BACKOUT",RPTIEN,"VADCERR"))
+5 SET RPTCERR=$SELECT((CERR&VERR):"B",CERR:"C",VERR:"V",1:"")
+6 QUIT
+7 ;
RPTHDR ; Write the report header
+1 SET ^XTMP(RPTNODE,0,"REPORT",1)=" "
+2 SET ^XTMP(RPTNODE,0,"REPORT",2)="************************* GMRA*4.0*72 Report ************************"
+3 SET ^XTMP(RPTNODE,0,"REPORT",3)=" "
+4 SET ^XTMP(RPTNODE,0,"REPORT",4)=" "_TYPE_" Report was requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT(DT)
+5 SET ^XTMP(RPTNODE,0,"REPORT",5)=" "
+6 SET ^XTMP(RPTNODE,0,"REPORT",6)=" You are receiving this report as a holder of the GMRA-SUPERVISOR or PSNMGR key"
+7 SET ^XTMP(RPTNODE,0,"REPORT",7)=" "
+8 QUIT
+9 ;
RPTFTR(LINE) ; Write the report footer
+1 SET ^XTMP(RPTNODE,0,"REPORT",LINE)=" "
+2 SET LINE=LINE+1
+3 IF TYPE="BACKOUT"
Begin DoDot:1
+4 IF 'NORECS
Begin DoDot:2
+5 SET ^XTMP(RPTNODE,0,"REPORT",LINE)=" Record IDs with a C, V, or B suffix, if any, had backout issues"
+6 SET LINE=LINE+1
+7 QUIT
End DoDot:2
+8 SET ^XTMP(RPTNODE,0,"REPORT",LINE)=" "
+9 SET LINE=LINE+1
+10 QUIT
End DoDot:1
+11 ;
+12 SET ^XTMP(RPTNODE,0,"REPORT",LINE)=RPTFTR
+13 QUIT
+14 ;
+15 ; ============================================================================
MAILMSG(MSGSUBJ,MSGFROM,MSGTEXT) ; Build and send a MailMan message
+1 NEW GMRAREC,GMRAMY,GMRAMIN,GMRAMZ,GMRAKEY
+2 IF '$DATA(GMRADUZ)
SET GMRADUZ=DUZ
+3 SET GMRAMIN("FROM")=MSGFROM
+4 ;
+5 ; Next line - send to users with specified GMRAKEY. Add more here if needed
+6 FOR GMRAKEY="GMRA-SUPERVISOR","PSNMGR"
Begin DoDot:1
+7 SET GMRAREC=""
+8 FOR
SET GMRAREC=$ORDER(^XUSEC(GMRAKEY,GMRAREC))
if GMRAREC=""
QUIT
SET GMRAMY(GMRAREC)=""
+9 QUIT
End DoDot:1
+10 ;
+11 SET GMRAMY(GMRADUZ)=""
+12 DO SENDMSG^XMXAPI(GMRADUZ,MSGSUBJ,MSGTEXT,.GMRAMY,.GMRAMIN,.GMRAMZ,"")
+13 QUIT
