- 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 Mar 13, 2025@20:45:30 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
