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
Q
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
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
Q
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
Q
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 Dec 13, 2024@01:39:30 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
