Routine: GMRAFX1

GMRAFX1 ;SLC/DAN Fix existing allergy entries-continued ;10/6/05  11:42

 ;;4.0;Adverse Reaction Tracking;**17,19,20**;Mar 29, 1996;Build 1

 ;DBIA SECTION

 ;10116 - VALM1

 ;10102 - XQORM1

 ;10104 - XLFSTR

 ;10061 - VADPT

 ;10017 - VALM10

 ;10118 - VALM

 ;10026 - DIR

DET ;Detailed listing of selected group

 N DIR,Y,DTOUT,DUOUT,DIRUT,J,GMRAT,GMRAUT,DFN,GMRA,GMRAL,VADM,CNT,VAERR,K,LEN,NAME,ENTRY,NMBR2,ENMBR,GMRAR

 S VALMBCK="R",CNT=0

 K ^TMP($J,LTYPE,"GMRADET"),^TMP($J,LTYPE,"IDX2")

 S ENMBR=+NMBR ;get number portion of entry

 S ENTRY=0

 S GMRAUT=$P(^XTMP("GMRAFX",LTYPE,"IDX",ENMBR),"^"),GMRAT=$P(^XTMP("GMRAFX",LTYPE,"IDX",ENMBR),"^",2)

 S J=0 F  S J=$O(^XTMP("GMRAFX",LTYPE,"GMRAR",GMRAUT,GMRAT,J)) Q:'+J  D

 .S DFN=$P($G(^GMR(120.8,J,0)),"^"),GMRA="0^0^111" D ^GMRADPT ;Get patient allergies

 .D DEM^VADPT ;Get patient information

 .Q:$G(VAERR)  ;Quit if patient lookup produces an error

 .S CNT=CNT+1,ENTRY=ENTRY+1

 .S GMRAR(CNT)=VADM(1)_$$REPEAT^XLFSTR(" ",(32-$L(VADM(1))))_$E(VADM(2),6,9)_" "

 .D SET^VALM10(CNT,ENTRY_$$REPEAT^XLFSTR(" ",(4-$L(ENTRY)))_GMRAR(CNT)) K GMRAR(CNT) ;19

 .S ^TMP($J,LTYPE,"IDX2",ENTRY)=CNT_"^"_J

 .S CNT=CNT+1,LEN=0,GMRAR(CNT)="Allergies: "

 .S K=0 F  S K=$O(GMRAL(K)) Q:'+K  D

 ..S NAME=$P(GMRAL(K),"^",2) ;Allergy name

 ..S LEN=LEN+$L(NAME)+1

 ..I LEN>70 D SET^VALM10(CNT,GMRAR(CNT)) K GMRAR(CNT) S CNT=CNT+1,LEN=$L(NAME)+1,GMRAR(CNT)="   " ;19

 ..S GMRAR(CNT)=$G(GMRAR(CNT))_NAME_$S($O(GMRAL(K)):"~",1:"") D:'$O(GMRAL(K)) SET^VALM10(CNT,GMRAR(CNT)) ;19

 S VALMCNT=CNT,^TMP($J,LTYPE,"IDX2",0)=ENTRY

HDR ; -- header code

 S VALMHDR(1)="Patient listing for reactant "_$S(+$G(NMBR):$P(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR),"^"),1:"")

PHDR ;

 S VALMSG="Select a patient"

 S XQORM("#")=$$FIND1^DIC(101,,"BX","GMRA FIX DETAIL MENU") ;19

 D SHOW^VALM

