GMRAY17 ;SLC/DAN Post-init for patch 17 ;10/20/03 14:24
;;4.0;Adverse Reaction Tracking;**17**;Mar 29, 1996
;
;DBIA SECTION
;10063 - %ZTLOAD
;3744 - $$TESTPAT^VADPT
;10018 - DIE
;10013 - DIK
;2056 - DIQ
;10103 - XLFDT
;10104 - XLFSTR
;10070 - XMD
;10141 - XPDUTL
;
Q ;Entry point to queue process during install
N ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK
S ZTRTN="DQ^GMRAY17",ZTDESC="GMRA*4*17 POST INSTALL ROUTINE",ZTIO="",ZTDTH=$H
D ^%ZTLOAD I '$G(ZTSK) D BMES^XPDUTL("POST INSTALL NOT QUEUED - RUN DQ^GMRA17 AFTER INSTALL FINISHES") Q
D BMES^XPDUTL("Post-install queued as task # "_$G(ZTSK))
Q
;
DQ ;Dequeue
D POST,MAIL
Q
;
POST ;Post-init entry point
;Update lower case entries
N NAME,IEN,AIEN,DA,DIE,DR,RIEN,SIEN,ROOT,GMRAI,GMRA0,LCV,CNT,PCNT,PROB,DIK,FILE,FILEIEN
;Re-index 120.85 as previous bug may have left xrefs unset
S DIK="^GMR(120.85," D IXALL^DIK
F ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")" D
.S NAME=""
.F S NAME=$O(@ROOT@(NAME)) Q:NAME="" I NAME?.E1L.E D
..S IEN=0 F S IEN=$O(@ROOT@(NAME,IEN)) Q:'+IEN I '$P(^GMRD(120.82,IEN,0),U,3) D
...S DIE="^GMRD(120.82,"_$S(ROOT["""D""":"DA(1),3,",1:""),DR=".01///"_$$UP^XLFSTR(NAME)
...I ROOT["""D""" S DA(1)=IEN,DA=$O(@ROOT@(NAME,IEN,0))
...I ROOT["""B""" S DA=IEN
...D ^DIE K DA
...S AIEN=0 F S AIEN=$O(^GMR(120.8,"C",NAME,AIEN)) Q:'+AIEN I $P(^GMR(120.8,AIEN,0),U,3)=(IEN_";GMRD(120.82,") S DIE="^GMR(120.8,",DA=AIEN,DR=".02////"_$$UP^XLFSTR(NAME) D ^DIE K DA D
....I $D(^GMR(120.85,"C",AIEN)) D ;Observed reaction for this reactant
.....S RIEN=0 F S RIEN=$O(^GMR(120.85,"C",AIEN,RIEN)) Q:'+RIEN D
......S SIEN=$O(^GMR(120.85,RIEN,3,"B",NAME,0)) Q:'+SIEN
......S DA(1)=RIEN,DA=SIEN,DIE="^GMR(120.85,DA(1),3,",DR=".01////^S X=$$UP^XLFSTR(NAME)" D ^DIE
;
;Find entries in 120.8 that are missing the reactant or are missing additional required data and take appropriate action.
K DA
S GMRAI=0 F S GMRAI=$O(^GMR(120.8,GMRAI)) Q:'+GMRAI D
.I '$D(^GMR(120.8,GMRAI,0)) Q ;Don't process if missing zero node
.S GMRA0=$G(^GMR(120.8,GMRAI,0))
.I $L(GMRA0,U)=1 S DIK="^GMR(120.8,",DA=GMRAI D ^DIK Q ;Delete entry if only the 1st piece of the zero node is present
.I $P(GMRA0,U,4)'=+$P(GMRA0,U,4) D FIXDATE
.I $P(GMRA0,U,6)="o",$P(GMRA0,U,20)["D" D CHECKOBS
.I $D(^GMR(120.8,GMRAI,10,"B",-1)) D FIXREACT ;If -1 is stored as reactant delete it
.I $P(GMRA0,U,2)="",$P(GMRA0,U,3)'="" D ;If no reactant but pointer is present then set reactant
..S ENTRY=$P(GMRA0,U,3)
..S FILE=+$P(@("^"_$P(ENTRY,";",2)_"0)"),U,2)
..S FILEIEN=$P(ENTRY,";")
..S NAME=$$GET1^DIQ(FILE,FILEIEN,$S(FILE'=50.67:.01,1:4))
..S DIE="^GMR(120.8,",DA=GMRAI,DR=".02////"_NAME D ^DIE
;Check observed data to make sure it's matched to the right patient
S LCV=0 F S LCV=$O(^GMR(120.85,LCV)) Q:'+LCV D
.S GMRA0=$G(^GMR(120.85,LCV,0)) Q:GMRA0=""
.I $P(GMRA0,U,2)'=$P($G(^GMR(120.8,$P(GMRA0,U,15),0)),U) S DIK="^GMR(120.85,",DA=LCV D ^DIK
Q
;
FIXDATE ;Update origination date to get rid of trailing zeros. Problem was caused by a bug in XLFDT
N DIE,DR,DA
S DIE="^GMR(120.8,",DA=GMRAI,DR="4////"_+$P(GMRA0,U,4)
D ^DIE
Q
;
CHECKOBS ;Check observation data to make sure it's present and accurate
Q:$D(^GMR(120.8,GMRAI,"ER"))!($$TESTPAT^VADPT($P(GMRA0,U)))!($$DECEASED^GMRAFX($P(GMRA0,U))) ;Stop if allergy entered in error, test patient or deceased patient
I $P(GMRA0,U,12)=1 D
.I '$D(^GMR(120.85,"C",GMRAI)) S PROB($P(GMRA0,U),GMRAI)="OBS" Q ;Marked as observed but no data
.S J=0 F S J=$O(^GMR(120.85,"C",GMRAI,J)) Q:'+J I '$O(^GMR(120.85,J,2,0)) S PROB($P(GMRA0,U),GMRAI)="SS" ;Has observed data but no sign/symptoms
Q
;
MAIL ;Send message indicating post install is finished
N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,GMRATXT
S XMDUZ="PATCH GMRA*4*17 POST-INSTALL",XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""
S GMRATXT(1)="The post-install routine for patch GMRA*4*17"
S GMRATXT(2)="finished on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
S GMRATXT(3)=""
S CNT=3 I $D(PROB) D
.S CNT=CNT+1,GMRATXT(CNT)="The following patients have observed allergy entries that are"
.S CNT=CNT+1,GMRATXT(CNT)="signed off (accepted) but are missing required data. Please review each"
.S CNT=CNT+1,GMRATXT(CNT)="entry and and update (if data is known), mark it as entered in error,"
.S CNT=CNT+1,GMRATXT(CNT)="or leave it alone."
.S CNT=CNT+1,GMRATXT(CNT)=""
.S PCNT=0
.F S PCNT=$O(PROB(PCNT)) Q:'+PCNT D
..S DFN=PCNT D DEM^VADPT
..S IEN=0 F S IEN=$O(PROB(PCNT,IEN)) Q:'+IEN D
...S CNT=CNT+1
...S GMRATXT(CNT)=VADM(1)_" "_$P($P(VADM(2),U,2),"-",3)_" "_$P(^GMR(120.8,IEN,0),U,2)_" missing "_$S(PROB(PCNT,IEN)="OBS":"observation date",1:"sign/symptoms")
..S CNT=CNT+1,GMRATXT(CNT)=""
S CNT=CNT+1,GMRATXT(CNT)="You should"_$S($D(PROB):" also ",1:" ")_"run option GMRA PRINT-NOT SIGNED OFF to get a listing"
S CNT=CNT+1,GMRATXT(CNT)="of all entries that have not yet been signed off. These entries"
S CNT=CNT+1,GMRATXT(CNT)="should be reviewed and updated if possible. They can be left alone"
S CNT=CNT+1,GMRATXT(CNT)="if additional data is unavailable."
S XMTEXT="GMRATXT(",XMSUB="PATCH GMRA*4*17 Post Install COMPLETED"
D ^XMD
Q
;
FIXREACT ;delete any sign/symptoms erroneously stored as -1
N DIK,DA,RIEN
S DA(1)=GMRAI,DA=$O(^GMR(120.8,GMRAI,10,"B",-1,0)),DIK="^GMR(120.8,DA(1),10," D ^DIK
;Now check 120.85 for corresponding entries
S RIEN=$O(^GMR(120.85,"C",GMRAI,0)) Q:'+RIEN
S DA(1)=RIEN,DA=$O(^GMR(120.85,RIEN,2,"B",-1,0)),DIK="^GMR(120.85,DA(1),2," D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAY17 5560 printed Apr 09, 2024@20:45:39 Page 2
GMRAY17 ;SLC/DAN Post-init for patch 17 ;10/20/03 14:24
+1 ;;4.0;Adverse Reaction Tracking;**17**;Mar 29, 1996
+2 ;
+3 ;DBIA SECTION
+4 ;10063 - %ZTLOAD
+5 ;3744 - $$TESTPAT^VADPT
+6 ;10018 - DIE
+7 ;10013 - DIK
+8 ;2056 - DIQ
+9 ;10103 - XLFDT
+10 ;10104 - XLFSTR
+11 ;10070 - XMD
+12 ;10141 - XPDUTL
+13 ;
Q ;Entry point to queue process during install
+1 NEW ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK
+2 SET ZTRTN="DQ^GMRAY17"
SET ZTDESC="GMRA*4*17 POST INSTALL ROUTINE"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+3 DO ^%ZTLOAD
IF '$GET(ZTSK)
DO BMES^XPDUTL("POST INSTALL NOT QUEUED - RUN DQ^GMRA17 AFTER INSTALL FINISHES")
QUIT
+4 DO BMES^XPDUTL("Post-install queued as task # "_$GET(ZTSK))
+5 QUIT
+6 ;
DQ ;Dequeue
+1 DO POST
DO MAIL
+2 QUIT
+3 ;
POST ;Post-init entry point
+1 ;Update lower case entries
+2 NEW NAME,IEN,AIEN,DA,DIE,DR,RIEN,SIEN,ROOT,GMRAI,GMRA0,LCV,CNT,PCNT,PROB,DIK,FILE,FILEIEN
+3 ;Re-index 120.85 as previous bug may have left xrefs unset
+4 SET DIK="^GMR(120.85,"
DO IXALL^DIK
+5 FOR ROOT="^GMRD(120.82,""B"")","^GMRD(120.82,""D"")"
Begin DoDot:1
+6 SET NAME=""
+7 FOR
SET NAME=$ORDER(@ROOT@(NAME))
if NAME=""
QUIT
IF NAME?.E1L.E
Begin DoDot:2
+8 SET IEN=0
FOR
SET IEN=$ORDER(@ROOT@(NAME,IEN))
if '+IEN
QUIT
IF '$PIECE(^GMRD(120.82,IEN,0),U,3)
Begin DoDot:3
+9 SET DIE="^GMRD(120.82,"_$SELECT(ROOT["""D""":"DA(1),3,",1:"")
SET DR=".01///"_$$UP^XLFSTR(NAME)
+10 IF ROOT["""D"""
SET DA(1)=IEN
SET DA=$ORDER(@ROOT@(NAME,IEN,0))
+11 IF ROOT["""B"""
SET DA=IEN
+12 DO ^DIE
KILL DA
+13 SET AIEN=0
FOR
SET AIEN=$ORDER(^GMR(120.8,"C",NAME,AIEN))
if '+AIEN
QUIT
IF $PIECE(^GMR(120.8,AIEN,0),U,3)=(IEN_";GMRD(120.82,")
SET DIE="^GMR(120.8,"
SET DA=AIEN
SET DR=".02////"_$$UP^XLFSTR(NAME)
DO ^DIE
KILL DA
Begin DoDot:4
+14 ;Observed reaction for this reactant
IF $DATA(^GMR(120.85,"C",AIEN))
Begin DoDot:5
+15 SET RIEN=0
FOR
SET RIEN=$ORDER(^GMR(120.85,"C",AIEN,RIEN))
if '+RIEN
QUIT
Begin DoDot:6
+16 SET SIEN=$ORDER(^GMR(120.85,RIEN,3,"B",NAME,0))
if '+SIEN
QUIT
+17 SET DA(1)=RIEN
SET DA=SIEN
SET DIE="^GMR(120.85,DA(1),3,"
SET DR=".01////^S X=$$UP^XLFSTR(NAME)"
DO ^DIE
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 ;Find entries in 120.8 that are missing the reactant or are missing additional required data and take appropriate action.
+20 KILL DA
+21 SET GMRAI=0
FOR
SET GMRAI=$ORDER(^GMR(120.8,GMRAI))
if '+GMRAI
QUIT
Begin DoDot:1
+22 ;Don't process if missing zero node
IF '$DATA(^GMR(120.8,GMRAI,0))
QUIT
+23 SET GMRA0=$GET(^GMR(120.8,GMRAI,0))
+24 ;Delete entry if only the 1st piece of the zero node is present
IF $LENGTH(GMRA0,U)=1
SET DIK="^GMR(120.8,"
SET DA=GMRAI
DO ^DIK
QUIT
+25 IF $PIECE(GMRA0,U,4)'=+$PIECE(GMRA0,U,4)
DO FIXDATE
+26 IF $PIECE(GMRA0,U,6)="o"
IF $PIECE(GMRA0,U,20)["D"
DO CHECKOBS
+27 ;If -1 is stored as reactant delete it
IF $DATA(^GMR(120.8,GMRAI,10,"B",-1))
DO FIXREACT
+28 ;If no reactant but pointer is present then set reactant
IF $PIECE(GMRA0,U,2)=""
IF $PIECE(GMRA0,U,3)'=""
Begin DoDot:2
+29 SET ENTRY=$PIECE(GMRA0,U,3)
+30 SET FILE=+$PIECE(@("^"_$PIECE(ENTRY,";",2)_"0)"),U,2)
+31 SET FILEIEN=$PIECE(ENTRY,";")
+32 SET NAME=$$GET1^DIQ(FILE,FILEIEN,$SELECT(FILE'=50.67:.01,1:4))
+33 SET DIE="^GMR(120.8,"
SET DA=GMRAI
SET DR=".02////"_NAME
DO ^DIE
End DoDot:2
End DoDot:1
+34 ;Check observed data to make sure it's matched to the right patient
+35 SET LCV=0
FOR
SET LCV=$ORDER(^GMR(120.85,LCV))
if '+LCV
QUIT
Begin DoDot:1
+36 SET GMRA0=$GET(^GMR(120.85,LCV,0))
if GMRA0=""
QUIT
+37 IF $PIECE(GMRA0,U,2)'=$PIECE($GET(^GMR(120.8,$PIECE(GMRA0,U,15),0)),U)
SET DIK="^GMR(120.85,"
SET DA=LCV
DO ^DIK
End DoDot:1
+38 QUIT
+39 ;
FIXDATE ;Update origination date to get rid of trailing zeros. Problem was caused by a bug in XLFDT
+1 NEW DIE,DR,DA
+2 SET DIE="^GMR(120.8,"
SET DA=GMRAI
SET DR="4////"_+$PIECE(GMRA0,U,4)
+3 DO ^DIE
+4 QUIT
+5 ;
CHECKOBS ;Check observation data to make sure it's present and accurate
+1 ;Stop if allergy entered in error, test patient or deceased patient
if $DATA(^GMR(120.8,GMRAI,"ER"))!($$TESTPAT^VADPT($PIECE(GMRA0,U)))!($$DECEASED^GMRAFX($PIECE(GMRA0,U)))
QUIT
+2 IF $PIECE(GMRA0,U,12)=1
Begin DoDot:1
+3 ;Marked as observed but no data
IF '$DATA(^GMR(120.85,"C",GMRAI))
SET PROB($PIECE(GMRA0,U),GMRAI)="OBS"
QUIT
+4 ;Has observed data but no sign/symptoms
SET J=0
FOR
SET J=$ORDER(^GMR(120.85,"C",GMRAI,J))
if '+J
QUIT
IF '$ORDER(^GMR(120.85,J,2,0))
SET PROB($PIECE(GMRA0,U),GMRAI)="SS"
End DoDot:1
+5 QUIT
+6 ;
MAIL ;Send message indicating post install is finished
+1 NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,GMRATXT
+2 SET XMDUZ="PATCH GMRA*4*17 POST-INSTALL"
SET XMY(.5)=""
if $GET(DUZ)
SET XMY(DUZ)=""
+3 SET GMRATXT(1)="The post-install routine for patch GMRA*4*17"
+4 SET GMRATXT(2)="finished on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
+5 SET GMRATXT(3)=""
+6 SET CNT=3
IF $DATA(PROB)
Begin DoDot:1
+7 SET CNT=CNT+1
SET GMRATXT(CNT)="The following patients have observed allergy entries that are"
+8 SET CNT=CNT+1
SET GMRATXT(CNT)="signed off (accepted) but are missing required data. Please review each"
+9 SET CNT=CNT+1
SET GMRATXT(CNT)="entry and and update (if data is known), mark it as entered in error,"
+10 SET CNT=CNT+1
SET GMRATXT(CNT)="or leave it alone."
+11 SET CNT=CNT+1
SET GMRATXT(CNT)=""
+12 SET PCNT=0
+13 FOR
SET PCNT=$ORDER(PROB(PCNT))
if '+PCNT
QUIT
Begin DoDot:2
+14 SET DFN=PCNT
DO DEM^VADPT
+15 SET IEN=0
FOR
SET IEN=$ORDER(PROB(PCNT,IEN))
if '+IEN
QUIT
Begin DoDot:3
+16 SET CNT=CNT+1
+17 SET GMRATXT(CNT)=VADM(1)_" "_$PIECE($PIECE(VADM(2),U,2),"-",3)_" "_$PIECE(^GMR(120.8,IEN,0),U,2)_" missing "_$SELECT(PROB(PCNT,IEN)="OBS":"observation date",1:"sign/symptoms")
End DoDot:3
+18 SET CNT=CNT+1
SET GMRATXT(CNT)=""
End DoDot:2
End DoDot:1
+19 SET CNT=CNT+1
SET GMRATXT(CNT)="You should"_$SELECT($DATA(PROB):" also ",1:" ")_"run option GMRA PRINT-NOT SIGNED OFF to get a listing"
+20 SET CNT=CNT+1
SET GMRATXT(CNT)="of all entries that have not yet been signed off. These entries"
+21 SET CNT=CNT+1
SET GMRATXT(CNT)="should be reviewed and updated if possible. They can be left alone"
+22 SET CNT=CNT+1
SET GMRATXT(CNT)="if additional data is unavailable."
+23 SET XMTEXT="GMRATXT("
SET XMSUB="PATCH GMRA*4*17 Post Install COMPLETED"
+24 DO ^XMD
+25 QUIT
+26 ;
FIXREACT ;delete any sign/symptoms erroneously stored as -1
+1 NEW DIK,DA,RIEN
+2 SET DA(1)=GMRAI
SET DA=$ORDER(^GMR(120.8,GMRAI,10,"B",-1,0))
SET DIK="^GMR(120.8,DA(1),10,"
DO ^DIK
+3 ;Now check 120.85 for corresponding entries
+4 SET RIEN=$ORDER(^GMR(120.85,"C",GMRAI,0))
if '+RIEN
QUIT
+5 SET DA(1)=RIEN
SET DA=$ORDER(^GMR(120.85,RIEN,2,"B",-1,0))
SET DIK="^GMR(120.85,DA(1),2,"
DO ^DIK
+6 QUIT
