Routine: GMRA1007

GMRA1007 ;IHS/MSC/PLS - Patch support;24-Mar-2014 12:10;DU

 ;;4.0;Adverse Reaction Tracking;**1007**;Mar 29, 1996;Build 18

ENV ;EP -

 N PATCH

 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 ;Check for the installation of other patches

 S PATCH="GMRA*4.0*1006"

 I '$$PATCH(PATCH) D  Q

 . W !,"You must first install "_PATCH_"." S XPDQUIT=2

 ;Check for the installation of IHS terminology services

 S IN="IHS STANDARD TERMINOLOGY 1.0",INSTDA=""

 I '$D(^XPD(9.7,"B",IN)) D  Q

 .W !,"You must first install IHS STANDARD TERMINOLOGY 1.0 before this patch"

 S INSTDA=$O(^XPD(9.7,"B",IN,INSTDA),-1)

 S STAT=+$P($G(^XPD(9.7,INSTDA,0)),U,9)

 I STAT'=3 D  Q

 .W !,"IHS STANDARD TERMINOLOGY 1.0 must be completely installed before installing this patch"

 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

PATCH(X) ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn

 ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb

 Q:X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N 0

 NEW NUM,I,J

 S I=$O(^DIC(9.4,"C",$P(X,"*"),0)) Q:'I 0

 S J=$O(^DIC(9.4,I,22,"B",$P(X,"*",2),0)),X=$P(X,"*",3) Q:'J 0

 ;check if patch is just a number

 Q:$O(^DIC(9.4,I,22,J,"PAH","B",X,0)) 1

 S NUM=$O(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))

 Q (X=+NUM)

PRE ;EP -

POST ;EP Run the post-init routines

 D EVENTS

 D INACT

 D ADDSYM

 D ADDING

 S X=$$ADD^XPDMENU("GMRA CLINICIAN MENU","GMRAZ NO ALLERGY ASSESSMENT","8")

 I 'X W "Attempt to add GMRA menu option option failed." H 3

EVENTS ;Enter old SNOMED event codes

 N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,DIR

 S ZTRTN="UPDATE^GMRA1007",ZTIO="",ZTSAVE("DUZ")=""

 S ZTDESC="Store Event Codes, SNOMEDs and UNIIs on old allergies"

 D ^%ZTLOAD

 I $G(ZTSK) D

 .K ^XTMP("GMRA1007")

 .N X,X1,X2 S X1=DT,X2=30

 .D C^%DTC

 .S ^XTMP("GMRA1007",0)=X_"^"_DT_"^"

 .S ^XTMP("GMRA1007","COUNT")=0

 .W !!,"A task has been queued in the background."

 .W !,"  The task number is "_$G(ZTSK)_"."

 .W !,"  To check on the status of the task, in programmer mode "

 .W !,"    type D STATUS^GMRA1007"

N X

UPDATE ; Run the post-init

 S ^XTMP("GMRA1007","STARTDT")=$$NOW^XLFDT

 D EVENT

 D BACKLOAD^GMRAZRXU

 S ^XTMP("GMRA1007","ENDDT")=$$NOW^XLFDT

 D MAIL

EVENT ; EP Populate old allergies with event codes

 N IEN,TYPE,CNT,ECNT,EIE,MECH

 S CNT=0,ECNT=0

 S IEN=0 F  S IEN=$O(^GMR(120.8,IEN)) Q:'+IEN  D

 .S EIE=$$GET1^DIQ(120.8,IEN,22)

 .Q:EIE'=""

 .I $P($G(^GMR(120.8,IEN,9999999.11)),U,2)=""  D

 ..S TYPE=$$GET1^DIQ(120.8,IEN,3.1,"I")

 ..S MECH=$$GET1^DIQ(120.8,IEN,17,"I")

 ..I MECH="" S MECH="U"

 ..I TYPE="" S TYPE="O"

 ..D ADD(IEN,MECH,TYPE)