INIT ; -- init variables and list array

 N DIR

 I '$G(NMBR) S NMBR=$$GETNUM^GMRAFX3("DET") S:'+NMBR VALMQUIT="" Q:'+NMBR  I '$$LOCK^GMRAFX3(+NMBR) S VALMQUIT="" Q

 I $L($G(NMBR),",")>2 D FULL^VALM1 W !,"Please select",$S('$G(NMBR):"",1:" only")," one entry from the list." S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR S VALMQUIT=1 Q

 K ^TMP($J,LTYPE,"GMRADET"),^TMP($J,LTYPE,"IDX2")

 S VALMBCK="",VALMBG=$G(VALMBG,1),VALMCNT=0,VALMWD=80

CHKSEL ;Evaluate selection if done by number

 N J,TMP,DIR,NUM,X,Y

 S NUM=$P($G(XQORNOD(0)),"=",2) ;get currently selected entries

 I NUM'="" D

 .I NUM=$G(NMBR2) D DESELECT Q  ;If user selects same entry without taking an entry, unhighlight and stop processing

 .D DESELECT:$G(NMBR2) ;If user previously selected entries but took no action, unhighlight before highlighting new choices

 .S NMBR2=$P(XQORNOD(0),"=",2),DIR(0)="L^"_"1:"_$G(^TMP($J,LTYPE,"IDX2",0)),X=NMBR2,DIR("V")="" D ^DIR K DIR

 .I Y="" D FULL^VALM1 W !,"Invalid selection." D WAIT^GMRAFX3 K NMBR2 Q  ;Selection out of range, stop processing

 .F J=1:1:$L(NMBR2,",")-1 S TMP=$P(NMBR2,",",J) D CNTRL^VALM10(+^TMP($J,LTYPE,"IDX2",TMP),1,+$G(VALMWD),IORVON,IORVOFF)

DESELECT ;Un-highlight selected choices

 N J,TMP

 F J=1:1:$L($G(NMBR2),",")-1 S TMP=$P(NMBR2,",",J) D CNTRL^VALM10(+^TMP($J,LTYPE,"IDX2",TMP),1,+$G(VALMWD),IORVOFF,IORVOFF)

 K NMBR2

HELP ; -- help code

 D FULL^VALM1

 W !!,"Use AE to add local allergies to the GMR ALLERGY file.  This",!,"should only be done if you're sure no existing reactant matches your needs."

 W !!,"Use EE to mark all selected entries as entered",!,"in error.  You may select multiple patients if you like."

 W !!,"Use UR to update the reactant.  Extreme caution should be used when updating",!,"reactants.  You may select multiple patients if you like,"

 W !!,"Use PR to add new allergies for the selected patient in",!,"addition to the ones listed here."

 W !!,"Use DD to get details about the allergy entry that you're",!,"currently working on for this patient.",!

 D WAIT^GMRAFX3 S VALMBCK="R"

EXIT ; -- exit code

 K ^TMP($J,LTYPE,"IDX2"),^TMP($J,LTYPE,"GMRADET")

EXPND ; -- expand code

PROCESS(TYPE) ;API to mark selected entries from the detailed listing as entered in error or update to new reactant

 N GMRAPA,GMRAJ,DIR,Y,NUM,GMRADONE,ENTRY,GMRAI,STOP,NUM2,GMRAAR

 S VALMBCK="R" D FULL^VALM1

 I '$G(NMBR2) S NMBR2=$$GETNUM^GMRAFX3("") Q:'+NMBR2

 W !!,"You are about to ",$S(TYPE="E":"mark",1:"update")," the selected patient",$S($L(NMBR2,",")>2:"s'",1:"'s"),!

 S ENTRY=$G(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR))

 W $P(ENTRY,"^",2)," allergy ",$S(TYPE="E":"as entered in error.",1:"to a new reactant."),!

 S DIR(0)="Y",DIR("B")="NO",DIR("A")="ARE YOU SURE"

 S DIR("?")="Once allergies are updated or marked as entered in error it cannot be undone!"

 S DIR("?",1)="Be sure this is what you want to do."

 D ^DIR Q:Y'=1  ;Stop if user doesn't answer yes

 S NUM=+NMBR

 F GMRAI=1:1:($L(NMBR2,",")-1) D  Q:$G(STOP)

 .S GMRADONE=1

 .S NUM2=$P(NMBR2,",",GMRAI)

 .S (GMRAPA,GMRAJ)=$P(^TMP($J,LTYPE,"IDX2",NUM2),U,2) Q:'GMRAPA

 .D @$S(TYPE="E":"EIE^GMRAFX",1:"UIE^GMRAFX3")

 .D:$G(GMRADONE) UPDATE^GMRAFX3

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAFX1   5086     printed  Feb 18, 2025@23:05:39                                                                                                                                                                                                     Page 2

GMRAFX1   ;SLC/DAN Fix existing allergy entries-continued ;10/6/05  11:42

 +1       ;;4.0;Adverse Reaction Tracking;**17,19,20**;Mar 29, 1996;Build 1

 +2       ;DBIA SECTION

 +3       ;10116 - VALM1

 +4       ;10102 - XQORM1

 +5       ;10104 - XLFSTR

 +6       ;10061 - VADPT

 +7       ;10017 - VALM10

 +8       ;10118 - VALM

 +9       ;10026 - DIR

 +10      ;

DET       ;Detailed listing of selected group

 +1        NEW DIR,Y,DTOUT,DUOUT,DIRUT,J,GMRAT,GMRAUT,DFN,GMRA,GMRAL,VADM,CNT,VAERR,K,LEN,NAME,ENTRY,NMBR2,ENMBR,GMRAR

 +2        SET VALMBCK="R"

           SET CNT=0

 +3        KILL ^TMP($JOB,LTYPE,"GMRADET"),^TMP($JOB,LTYPE,"IDX2")

 +4       ;get number portion of entry

           SET ENMBR=+NMBR

 +5        SET ENTRY=0

 +6        SET GMRAUT=$PIECE(^XTMP("GMRAFX",LTYPE,"IDX",ENMBR),"^")

           SET GMRAT=$PIECE(^XTMP("GMRAFX",LTYPE,"IDX",ENMBR),"^",2)

 +7        SET J=0

