Routine: GMRALAB1

GMRALAB1 ;HIRMFO/WAA-THIS PROGRAM WILL SELECT ALL LAB TEST FOR A PATIENT ;1/9/96  09:48

 ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996

EDIT ;EDIT EXISTING DATA

 I '$O(^GMR(120.85,GMRAPA1,4,0)) W !,?3,"YOU CANNOT EDIT WHEN THERE IS NO DATA ON FILE.",$C(7) Q

EDITLST ; DISPLAY TO EDIT FIELD

 D LST^GMRALAB0

EEDT K DA,DO,DIC,DIE,DLAYGO,DR

 S DA(1)=GMRAPA1,DIC="^GMR(120.85,"_DA(1)_",4,",DIC(0)="AMQEZ" D ^DIC K DIC,DLAYGO

 I $D(DUOUT)!($D(DTOUT)) S GMRAOUT=1 Q

 I Y=-1 S GMRAOUT=1 Q

 S DA(1)=GMRAPA1,DIE="^GMR(120.85,"_DA(1)_",4,",DA=+Y,DR=".01;1;2" D ^DIE

 K GMRAX,DA,DIE,DR

ADD ;This is to allow the user to select a LAB TEST

 D DISP^GMRALAB0 I GMRAOUT S GMRAOUT=GMRAOUT-1 Q:GMRAOUT

 K % I '$D(^TMP($J,"GMRALAB")) D ADD2 Q:X=""  G ADD