ADD(IEN,MECH,TYPE) ;ADD the event code

 N SNO,IENS,ERR,SNOIEN,FDA

 I MECH="A" D

 .S SNO=$S(TYPE="D":"DRUG ALLERGY",TYPE="F":"FOOD ALLERGY",1:"ALLERGY TO SUBSTANCE")

 I MECH="P" D

 .S SNO=$S(TYPE="D":"DRUG INTOLERANCE",TYPE="F":"FOOD INTOLERANCE",1:"PROPENSITY TO ADVERSE REACTIONS TO SUBSTANCE")

 I MECH="U" D

 .S SNO=$S(TYPE="D":"PROPENSITY TO ADVERSE REACTIONS TO DRUG",TYPE="F":"FOOD INTOLERANCE",1:"PROPENSITY TO ADVERSE REACTIONS TO SUBSTANCE")

 S SNOIEN=$O(^BEHOAR(90460.06,"B",SNO,""))

 S IENS=IEN_","

 K AIEN,ERR

 S FDA(120.8,IENS,9999999.13)=SNOIEN

 D UPDATE^DIE("","FDA","AIEN","ERR")

 K FDA,AIEN,ERR

STATUS ;check on status of VS xref indexing

 I $G(^XTMP("GMRA1007","ENDDT")) D

 . N START,END,X,Y

 . W !,"Data update completed!"

 . S Y=$G(^XTMP("GMRA1007","STARTDT")) D DD^%DT

 . W !,"Task started: "_Y

 . S Y=$G(^XTMP("GMRA1007","ENDDT")) D DD^%DT

 . W !,"Task ended:   "_Y

 I '$G(^XTMP("GMRA1007","ENDDT")) D

 . W !,"Still working on the update."

 . I $G(^XTMP("GMRA1007","COUNT"))=0 W !,"You must have tasked it!"

INACT ;EP Remove duplicate toothpaste entries

 N IEN,X,SAVE

 S SAVE=0

 S IEN="" F  S IEN=$O(^GMRD(120.82,"B","TOOTHPASTE",IEN)) Q:IEN=""  D

 .S X=$$CHECK^ORWDAL32(IEN)

 .I X=0&(SAVE=0) S SAVE=1

 .E  I X=0&(SAVE=1) D INAC(IEN)

INAC(IEN) ;Inactivate this entry

 K ERR,FDA,NIEN,FNUM

 S FNUM=120.8299

 S AIEN="+1,"_IEN_","

 S FDA(120.8299,AIEN,.01)=$$NOW^XLFDT

 S FDA(120.8299,AIEN,.02)=0

 D UPDATE^DIE(,"FDA","NIEN","ERR")

 I $D(ERR) W !,IENS W ERR("DIERR",1,"TEXT",1) W !

MAIL ;Send completion message to user who initiated post-install

 N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,TXT,GMRATXT

 S XMDUZ="PATCH GMRA*4*1007 Backload event codes",XMY(.5)=""

 S:$G(DUZ) XMY(DUZ)=""

 S GMRATXT(1)="Backload SNOMED and UNII codes"

 S GMRATXT(2)=""

 S GMRATXT(3)="Task Started: "_$$FMTE^XLFDT($G(^XTMP("GMRA1007","STARTDT")))

 S GMRATXT(4)="Task   Ended: "_$$FMTE^XLFDT($G(^XTMP("GMRA1007","ENDDT")))

 S GMRATXT(5)=""

 S XMTEXT="GMRATXT(",XMSUB="GMRA*4*1007 SNOMED Event backload"

 D ^XMD

ADDSYM ;Add new symptom to the file

 N XUMF,FDA,IEN,IENS,ERR,FILE,SIEN,SIGN,SYN,SYNIEN

 S SIGN="THROAT IRRITATION"

 S SYN="ITCHING OF THROAT"

 S SIEN=$O(^GMRD(120.83,"B",SIGN,"")) Q:SIEN=""  D

 .S SYNIEN=$O(^GMRD(120.83,SIEN,2,"B",SYN,"")) Q:SYNIEN'=""  D

 ..S XUMF=1,FILE=120.832

 ..S IENS="+1,"_SIEN_","

 ..S FDA(FILE,IENS,.01)=SYN

 ..D UPDATE^DIE("","FDA","IENS","ERR")