FOR

               SET J=$ORDER(^XTMP("GMRAFX",LTYPE,"GMRAR",GMRAUT,GMRAT,J))

               if '+J

                   QUIT

               Begin DoDot:1

 +8       ;Get patient allergies

                   SET DFN=$PIECE($GET(^GMR(120.8,J,0)),"^")

                   SET GMRA="0^0^111"

                   DO ^GMRADPT

 +9       ;Get patient information

                   DO DEM^VADPT

 +10      ;Quit if patient lookup produces an error

                   if $GET(VAERR)

                       QUIT

 +11               SET CNT=CNT+1

                   SET ENTRY=ENTRY+1

 +12               SET GMRAR(CNT)=VADM(1)_$$REPEAT^XLFSTR(" ",(32-$LENGTH(VADM(1))))_$EXTRACT(VADM(2),6,9)_" "

 +13      ;19

                   DO SET^VALM10(CNT,ENTRY_$$REPEAT^XLFSTR(" ",(4-$LENGTH(ENTRY)))_GMRAR(CNT))

                   KILL GMRAR(CNT)

 +14               SET ^TMP($JOB,LTYPE,"IDX2",ENTRY)=CNT_"^"_J

 +15               SET CNT=CNT+1

                   SET LEN=0

                   SET GMRAR(CNT)="Allergies: "

 +16               SET K=0

FOR

                       SET K=$ORDER(GMRAL(K))

                       if '+K

                           QUIT

                       Begin DoDot:2

 +17      ;Allergy name

                           SET NAME=$PIECE(GMRAL(K),"^",2)

 +18                       SET LEN=LEN+$LENGTH(NAME)+1

 +19      ;19

                           IF LEN>70

                               DO SET^VALM10(CNT,GMRAR(CNT))

                               KILL GMRAR(CNT)

                               SET CNT=CNT+1

                               SET LEN=$LENGTH(NAME)+1

                               SET GMRAR(CNT)="   "

 +20      ;19

                           SET GMRAR(CNT)=$GET(GMRAR(CNT))_NAME_$SELECT($ORDER(GMRAL(K)):"~",1:"")

                           if '$ORDER(GMRAL(K))

                               DO SET^VALM10(CNT,GMRAR(CNT))

                       End DoDot:2

               End DoDot:1

 +21       SET VALMCNT=CNT

           SET ^TMP($JOB,LTYPE,"IDX2",0)=ENTRY

 +22       QUIT

 +23      ;

HDR       ; -- header code

 +1        SET VALMHDR(1)="Patient listing for reactant "_$SELECT(+$GET(NMBR):$PIECE(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR),"^"),1:"")

 +2        QUIT

 +3       ;

PHDR      ;

 +1        SET VALMSG="Select a patient"

 +2       ;19

           SET XQORM("#")=$$FIND1^DIC(101,,"BX","GMRA FIX DETAIL MENU")

 +3        DO SHOW^VALM

 +4        QUIT

 +5       ;