ADDED W !,"Enter the number of the TX/Test to ADD or ""N"" for NEW: "

 R GMRAX:DTIME S:'$T GMRAX="^^" I "^^"[GMRAX S GMRAOUT=$L(GMRAX) Q

 I "??"[GMRAX D:$L(GMRAX)=2  Q:GMRAOUT  W !,"ENTER THE NUMBER OF THE ENTRY YOU WANT OR ""N"" FOR A NEW TEST" G ADDED

 .D DISP^GMRALAB0 I GMRAOUT S GMRAOUT=GMRAOUT-1 Q:GMRAOUT

.Q

 I GMRAX="n" S GMRAX="N"

 I GMRAX="N" D ADD2 Q:X=""  G ADD

 I '$$VALST^GMRALAB1(GMRAX,"L") W !,$C(7),"INVALID SELECTION PLEASE SELECT ONE OF THE TEST/TX LISTED OR ""N"" FOR A NEW TEST" G ADD

 S GMRALST=0 F  S GMRALST=$O(GMRALST(GMRALST)) Q:GMRALST<1  S GMRAX=GMRALST D  Q:GMRAOUT

 .S X=$E($P(^TMP($J,"GMRALAB","L",GMRAX),U,3),1,18)

 .I $D(^GMR(120.85,GMRAPA1,4,"B",X)) D  Q:GMRAOUT!(%-1)  K %

 ..W !,"You already have a ",X," test on file."

 ..S %=2 F  W !,"Do You still want to add this one" D YN^DICN S:%=-1 %=2,GMRAOUT=1 Q:%  W !,"ENTER YES TO ADD THE TEST/TX OR NO TO SELECT ANOTHER"

..Q

 .K DD,DO

 .I '$D(^GMR(120.85,GMRAPA1,4,0)) S ^(0)="^120.8504^^"

 .S DA(1)=GMRAPA1,DIC="^GMR(120.85,"_GMRAPA1_",4,",DIC(0)="L",DLAYGO=120.85 D FILE^DICN K DLAYGO Q:(+Y<1)

 .S GMRARSLT=$E($P($P(^TMP($J,"GMRALAB","L",GMRAX),U,4),"|"),1,78)_" "_$E($P(^TMP($J,"GMRALAB","L",GMRAX),U,6),1,10)

 .I $P(^TMP($J,"GMRALAB","L",GMRAX),U,8)'="" S GMRARSLT=GMRARSLT_" H:"_$E($P(^TMP($J,"GMRALAB","L",GMRAX),U,8),1,45)_"/L:"_$E($P(^TMP($J,"GMRALAB","L",GMRAX),U,7),1,45)

 .S:$P(^TMP($J,"GMRALAB","L",GMRAX),U,5)'="" GMRARSLT=$E($P(^TMP($J,"GMRALAB","L",GMRAX),U,5),1,2)_" "_GMRARSLT

 .S DA=+Y,DIE=DIC,DR="1////"_GMRARSLT_";2///"

 .S DR=DR_$S($P($P(^TMP($J,"GMRALAB","L",GMRAX),U)," ",2)'="":$P($P(^TMP($J,"GMRALAB","L",GMRAX),U)," ")_"@"_$P($P(^TMP($J,"GMRALAB","L",GMRAX),U)," ",2),1:$P($P(^TMP($J,"GMRALAB","L",GMRAX),U)," ")) K DIC,Y D ^DIE

 .K DA,DIE,DR,GMRAX,GMRARSLT,DD,DO,%,X

.Q

ADD2 ;This is to allow the patient's lab test to be added.

 S DA=GMRAPA1,DIE="^GMR(120.85,",DLAYGO=120.85,DR="4" D ^DIE

 S:$D(Y) GMRAOUT=1

 K DA,DIE,DR

DEL ;This entry point is to delete a lab entry from the Adverse Reaction file.

 I '$D(^GMR(120.85,GMRAPA1,4,0)) W !,"THERE IS NO LAB DATA SELECTED FOR THIS PATIENT" Q

 K DA,DO,DIC,DIE,DLAYGO,DR

 S DA(1)=GMRAPA1,DIC="^GMR(120.85,"_DA(1)_",4,",DIC(0)="AMQEZ" D ^DIC

 I $D(DUOUT)!($D(DTOUT)) S GMRAOUT=1 Q

 I Y=-1 S GMRAOUT=1 Q

 K DIC,DA,DO,DLAYGO

 S DA(1)=GMRAPA1,DIK="^GMR(120.85,"_DA(1)_",4,",DA=+Y D ^DIK

 K DIC,DIC,DA,DO,DLAYGO

LDATE(X) ;This function takes X and will return Y

 ;in a format that will keep every thing lined up for prints

N Y

 S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)

 I $P(X,".",2)'="" S X=$E($P(X,".",2),1,4) S:$L(X)<4 X=X_$E("000",1,(4-$L(X))) S Y=Y_"@"_$E(X,1,2)_":"_$E(X,3,4)

Q Y

VALST(LST,SUB) ; GIVEN LST, THIS FUNCTION RETURNS 1 IF LIST VALID, ELSE 0

 N X,Y,Z,A

 K GMRALST

 S Z=1 F X=1:1:$L(LST,",") S Y=$P(LST,",",X) D  Q:'Z

 .I Y'?1N.N,Y'?1N.N1"-"1N.N S Z=0 Q

 .I Y?1N.N S Y=Y_"-"_Y

 .F A=$P(Y,"-"):1:$P(Y,"-",2) S:'$D(^TMP($J,"GMRALAB",SUB,A)) Z=0 Q:'Z  S GMRALST(A)=""

.Q

 K:'Z GMRALST

Q Z

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRALAB1   3778     printed  Feb 18, 2025@23:05:53                                                                                                                                                                                                    Page 2

GMRALAB1  ;HIRMFO/WAA-THIS PROGRAM WILL SELECT ALL LAB TEST FOR A PATIENT ;1/9/96  09:48

 +1       ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996

EDIT      ;EDIT EXISTING DATA

 +1        IF '$ORDER(^GMR(120.85,GMRAPA1,4,0))

               WRITE !,?3,"YOU CANNOT EDIT WHEN THERE IS NO DATA ON FILE.",$CHAR(7)

               QUIT

EDITLST   ; DISPLAY TO EDIT FIELD

 +1        DO LST^GMRALAB0

EEDT       KILL DA,DO,DIC,DIE,DLAYGO,DR

 +1        SET DA(1)=GMRAPA1

           SET DIC="^GMR(120.85,"_DA(1)_",4,"

           SET DIC(0)="AMQEZ"

           DO ^DIC

           KILL DIC,DLAYGO

 +2        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET GMRAOUT=1

               QUIT

 +3        IF Y=-1

               SET GMRAOUT=1

               QUIT

 +4        SET DA(1)=GMRAPA1

           SET DIE="^GMR(120.85,"_DA(1)_",4,"

           SET DA=+Y

           SET DR=".01;1;2"

           DO ^DIE

 +5        KILL GMRAX,DA,DIE,DR

 +6        QUIT

ADD       ;This is to allow the user to select a LAB TEST

 +1        DO DISP^GMRALAB0

           IF GMRAOUT

               SET GMRAOUT=GMRAOUT-1

               if GMRAOUT

                   QUIT

 +2        KILL %

           IF '$DATA(^TMP($JOB,"GMRALAB"))

               DO ADD2

               if X=""

                   QUIT

               GOTO ADD

ADDED      WRITE !,"Enter the number of the TX/Test to ADD or ""N"" for NEW: "

 +1        READ GMRAX:DTIME

           if '$TEST

               SET GMRAX="^^"

           IF "^^"[GMRAX

               SET GMRAOUT=$LENGTH(GMRAX)

               QUIT

 +2        IF "??"[GMRAX

               if $LENGTH(GMRAX)=2

                   Begin DoDot:1

 +3                    DO DISP^GMRALAB0

                       IF GMRAOUT

                           SET GMRAOUT=GMRAOUT-1

                           if GMRAOUT

                               QUIT

 +4                    QUIT

                   End DoDot:1

               if GMRAOUT

                   QUIT

               WRITE !,"ENTER THE NUMBER OF THE ENTRY YOU WANT OR ""N"" FOR A NEW TEST"

               GOTO ADDED

 +5        IF GMRAX="n"

               SET GMRAX="N"

 +6        IF GMRAX="N"

               DO ADD2

               if X=""

                   QUIT

               GOTO ADD

 +7        IF '$$VALST^GMRALAB1(GMRAX,"L")

               WRITE !,$CHAR(7),"INVALID SELECTION PLEASE SELECT ONE OF THE TEST/TX LISTED OR ""N"" FOR A NEW TEST"

               GOTO ADD

 +8        SET GMRALST=0

FOR

               SET GMRALST=$ORDER(GMRALST(GMRALST))

               if GMRALST<1

                   QUIT

               SET GMRAX=GMRALST

               Begin DoDot:1

 +9                SET X=$EXTRACT($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,3),1,18)

 +10               IF $DATA(^GMR(120.85,GMRAPA1,4,"B",X))

                       Begin DoDot:2

 +11                       WRITE !,"You already have a ",X," test on file."

 +12                       SET %=2

FOR

                               WRITE !,"Do You still want to add this one"

                               DO YN^DICN

                               if %=-1

                                   SET %=2

                                   SET GMRAOUT=1

                               if %

                                   QUIT

                               WRITE !,"ENTER YES TO ADD THE TEST/TX OR NO TO SELECT ANOTHER"

 +13                       QUIT

                       End DoDot:2

                       if GMRAOUT!(%-1)

                           QUIT

                       KILL %

 +14               KILL DD,DO

 +15               IF '$DATA(^GMR(120.85,GMRAPA1,4,0))

                       SET ^(0)="^120.8504^^"

 +16               SET DA(1)=GMRAPA1

                   SET DIC="^GMR(120.85,"_GMRAPA1_",4,"

                   SET DIC(0)="L"

                   SET DLAYGO=120.85

                   DO FILE^DICN

                   KILL DLAYGO

                   if (+Y<1)

                       QUIT

 +17               SET GMRARSLT=$EXTRACT($PIECE($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,4),"|"),1,78)_" "_$EXTRACT($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,6),1,10)

 +18               IF $PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,8)'=""

                       SET GMRARSLT=GMRARSLT_" H:"_$EXTRACT($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,8),1,45)_"/L:"_$EXTRACT($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,7),1,45)

 +19               if $PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,5)'=""

                       SET GMRARSLT=$EXTRACT($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U,5),1,2)_" "_GMRARSLT

 +20               SET DA=+Y

                   SET DIE=DIC

                   SET DR="1////"_GMRARSLT_";2///"

 +21               SET DR=DR_$SELECT($PIECE($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U)," ",2)'="":$PIECE($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U)," ")_"@"_$PIECE($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),U)," ",2),1:$PIECE($PIECE(^TMP($JOB,"GMRALAB","L",GMRAX),