ADDING ;Add new ingredient to the file

 N SULFA,ING,INGIEN,SULIEN,IENS,IEN2,ERR,FDA,FILE,IENS,IN,X,PT,RXNORM,UNII

 S SULFA="SULFA DRUGS"

 S ING="SULFISOXAZOLE"

 S INGIEN="" S INGIEN=$O(^PS(50.416,"B",ING,INGIEN))

 Q:INGIEN=""

 S SULIEN="" S SULIEN=$O(^GMRD(120.82,"B",SULFA,SULIEN))

 Q:SULIEN=""

 S XUMF=1,FILE=120.824

 ;Continue if its not already there

 S ERR=""

 I $D(^GMRD(120.82,SULIEN,"ING","B",INGIEN))=0 D

 .S IENS="+1,"_SULIEN_","

 .S FDA(FILE,IENS,.01)=INGIEN

 .D UPDATE^DIE("","FDA","IEN2","ERR")

 Q:ERR

 ;Next update users with this allergy

 S IN=ING_U_"32771^^1"

 S X=$$ASSOC^BSTSAPI(IN)

 I $P(X,U,2)'=""!($P(X,U,3)'="") D

 .S RXNORM=$P(X,U,2),UNII=$P(X,U,3)

 S PT="" F  S PT=$O(^GMR(120.8,"C",SULFA,PT)) Q:'+PT  D

 .I $D(^GMR(120.8,PT,2,"B",INGIEN))=0 D

 ..K FDA,IENS,IEN2

 ..S IENS="+1,"_PT_","

 ..S FDA(120.802,IENS,.01)=INGIEN

 ..S FDA(120.802,IENS,9999999.01)=RXNORM

 ..S FDA(120.802,IENS,9999999.02)=UNII

 ..D UPDATE^DIE(,"FDA","IEN2","ERR")

GMRA1007  ;IHS/MSC/PLS - Patch support;24-Mar-2014 12:10;DU

 +1       ;;4.0;Adverse Reaction Tracking;**1007**;Mar 29, 1996;Build 18

 +2       ;

ENV       ;EP -

 +1        NEW PATCH

 +2        SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +3       ;

 +4       ;Check for the installation of other patches

 +5        SET PATCH="GMRA*4.0*1006"

 +6        IF '$$PATCH(PATCH)

               Begin DoDot:1

 +7                WRITE !,"You must first install "_PATCH_"."

                   SET XPDQUIT=2

               End DoDot:1

               QUIT

 +8       ;Check for the installation of IHS terminology services

 +9        SET IN="IHS STANDARD TERMINOLOGY 1.0"

           SET INSTDA=""

 +10       IF '$DATA(^XPD(9.7,"B",IN))

               Begin DoDot:1

 +11               WRITE !,"You must first install IHS STANDARD TERMINOLOGY 1.0 before this patch"

               End DoDot:1

               QUIT

 +12       SET INSTDA=$ORDER(^XPD(9.7,"B",IN,INSTDA),-1)

 +13       SET STAT=+$PIECE($GET(^XPD(9.7,INSTDA,0)),U,9)

 +14       IF STAT'=3

               Begin DoDot:1

 +15               WRITE !,"IHS STANDARD TERMINOLOGY 1.0 must be completely installed before installing this patch"

               End DoDot:1

               QUIT

 +16       SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0

 +17       QUIT

 +18      ;

