GMRAY23 ;SLC/DAN Installation Utilities ;7/18/05 08:06
;;4.0;Adverse Reaction Tracking;**23**;Mar 29, 1996
;
;DBIA SECTION
;3744 - $$TESTPAT^VADPT
;10061 - VADPT
;2916 - DDMOD
;10013 - DIK
;2056 - DIQ
;10018 - DIE
;10070 - XMD
;10103 - XLFDT
;2051 - DIC
;2232 - XUDHSET
;
PRETRAN ;Load descriptions for files 120.82 and 120.83
M @XPDGREF@("GMRADD82")=^DIC(120.82,"%D")
M @XPDGREF@("GMRADD83")=^DIC(120.83,"%D")
Q
;
GETERMS ;Make the request for the allergy standardized terms to be pushed to the site
N TMP,GMRADOM
S TMP=$$GETIEN^HDISVF09("ALLERGIES",.GMRADOM)
D EN^HDISVCMR(GMRADOM,"")
Q
;
POST ;Post installation processes
N ERR,GMRADONT
D RESFILE
D RESDEV
D FIXREF
D ^GMRAY23A,^GMRAY23B,^GMRAY23C ;Set up new style xrefs
;S GMRADONT=1 ;When GMRADONT is defined, messages are NOT sent to HDR
D CLN85
D FIXALG
D GETERMS
D MAIL
Q
;
CLN85 ;Clean up erroneous date/times that are in the STOP DATE OF ADMINISTRATION field of CONCOMITANT DRUG multiple
N GMRAI,GMRAJ,ENDT
S GMRAI=0 F S GMRAI=$O(^GMR(120.85,GMRAI)) Q:'+GMRAI I $D(^GMR(120.85,GMRAI,13)) D
.S GMRAJ=0 F S GMRAJ=$O(^GMR(120.85,GMRAI,13,GMRAJ)) Q:'+GMRAJ D
..S ENDT=$P($G(^GMR(120.85,GMRAI,13,GMRAJ,0)),U,3) Q:ENDT=""
..I ENDT\1'=ENDT S $P(^GMR(120.85,GMRAI,13,GMRAJ,0),U,3)=ENDT\1 ;If value is date/time strip time
Q
;
FIXALG ;Loop through 120.8, fix database issues
N GMRAI,FREE,REACTANT,ENTRY
S FREE=$O(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0)) S:'+FREE ERR=1 S:FREE FREE=FREE_";GMRD(120.82," Q:$G(ERR)
S GMRAI=0 F S GMRAI=$O(^GMR(120.8,GMRAI)) Q:'+GMRAI D
.I '$D(^GMR(120.8,GMRAI,0))!($L(^GMR(120.8,GMRAI,0),"^")=1) D DEL Q
.Q:$$TESTPAT^VADPT($P(^GMR(120.8,GMRAI,0),U)) ;stop if test patient
.I $D(^GMR(120.8,GMRAI,10)) D CHECKSS ;Check signs/symptoms for broken pointers
.D CHECK23(.DELETED) Q:$G(DELETED) ;If pieces 2 and 3 cannot be resolved, delete entry
Q
;
DEL ;No zero node, remove entry
N DIK,DA
S DIK="^GMR(120.8,",DA=GMRAI
D ^DIK
Q
;
CHECKSS ;Check Signs/Symptoms for broken pointers, delete if necessary
N GMRAJ,REF,DIK,DA,RIEN
S GMRAJ=0 F S GMRAJ=$O(^GMR(120.8,GMRAI,10,GMRAJ)) Q:'+GMRAJ D
.S REF=$P($G(^GMR(120.8,GMRAI,10,GMRAJ,0)),U) ;Pointer to 120.83
.I REF I $D(^GMRD(120.83,REF)) Q ;Pointer isn't broken - done
.S DA(1)=GMRAI,DA=GMRAJ,DIK="^GMR(120.8,DA(1),10," D ^DIK ;Remove S/S with broken pointer
.;If observed reaction then there should be a broken pointer in 120.85
.S RIEN=$O(^GMR(120.85,"C",GMRAI,0)) Q:'+RIEN
.S DA(1)=RIEN
.S DA=$O(^GMR(120.85,RIEN,2,"B",REF,0)) Q:'+DA ;S/S not found
.S DIK="^GMR(120.85,DA(1),2," D ^DIK ;Remove S/S from obs entry
Q
;
CHECK23(DELETED) ;Check REACTANT (piece 2) and GMR ALLERGY (piece 3) to make sure they are present and valid
N REACTANT,ALLPTR,GMRA0,IEN,FILE,DIE,DA,DR,BROKEN
S DELETED=0
S GMRA0=$G(^GMR(120.8,GMRAI,0))
S REACTANT=$P(GMRA0,U,2)
S ALLPTR=$P(GMRA0,U,3)
S FILE=$P(ALLPTR,";",2)
S IEN=$P(ALLPTR,";")
S BROKEN=$S(ALLPTR="":1,FILE="":1,IEN="":1,1:$G(@("^"_FILE_IEN_",0)"))="")
I ALLPTR=""!(BROKEN) D Q ;If no pointer present or pointer is broken
.I REACTANT'="" S $P(^GMR(120.8,GMRAI,0),U,3)=FREE Q ;If REACTANT field has a value then set GMR ALLERGY to "free text" entry
.I REACTANT="" D DEL S DELETED=1 Q ;If no pointer or broken pointer and no value in REACTANT then delete entry
Q:DELETED
I ALLPTR'="",REACTANT="" D ;Pointer exists but no value in REACTANT field
.S FILE=+$P(@("^"_FILE_"0)"),U,2) ;Get file number
.S REACTANT=$$GET1^DIQ(FILE,IEN,$S(FILE'=50.67:.01,1:4))
.S DIE="^GMR(120.8,",DA=GMRAI,DR=".02////"_REACTANT D ^DIE
Q
;
MAIL ;Send message indicating post install is finished
N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,GMRATXT,CNT,VADM,DFN,REACTANT,LOOP,DIFROM
S XMDUZ="PATCH GMRA*4*23 POST-INSTALL",XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""
S GMRATXT(1)="The post-install routine for patch GMRA*4*23"
S GMRATXT(2)="finished on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
S GMRATXT(3)=""
S CNT=3
I $G(ERR)=1 D
.S GMRATXT(4)="**NOTE: There was a problem with the installation!"
.S GMRATXT(5)="Required entry missing from file 120.82 - CONVERSION ABORTED.",GMRATXT(6)="Contact the National Help Desk for Immediate assistance."
S XMTEXT="GMRATXT(",XMSUB="PATCH GMRA*4*23 Post Install COMPLETED"
D ^XMD
Q
;
RESFILE ;Restrict file access and update description
N FILE,J,GMRASEC
M ^DIC(120.82,"%D")=@XPDGREF@("GMRADD82")
M ^DIC(120.83,"%D")=@XPDGREF@("GMRADD83")
F J="DD","WR","DEL","LAYGO","AUDIT" S GMRASEC(J)="@"
F FILE=120.82,120.83 D
.S ^DD(FILE,.01,"LAYGO",1,0)="D:'$D(XUMF) EN^DDIOL(""Entries must be added via the Master File Server (MFS)."","""",""!?5,$C(7)"") I $D(XUMF)"
.S ^DD(FILE,.01,7.5)="I $G(DIC(0))[""L"",'$D(XUMF) K X D EN^DDIOL(""Entries must be edited via the Master File Server (MFS)."","""",""!?5,$C(7)"")"
.S ^DD(FILE,.01,"DEL",1,0)="D:'$D(XUMF) EN^DDIOL(""Entries must be inactivated via the Master File Server (MFS)."","""",""!?5,$C(7)"") I $D(XUMF)"
.D FILESEC^DDMOD(FILE,.GMRASEC) ;Force security update to file
F J=.01,1,2,99.98,99.99 S ^DD(120.82,J,9)="^",^DD(120.83,J,9)="^"
F J=120.821,120.831 S ^DD(J,.01,9)="^",^DD(J,.02,9)="^"
F J=120.823,120.824,120.8205 S ^DD(J,.01,9)="^"
Q
;
RESDEV ;Set up resource device
N X
S X=$$RES^XUDHSET("GMRA UPDATE RESOURCE",,1,"Allergy update control")
Q
;
FIXREF ;Fix new style xrefs so they fire when using DIK to set xrefs for an entry in the file
N LCV,DIE,DR,DA
S LCV=0 F S LCV=$O(^DD("IX","IX","AHDR",LCV)) Q:'+LCV S DIE="^DD(""IX"",",DA=LCV,DR=".41///"_"R" D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAY23 5641 printed Sep 23, 2025@19:16:53 Page 2
GMRAY23 ;SLC/DAN Installation Utilities ;7/18/05 08:06
+1 ;;4.0;Adverse Reaction Tracking;**23**;Mar 29, 1996
+2 ;
+3 ;DBIA SECTION
+4 ;3744 - $$TESTPAT^VADPT
+5 ;10061 - VADPT
+6 ;2916 - DDMOD
+7 ;10013 - DIK
+8 ;2056 - DIQ
+9 ;10018 - DIE
+10 ;10070 - XMD
+11 ;10103 - XLFDT
+12 ;2051 - DIC
+13 ;2232 - XUDHSET
+14 ;
PRETRAN ;Load descriptions for files 120.82 and 120.83
+1 MERGE @XPDGREF@("GMRADD82")=^DIC(120.82,"%D")
+2 MERGE @XPDGREF@("GMRADD83")=^DIC(120.83,"%D")
+3 QUIT
+4 ;
GETERMS ;Make the request for the allergy standardized terms to be pushed to the site
+1 NEW TMP,GMRADOM
+2 SET TMP=$$GETIEN^HDISVF09("ALLERGIES",.GMRADOM)
+3 DO EN^HDISVCMR(GMRADOM,"")
+4 QUIT
+5 ;
POST ;Post installation processes
+1 NEW ERR,GMRADONT
+2 DO RESFILE
+3 DO RESDEV
+4 DO FIXREF
+5 ;Set up new style xrefs
DO ^GMRAY23A
DO ^GMRAY23B
DO ^GMRAY23C
+6 ;S GMRADONT=1 ;When GMRADONT is defined, messages are NOT sent to HDR
+7 DO CLN85
+8 DO FIXALG
+9 DO GETERMS
+10 DO MAIL
+11 QUIT
+12 ;
CLN85 ;Clean up erroneous date/times that are in the STOP DATE OF ADMINISTRATION field of CONCOMITANT DRUG multiple
+1 NEW GMRAI,GMRAJ,ENDT
+2 SET GMRAI=0
FOR
SET GMRAI=$ORDER(^GMR(120.85,GMRAI))
if '+GMRAI
QUIT
IF $DATA(^GMR(120.85,GMRAI,13))
Begin DoDot:1
+3 SET GMRAJ=0
FOR
SET GMRAJ=$ORDER(^GMR(120.85,GMRAI,13,GMRAJ))
if '+GMRAJ
QUIT
Begin DoDot:2
+4 SET ENDT=$PIECE($GET(^GMR(120.85,GMRAI,13,GMRAJ,0)),U,3)
if ENDT=""
QUIT
+5 ;If value is date/time strip time
IF ENDT\1'=ENDT
SET $PIECE(^GMR(120.85,GMRAI,13,GMRAJ,0),U,3)=ENDT\1
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
FIXALG ;Loop through 120.8, fix database issues
+1 NEW GMRAI,FREE,REACTANT,ENTRY
+2 SET FREE=$ORDER(^GMRD(120.82,"B","OTHER ALLERGY/ADVERSE REACTION",0))
if '+FREE
SET ERR=1
if FREE
SET FREE=FREE_";GMRD(120.82,"
if $GET(ERR)
QUIT
+3 SET GMRAI=0
FOR
SET GMRAI=$ORDER(^GMR(120.8,GMRAI))
if '+GMRAI
QUIT
Begin DoDot:1
+4 IF '$DATA(^GMR(120.8,GMRAI,0))!($LENGTH(^GMR(120.8,GMRAI,0),"^")=1)
DO DEL
QUIT
+5 ;stop if test patient
if $$TESTPAT^VADPT($PIECE(^GMR(120.8,GMRAI,0),U))
QUIT
+6 ;Check signs/symptoms for broken pointers
IF $DATA(^GMR(120.8,GMRAI,10))
DO CHECKSS
+7 ;If pieces 2 and 3 cannot be resolved, delete entry
DO CHECK23(.DELETED)
if $GET(DELETED)
QUIT
End DoDot:1
+8 QUIT
+9 ;
DEL ;No zero node, remove entry
+1 NEW DIK,DA
+2 SET DIK="^GMR(120.8,"
SET DA=GMRAI
+3 DO ^DIK
+4 QUIT
+5 ;
CHECKSS ;Check Signs/Symptoms for broken pointers, delete if necessary
+1 NEW GMRAJ,REF,DIK,DA,RIEN
+2 SET GMRAJ=0
FOR
SET GMRAJ=$ORDER(^GMR(120.8,GMRAI,10,GMRAJ))
if '+GMRAJ
QUIT
Begin DoDot:1
+3 ;Pointer to 120.83
SET REF=$PIECE($GET(^GMR(120.8,GMRAI,10,GMRAJ,0)),U)
+4 ;Pointer isn't broken - done
IF REF
IF $DATA(^GMRD(120.83,REF))
QUIT
+5 ;Remove S/S with broken pointer
SET DA(1)=GMRAI
SET DA=GMRAJ
SET DIK="^GMR(120.8,DA(1),10,"
DO ^DIK
+6 ;If observed reaction then there should be a broken pointer in 120.85
+7 SET RIEN=$ORDER(^GMR(120.85,"C",GMRAI,0))
if '+RIEN
QUIT
+8 SET DA(1)=RIEN
+9 ;S/S not found
SET DA=$ORDER(^GMR(120.85,RIEN,2,"B",REF,0))
if '+DA
QUIT
+10 ;Remove S/S from obs entry
SET DIK="^GMR(120.85,DA(1),2,"
DO ^DIK
End DoDot:1
+11 QUIT
+12 ;
CHECK23(DELETED) ;Check REACTANT (piece 2) and GMR ALLERGY (piece 3) to make sure they are present and valid
+1 NEW REACTANT,ALLPTR,GMRA0,IEN,FILE,DIE,DA,DR,BROKEN
+2 SET DELETED=0
+3 SET GMRA0=$GET(^GMR(120.8,GMRAI,0))
+4 SET REACTANT=$PIECE(GMRA0,U,2)
+5 SET ALLPTR=$PIECE(GMRA0,U,3)
+6 SET FILE=$PIECE(ALLPTR,";",2)
+7 SET IEN=$PIECE(ALLPTR,";")
+8 SET BROKEN=$SELECT(ALLPTR="":1,FILE="":1,IEN="":1,1:$GET(@("^"_FILE_IEN_",0)"))="")
+9 ;If no pointer present or pointer is broken
IF ALLPTR=""!(BROKEN)
Begin DoDot:1
+10 ;If REACTANT field has a value then set GMR ALLERGY to "free text" entry
IF REACTANT'=""
SET $PIECE(^GMR(120.8,GMRAI,0),U,3)=FREE
QUIT
+11 ;If no pointer or broken pointer and no value in REACTANT then delete entry
IF REACTANT=""
DO DEL
SET DELETED=1
QUIT
End DoDot:1
QUIT
+12 if DELETED
QUIT
+13 ;Pointer exists but no value in REACTANT field
IF ALLPTR'=""
IF REACTANT=""
Begin DoDot:1
+14 ;Get file number
SET FILE=+$PIECE(@("^"_FILE_"0)"),U,2)
+15 SET REACTANT=$$GET1^DIQ(FILE,IEN,$SELECT(FILE'=50.67:.01,1:4))
+16 SET DIE="^GMR(120.8,"
SET DA=GMRAI
SET DR=".02////"_REACTANT
DO ^DIE
End DoDot:1
+17 QUIT
+18 ;
MAIL ;Send message indicating post install is finished
+1 NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,GMRATXT,CNT,VADM,DFN,REACTANT,LOOP,DIFROM
+2 SET XMDUZ="PATCH GMRA*4*23 POST-INSTALL"
SET XMY(.5)=""
if $GET(DUZ)
SET XMY(DUZ)=""
+3 SET GMRATXT(1)="The post-install routine for patch GMRA*4*23"
+4 SET GMRATXT(2)="finished on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
+5 SET GMRATXT(3)=""
+6 SET CNT=3
+7 IF $GET(ERR)=1
Begin DoDot:1
+8 SET GMRATXT(4)="**NOTE: There was a problem with the installation!"
+9 SET GMRATXT(5)="Required entry missing from file 120.82 - CONVERSION ABORTED."
SET GMRATXT(6)="Contact the National Help Desk for Immediate assistance."
End DoDot:1
+10 SET XMTEXT="GMRATXT("
SET XMSUB="PATCH GMRA*4*23 Post Install COMPLETED"
+11 DO ^XMD
+12 QUIT
+13 ;
RESFILE ;Restrict file access and update description
+1 NEW FILE,J,GMRASEC
+2 MERGE ^DIC(120.82,"%D")=@XPDGREF@("GMRADD82")
+3 MERGE ^DIC(120.83,"%D")=@XPDGREF@("GMRADD83")
+4 FOR J="DD","WR","DEL","LAYGO","AUDIT"
SET GMRASEC(J)="@"
+5 FOR FILE=120.82,120.83
Begin DoDot:1
+6 SET ^DD(FILE,.01,"LAYGO",1,0)="D:'$D(XUMF) EN^DDIOL(""Entries must be added via the Master File Server (MFS)."","""",""!?5,$C(7)"") I $D(XUMF)"
+7 SET ^DD(FILE,.01,7.5)="I $G(DIC(0))[""L"",'$D(XUMF) K X D EN^DDIOL(""Entries must be edited via the Master File Server (MFS)."","""",""!?5,$C(7)"")"
+8 SET ^DD(FILE,.01,"DEL",1,0)="D:'$D(XUMF) EN^DDIOL(""Entries must be inactivated via the Master File Server (MFS)."","""",""!?5,$C(7)"") I $D(XUMF)"
+9 ;Force security update to file
DO FILESEC^DDMOD(FILE,.GMRASEC)
End DoDot:1
+10 FOR J=.01,1,2,99.98,99.99
SET ^DD(120.82,J,9)="^"
SET ^DD(120.83,J,9)="^"
+11 FOR J=120.821,120.831
SET ^DD(J,.01,9)="^"
SET ^DD(J,.02,9)="^"
+12 FOR J=120.823,120.824,120.8205
SET ^DD(J,.01,9)="^"
+13 QUIT
+14 ;
RESDEV ;Set up resource device
+1 NEW X
+2 SET X=$$RES^XUDHSET("GMRA UPDATE RESOURCE",,1,"Allergy update control")
+3 QUIT
+4 ;
FIXREF ;Fix new style xrefs so they fire when using DIK to set xrefs for an entry in the file
+1 NEW LCV,DIE,DR,DA
+2 SET LCV=0
FOR
SET LCV=$ORDER(^DD("IX","IX","AHDR",LCV))
if '+LCV
QUIT
SET DIE="^DD(""IX"","
SET DA=LCV
SET DR=".41///"_"R"
DO ^DIE
+3 QUIT