U)," "))

                   KILL DIC,Y

                   DO ^DIE

 +22               KILL DA,DIE,DR,GMRAX,GMRARSLT,DD,DO,%,X

 +23               QUIT

               End DoDot:1

               if GMRAOUT

                   QUIT

 +24       QUIT

ADD2      ;This is to allow the patient's lab test to be added.

 +1        SET DA=GMRAPA1

           SET DIE="^GMR(120.85,"

           SET DLAYGO=120.85

           SET DR="4"

           DO ^DIE

 +2        if $DATA(Y)

               SET GMRAOUT=1

 +3        KILL DA,DIE,DR

 +4        QUIT

DEL       ;This entry point is to delete a lab entry from the Adverse Reaction file.

 +1        IF '$DATA(^GMR(120.85,GMRAPA1,4,0))

               WRITE !,"THERE IS NO LAB DATA SELECTED FOR THIS PATIENT"

               QUIT

 +2        KILL DA,DO,DIC,DIE,DLAYGO,DR

 +3        SET DA(1)=GMRAPA1

           SET DIC="^GMR(120.85,"_DA(1)_",4,"

           SET DIC(0)="AMQEZ"

           DO ^DIC

 +4        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET GMRAOUT=1

               QUIT

 +5        IF Y=-1

               SET GMRAOUT=1

               QUIT

 +6        KILL DIC,DA,DO,DLAYGO

 +7        SET DA(1)=GMRAPA1

           SET DIK="^GMR(120.85,"_DA(1)_",4,"

           SET DA=+Y

           DO ^DIK

 +8        KILL DIC,DIC,DA,DO,DLAYGO

 +9        QUIT