PATCH(X)  ;return 1 if patch X was installed, X=aaaa*nn.nn*nnnn

 +1       ;copy of code from XPDUTL but modified to handle 4 digit IHS patch numb

 +2        IF X'?1.4UN1"*"1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.4N

               QUIT 0

 +3        NEW NUM,I,J

 +4        SET I=$ORDER(^DIC(9.4,"C",$PIECE(X,"*"),0))

           IF 'I

               QUIT 0

 +5        SET J=$ORDER(^DIC(9.4,I,22,"B",$PIECE(X,"*",2),0))

           SET X=$PIECE(X,"*",3)

           IF 'J

               QUIT 0

 +6       ;check if patch is just a number

 +7        IF $ORDER(^DIC(9.4,I,22,J,"PAH","B",X,0))

               QUIT 1

 +8        SET NUM=$ORDER(^DIC(9.4,I,22,J,"PAH","B",X_" SEQ"))

 +9        QUIT (X=+NUM)

PRE       ;EP -

 +1        QUIT

POST      ;EP Run the post-init routines

 +1        DO EVENTS

 +2        DO INACT

 +3        DO ADDSYM

 +4        DO ADDING

 +5        SET X=$$ADD^XPDMENU("GMRA CLINICIAN MENU","GMRAZ NO ALLERGY ASSESSMENT","8")

 +6        IF 'X

               WRITE "Attempt to add GMRA menu option option failed."

               HANG 3

 +7        QUIT

EVENTS    ;Enter old SNOMED event codes

 +1        NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,DIR

 +2        SET ZTRTN="UPDATE^GMRA1007"

           SET ZTIO=""

           SET ZTSAVE("DUZ")=""

 +3        SET ZTDESC="Store Event Codes, SNOMEDs and UNIIs on old allergies"

 +4        DO ^%ZTLOAD

 +5        IF $GET(ZTSK)

               Begin DoDot:1

 +6                KILL ^XTMP("GMRA1007")

 +7                NEW X,X1,X2

                   SET X1=DT

                   SET X2=30

 +8                DO C^%DTC

 +9                SET ^XTMP("GMRA1007",0)=X_"^"_DT_"^"

 +10               SET ^XTMP("GMRA1007","COUNT")=0

 +11               WRITE !!,"A task has been queued in the background."

 +12               WRITE !,"  The task number is "_$GET(ZTSK)_"."

 +13               WRITE !,"  To check on the status of the task, in programmer mode "

 +14               WRITE !,"    type D STATUS^GMRA1007"

               End DoDot:1

 +15       NEW X

 +16       QUIT

UPDATE    ; Run the post-init

 +1        SET ^XTMP("GMRA1007","STARTDT")=$$NOW^XLFDT

 +2        DO EVENT

 +3        DO BACKLOAD^GMRAZRXU

 +4        SET ^XTMP("GMRA1007","ENDDT")=$$NOW^XLFDT

 +5        DO MAIL

 +6        QUIT

EVENT     ; EP Populate old allergies with event codes

 +1        NEW IEN,TYPE,CNT,ECNT,EIE,MECH

 +2        SET CNT=0

           SET ECNT=0

 +3        SET IEN=0

FOR

               SET IEN=$ORDER(^GMR(120.8,IEN))

               IF '+IEN

                   QUIT

               Begin DoDot:1

 +4                SET EIE=$$GET1^DIQ(120.8,IEN,22)

 +5                IF EIE'=""

                       QUIT

 +6                IF $PIECE($GET(^GMR(120.8,IEN,9999999.11)),U,2)=""

                       Begin DoDot:2

 +7                        SET TYPE=$$GET1^DIQ(120.8,IEN,3.1,"I")

 +8                        SET MECH=$$GET1^DIQ(120.8,IEN,17,"I")

 +9                        IF MECH=""

                               SET MECH="U"

 +10                       IF TYPE=""

                               SET TYPE="O"

 +11                       DO ADD(IEN,MECH,TYPE)

                       End DoDot:2

               End DoDot:1

 +12       QUIT