INIT      ; -- init variables and list array

 +1        NEW DIR

 +2        IF '$GET(NMBR)

               SET NMBR=$$GETNUM^GMRAFX3("DET")

               if '+NMBR

                   SET VALMQUIT=""

               if '+NMBR

                   QUIT

               IF '$$LOCK^GMRAFX3(+NMBR)

                   SET VALMQUIT=""

                   QUIT

 +3        IF $LENGTH($GET(NMBR),",")>2

               DO FULL^VALM1

               WRITE !,"Please select",$SELECT('$GET(NMBR):"",1:" only")," one entry from the list."

               SET DIR(0)="E"

               SET DIR("A")="Press enter to continue"

               DO ^DIR

               SET VALMQUIT=1

               QUIT

 +4        KILL ^TMP($JOB,LTYPE,"GMRADET"),^TMP($JOB,LTYPE,"IDX2")

 +5        SET VALMBCK=""

           SET VALMBG=$GET(VALMBG,1)

           SET VALMCNT=0

           SET VALMWD=80

 +6        QUIT

 +7       ;

CHKSEL    ;Evaluate selection if done by number

 +1        NEW J,TMP,DIR,NUM,X,Y

 +2       ;get currently selected entries

           SET NUM=$PIECE($GET(XQORNOD(0)),"=",2)

 +3        IF NUM'=""

               Begin DoDot:1

 +4       ;If user selects same entry without taking an entry, unhighlight and stop processing

                   IF NUM=$GET(NMBR2)

                       DO DESELECT

                       QUIT

 +5       ;If user previously selected entries but took no action, unhighlight before highlighting new choices

                   if $GET(NMBR2)

                       DO DESELECT

 +6                SET NMBR2=$PIECE(XQORNOD(0),"=",2)

                   SET DIR(0)="L^"_"1:"_$GET(^TMP($JOB,LTYPE,"IDX2",0))

                   SET X=NMBR2

                   SET DIR("V")=""

                   DO ^DIR

                   KILL DIR

 +7       ;Selection out of range, stop processing

                   IF Y=""

                       DO FULL^VALM1

                       WRITE !,"Invalid selection."

                       DO WAIT^GMRAFX3

                       KILL NMBR2

                       QUIT

 +8                FOR J=1:1:$LENGTH(NMBR2,",")-1

                       SET TMP=$PIECE(NMBR2,",",J)

                       DO CNTRL^VALM10(+^TMP($JOB,LTYPE,"IDX2",TMP),1,+$GET(VALMWD),IORVON,IORVOFF)

               End DoDot:1

 +9        QUIT

 +10      ;

DESELECT  ;Un-highlight selected choices

 +1        NEW J,TMP

 +2        FOR J=1:1:$LENGTH($GET(NMBR2),",")-1

               SET TMP=$PIECE(NMBR2,",",J)

               DO CNTRL^VALM10(+^TMP($JOB,LTYPE,"IDX2",TMP),1,+$GET(VALMWD),IORVOFF,IORVOFF)

 +3        KILL NMBR2

 +4        QUIT

HELP      ; -- help code

 +1        DO FULL^VALM1

 +2        WRITE !!,"Use AE to add local allergies to the GMR ALLERGY file.  This",!,"should only be done if you're sure no existing reactant matches your needs."

 +3        WRITE !!,"Use EE to mark all selected entries as entered",!,"in error.  You may select multiple patients if you like."

 +4        WRITE !!,"Use UR to update the reactant.  Extreme caution should be used when updating",!,"reactants.  You may select multiple patients if you like,"

 +5        WRITE !!,"Use PR to add new allergies for the selected patient in",!,"addition to the ones listed here."

 +6        WRITE !!,"Use DD to get details about the allergy entry that you're",!,"currently working on for this patient.",!

 +7        DO WAIT^GMRAFX3

           SET VALMBCK="R"

 +8        QUIT

 +9       ;

EXIT      ; -- exit code

 +1        KILL ^TMP($JOB,LTYPE,"IDX2"),^TMP($JOB,LTYPE,"GMRADET")

 +2        QUIT

 +3       ;

EXPND     ; -- expand code

 +1        QUIT

 +2       ;

PROCESS(TYPE) ;API to mark selected entries from the detailed listing as entered in error or update to new reactant

 +1        NEW GMRAPA,GMRAJ,DIR,Y,NUM,GMRADONE,ENTRY,GMRAI,STOP,NUM2,GMRAAR

 +2        SET VALMBCK="R"

           DO FULL^VALM1

 +3        IF '$GET(NMBR2)

               SET NMBR2=$$GETNUM^GMRAFX3("")

               if '+NMBR2

                   QUIT

 +4        WRITE !!,"You are about to ",$SELECT(TYPE="E":"mark",1:"update")," the selected patient",$SELECT($LENGTH(NMBR2,",")>2:"s'",1:"'s"),!

 +5        SET ENTRY=$GET(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR))

 +6        WRITE $PIECE(ENTRY,"^",2)," allergy ",$SELECT(TYPE="E":"as entered in error.",1:"to a new reactant."),!

 +7        SET DIR(0)="Y"

           SET DIR("B")="NO"

           SET DIR("A")="ARE YOU SURE"

 +8        SET DIR("?")="Once allergies are updated or marked as entered in error it cannot be undone!"

 +9        SET DIR("?",1)="Be sure this is what you want to do."

 +10      ;Stop if user doesn't answer yes

           DO ^DIR

           if Y'=1

               QUIT

 +11       SET NUM=+NMBR

 +12       FOR GMRAI=1:1:($LENGTH(NMBR2,",")-1)

               Begin DoDot:1

 +13               SET GMRADONE=1

 +14               SET NUM2=$PIECE(NMBR2,",",GMRAI)

 +15               SET (GMRAPA,GMRAJ)=$PIECE(^TMP($JOB,LTYPE,"IDX2",NUM2),U,2)

                   if 'GMRAPA

                       QUIT

 +16               DO @$SELECT(TYPE="E":"EIE^GMRAFX",1:"UIE^GMRAFX3")

 +17               if $GET(GMRADONE)

                       DO UPDATE^GMRAFX3

               End DoDot:1

               if $GET(STOP)

                   QUIT

 +18       QUIT

GMRAFX1.m