LDATE(X)  ;This function takes X and will return Y

 +1       ;in a format that will keep every thing lined up for prints

 +2        NEW Y

 +3        SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)

 +4        IF $PIECE(X,".",2)'=""

               SET X=$EXTRACT($PIECE(X,".",2),1,4)

               if $LENGTH(X)<4

                   SET X=X_$EXTRACT("000",1,(4-$LENGTH(X)))

               SET Y=Y_"@"_$EXTRACT(X,1,2)_":"_$EXTRACT(X,3,4)

 +5        QUIT Y

VALST(LST,SUB) ; GIVEN LST, THIS FUNCTION RETURNS 1 IF LIST VALID, ELSE 0

 +1        NEW X,Y,Z,A

 +2        KILL GMRALST

 +3        SET Z=1

           FOR X=1:1:$LENGTH(LST,",")

               SET Y=$PIECE(LST,",",X)

               Begin DoDot:1

 +4                IF Y'?1N.N

                       IF Y'?1N.N1"-"1N.N

                           SET Z=0

                           QUIT

 +5                IF Y?1N.N

                       SET Y=Y_"-"_Y

 +6                FOR A=$PIECE(Y,"-"):1:$PIECE(Y,"-",2)

                       if '$DATA(^TMP($JOB,"GMRALAB",SUB,A))

                           SET Z=0

                       if 'Z

                           QUIT

                       SET GMRALST(A)=""

 +7                QUIT

               End DoDot:1

               if 'Z

                   QUIT

 +8        if 'Z

               KILL GMRALST

 +9        QUIT Z

GMRALAB1.m