- 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 Feb 18, 2025@23:07:17 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