ADD(IEN,MECH,TYPE) ;ADD the event code

 +1        NEW SNO,IENS,ERR,SNOIEN,FDA

 +2        IF MECH="A"

               Begin DoDot:1

 +3                SET SNO=$SELECT(TYPE="D":"DRUG ALLERGY",TYPE="F":"FOOD ALLERGY",1:"ALLERGY TO SUBSTANCE")

               End DoDot:1

 +4        IF MECH="P"

               Begin DoDot:1

 +5                SET SNO=$SELECT(TYPE="D":"DRUG INTOLERANCE",TYPE="F":"FOOD INTOLERANCE",1:"PROPENSITY TO ADVERSE REACTIONS TO SUBSTANCE")

               End DoDot:1

 +6        IF MECH="U"

               Begin DoDot:1

 +7                SET SNO=$SELECT(TYPE="D":"PROPENSITY TO ADVERSE REACTIONS TO DRUG",TYPE="F":"FOOD INTOLERANCE",1:"PROPENSITY TO ADVERSE REACTIONS TO SUBSTANCE")

               End DoDot:1

 +8        SET SNOIEN=$ORDER(^BEHOAR(90460.06,"B",SNO,""))

 +9        SET IENS=IEN_","

 +10       KILL AIEN,ERR

 +11       SET FDA(120.8,IENS,9999999.13)=SNOIEN

 +12       DO UPDATE^DIE("","FDA","AIEN","ERR")

 +13       KILL FDA,AIEN,ERR

 +14       QUIT

STATUS    ;check on status of VS xref indexing

 +1        IF $GET(^XTMP("GMRA1007","ENDDT"))

               Begin DoDot:1

 +2                NEW START,END,X,Y

 +3                WRITE !,"Data update completed!"

 +4                SET Y=$GET(^XTMP("GMRA1007","STARTDT"))

                   DO DD^%DT

 +5                WRITE !,"Task started: "_Y

 +6                SET Y=$GET(^XTMP("GMRA1007","ENDDT"))

                   DO DD^%DT

 +7                WRITE !,"Task ended:   "_Y

               End DoDot:1

 +8        IF '$GET(^XTMP("GMRA1007","ENDDT"))

               Begin DoDot:1

 +9                WRITE !,"Still working on the update."

 +10               IF $GET(^XTMP("GMRA1007","COUNT"))=0

                       WRITE !,"You must have tasked it!"

               End DoDot:1

 +11       QUIT

INACT     ;EP Remove duplicate toothpaste entries

 +1        NEW IEN,X,SAVE

 +2        SET SAVE=0

 +3        SET IEN=""

FOR

               SET IEN=$ORDER(^GMRD(120.82,"B","TOOTHPASTE",IEN))

               IF IEN=""

                   QUIT

               Begin DoDot:1

 +4                SET X=$$CHECK^ORWDAL32(IEN)

 +5                IF X=0&(SAVE=0)

                       SET SAVE=1

 +6               IF '$TEST

                       IF X=0&(SAVE=1)

                           DO INAC(IEN)

               End DoDot:1

 +7        QUIT

INAC(IEN) ;Inactivate this entry

 +1        KILL ERR,FDA,NIEN,FNUM

 +2        SET FNUM=120.8299

 +3        SET AIEN="+1,"_IEN_","

 +4        SET FDA(120.8299,AIEN,.01)=$$NOW^XLFDT

 +5        SET FDA(120.8299,AIEN,.02)=0

 +6        DO UPDATE^DIE(,"FDA","NIEN","ERR")

 +7        IF $DATA(ERR)

               WRITE !,IENS

               WRITE ERR("DIERR",1,"TEXT",1)

               WRITE !

 +8        QUIT

MAIL      ;Send completion message to user who initiated post-install

 +1        NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,TXT,GMRATXT

 +2        SET XMDUZ="PATCH GMRA*4*1007 Backload event codes"

           SET XMY(.5)=""

 +3        IF $GET(DUZ)

               SET XMY(DUZ)=""

 +4        SET GMRATXT(1)="Backload SNOMED and UNII codes"

 +5        SET GMRATXT(2)=""

 +6        SET GMRATXT(3)="Task Started: "_$$FMTE^XLFDT($GET(^XTMP("GMRA1007","STARTDT")))

 +7        SET GMRATXT(4)="Task   Ended: "_$$FMTE^XLFDT($GET(^XTMP("GMRA1007","ENDDT")))

 +8        SET GMRATXT(5)=""

 +9        SET XMTEXT="GMRATXT("

           SET XMSUB="GMRA*4*1007 SNOMED Event backload"

 +10       DO ^XMD

 +11       QUIT

ADDSYM    ;Add new symptom to the file

 +1        NEW XUMF,FDA,IEN,IENS,ERR,FILE,SIEN,SIGN,SYN,SYNIEN

 +2        SET SIGN="THROAT IRRITATION"

 +3        SET SYN="ITCHING OF THROAT"

 +4        SET SIEN=$ORDER(^GMRD(120.83,"B",SIGN,""))

           IF SIEN=""

               QUIT

           Begin DoDot:1

 +5            SET SYNIEN=$ORDER(^GMRD(120.83,SIEN,2,"B",SYN,""))

               IF SYNIEN'=""

                   QUIT

               Begin DoDot:2

 +6                SET XUMF=1

                   SET FILE=120.832

 +7                SET IENS="+1,"_SIEN_","

 +8                SET FDA(FILE,IENS,.01)=SYN

 +9                DO UPDATE^DIE("","FDA","IENS","ERR")

               End DoDot:2

           End DoDot:1

 +10       QUIT

ADDING    ;Add new ingredient to the file

 +1        NEW SULFA,ING,INGIEN,SULIEN,IENS,IEN2,ERR,FDA,FILE,IENS,IN,X,PT,RXNORM,UNII

 +2        SET SULFA="SULFA DRUGS"

 +3        SET ING="SULFISOXAZOLE"

 +4        SET INGIEN=""

           SET INGIEN=$ORDER(^PS(50.416,"B",ING,INGIEN))

 +5        IF INGIEN=""

               QUIT

 +6        SET SULIEN=""

           SET SULIEN=$ORDER(^GMRD(120.82,"B",SULFA,SULIEN))

 +7        IF SULIEN=""

               QUIT

 +8        SET XUMF=1

           SET FILE=120.824

 +9       ;Continue if its not already there

 +10       SET ERR=""

 +11       IF $DATA(^GMRD(120.82,SULIEN,"ING","B",INGIEN))=0

               Begin DoDot:1

 +12               SET IENS="+1,"_SULIEN_","

 +13               SET FDA(FILE,IENS,.01)=INGIEN

 +14               DO UPDATE^DIE("","FDA","IEN2","ERR")

               End DoDot:1

 +15       IF ERR

               QUIT

 +16      ;Next update users with this allergy

 +17       SET IN=ING_U_"32771^^1"

 +18       SET X=$$ASSOC^BSTSAPI(IN)

 +19       IF $PIECE(X,U,2)'=""!($PIECE(X,U,3)'="")

               Begin DoDot:1

 +20               SET RXNORM=$PIECE(X,U,2)

                   SET UNII=$PIECE(X,U,3)

               End DoDot:1

 +21       SET PT=""

FOR

               SET PT=$ORDER(^GMR(120.8,"C",SULFA,PT))

               IF '+PT

                   QUIT

               Begin DoDot:1

 +22               IF $DATA(^GMR(120.8,PT,2,"B",INGIEN))=0

                       Begin DoDot:2

 +23                       KILL FDA,IENS,IEN2

 +24                       SET IENS="+1,"_PT_","

 +25                       SET FDA(120.802,IENS,.01)=INGIEN

 +26                       SET FDA(120.802,IENS,9999999.01)=RXNORM

 +27                       SET FDA(120.802,IENS,9999999.02)=UNII

 +28                       DO UPDATE^DIE(,"FDA","IEN2","ERR")

                       End DoDot:2

               End DoDot:1

 +29       QUIT

GMRA1007.m