GMRAUTL ;HIRMFO/YMP,RM,WAA-ALLERGY UTILITIES ;7/28/03 08:40
;;4.0;Adverse Reaction Tracking;**17**;Mar 29, 1996
DEV ;Device selecting module
W !
S GMRAZIS=$G(GMRAZIS)
S IOP="Q",%ZIS("B")=""
S %ZIS="NQ" I GMRAZIS'["Q",GMRAZIS'["M132" S %ZIS("B")="HOME" K IOP
D ^%ZIS I POP K GMRAZIS Q ; Select the device (not open)
I '$D(IO("S")) D I POP S POP=0 G DEV
.I $E(IOST)="P",'$D(IO("Q")) W !?4,$C(7),"PRINTED REPORTS MUST BE QUEUED.",! S POP=1
.Q
I $G(GMRAZIS)?.E1"M"1N.E D I POP S POP=0 G DEV
.I IOM<+$P(GMRAZIS,"M",2) W !!?4,$C(7),"THIS REPORT MUST BE SENT TO A PRINTER WITH A MARGIN OF AT LEAST "_+$P(GMRAZIS,"M",2)_"." S POP=1
.Q
I $G(GMRAZIS)?.E1"S"1N.E D I POP S POP=0 G DEV
. I IOSL<+$P(GMRAZIS,"S",2) W !!?4,$C(7),"THIS REPORT MUST BE SENT TO A PRINTER WITH PAGE LENGTH OF AT LEAST "_+$P(GMRAZIS,"S",2)_"." S POP=1
.Q
I '$D(IO("Q")) S IOP=ION_";"_IOST_";"_IOM_";"_IOSL,%ZIS="" D ^%ZIS I POP G DEV ; Open the device
K GMRAZIS
Q
CLOSE ; Close device, and dequeue if queued.
I 'GMRAOUT D ENDPG^GMRADSP3
W ! D ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
Q
SITE ; GET SITE PARAMTER NODE
S GMRASITE=$O(^GMRD(120.84,"SITE",+$G(DUZ(2)),0))
I 'GMRASITE S GMRASITE=$O(^GMRD(120.84,"B","HOSPITAL",0)) I 'GMRASITE S GMRASITE=$O(^GMRD(120.84,0)) I 'GMRASITE S GMRASITE=1
Q
LOCK(X,Y,Z) ; LOCKS ^GMR(X,Y,0). IF IT CAN RETURNS 1, ELSE RETURNS 0
; OPTIONAL PAR. Z IF EXISTS AND TRUE WILL PRINT ERROR MSG IF NO LOCK
L +^GMR(X,Y,0):1
E W:$G(Z) !,$C(7),"THIS ENTRY BEING EDITED, TRY LATER."
Q $T
UNLOCK(X,Y) ; UNLOCKS ^GMR(X,Y,0)
L -^GMR(X,Y,0)
Q
OUTTYPE(GMRAY) ; INPUT VARIABLE IS INTERNAL FORMAT OF TYPE FIELD FOR
; FILES 120.8 AND 120.82. THIS FUNCTION RETURNS OUTPUT VALUE
; FOR THAT FIELD.
N FXN,X S FXN=""
F X=1:1:$L(GMRAY) S FXN=FXN_$S(FXN="":"",1:", ")_$P("^FOOD^DRUG^OTHER","^",$F("FDO",$E(GMRAY,X)))
Q FXN
INPTYPE(GMRAEN) ; THIS PROCEDURE WILL ALLOW USER TO EDIT TYPE FIELD FOR
; FILE AND ENTRY DESIGNATED IN GMRAEN. GMRAEN IS IN VARIABLE PTR.
; FORMAT.
Q:'+GMRAEN!("^GMRD(120.82,^GMR(120.8,^"'[("^"_$P(GMRAEN,";",2)_"^"))
N DIE,DA,DR,GMRADEF
S DIE="^"_$P(GMRAEN,";",2),DA=+GMRAEN,DR=$S(DIE[120.82:1,1:3.1)_"////"
S GMRADEF=$P($G(@(DIE_DA_",0)")),"^",$S(DIE[120.82:2,1:20))
D EDTTYPE(.GMRADEF)
I "^^"[GMRADEF Q
S DR=DR_GMRADEF D ^DIE
Q
EDTTYPE(GMRADEF) ; THIS PROCEDURE WILL ALLOW EMULATE THE EDITING OF
; TYPE FIELD. GMRADEF IS THE VARIABLE THAT WILL BE RETURNED, AND MUST
; BE PASSED BY REFERENCE. IT SHOULD BE SET TO THE DEFAULT VALUE OF
; THE TYPE PRIOR TO THE EDIT AND WILL BE RETURNED AS THE NEW VALUE.
; GMRAOUT WILL BE SET TO 1 IF USER ABNORMALLY EXITS.
Q:'$D(GMRADEF)
N DIR,X,Y
I GMRADEF'="" D
. S X=""
. I GMRADEF["D" S X=1
. I GMRADEF["F" S X=X_$S(X="":"",1:",")_2
. I GMRADEF["O" S X=X_$S(X="":"",1:",")_3
. S GMRADEF=X
. Q
ASKTYP ; This line is where the query for type begins.
S DIR(0)="LA^1:3",DIR("A",1)=" 1 Drug",DIR("A",2)=" 2 Food",DIR("A",3)=" 3 Other",DIR("A")="Select Classification(s) of Causative Agent: " S:GMRADEF'="" DIR("B")=GMRADEF
S DIR("?")="This response must be a list or a range, e.g., 1,3 or 1-3."
D ^DIR
I $D(DIRUT) S GMRADEF="",GMRAOUT=1 Q
S GMRADEF="" F X=1:1:3 I Y[X S GMRADEF=GMRADEF_$E("DFO",X)
Q
INTTYPE(GMRAX) ; INPUT VARIABLE IS INTERNAL VALUE OF TYPE FIELD FOR FILES
; 120.8 AND 120.82. THIS PROCEDURE WILL KILL GMRAX IF IT IS INVALID,
; OR WILL RETURN GMRAX IN ITS PROPER FORMAT. GMRAX MUST BE PASSED BY
; REFERENCE.
N FXN S FXN=1
I $L(GMRAX)>3 D ; take text entry ($L>3) and codify or reject
. N I,J,K
. S K="" F I=1:1 S J=$TR($$UP^XLFSTR($P(GMRAX,",",I))," ") Q:J="" D
. . I "^DRUG^FOOD^OTHER^"[("^"_J_"^") S J=$E(J) I K'[J S K=$S(J="D":J_K,J="F":$E("D",K["D")_J_$E("O",K["O"),1:K_J)
. . E S FXN=0
. . Q
. I FXN S GMRAX=K
. Q
E D ; take coded entry ($L'>3) and validates/formats
. I $L($TR(GMRAX,"DFO"))!'$L(GMRAX)!($L(GMRAX,"D")>2)!($L(GMRAX,"F")>2)!($L(GMRAX,"O")>2) S FXN=0 Q
. S GMRAX=$E("D",GMRAX["D")_$E("F",GMRAX["F")_$E("O",GMRAX["O")
. Q
I 'FXN K GMRAX
Q
ASK(GMRATYPE,GMRAOUT,GMRASP) ;Answer yes or no to data type questions
N DIR,Y,X
S DIR(0)="YA",DIR("A")=GMRATYPE
S DIR("B")=$S(GMRASP=0:"NO",1:"YES") D ^DIR
S:$D(DIRUT) GMRAOUT=1,GMRASP=0
S:'GMRAOUT GMRASP=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAUTL 4357 printed Dec 13, 2024@01:40:38 Page 2
GMRAUTL ;HIRMFO/YMP,RM,WAA-ALLERGY UTILITIES ;7/28/03 08:40
+1 ;;4.0;Adverse Reaction Tracking;**17**;Mar 29, 1996
DEV ;Device selecting module
+1 WRITE !
+2 SET GMRAZIS=$GET(GMRAZIS)
+3 SET IOP="Q"
SET %ZIS("B")=""
+4 SET %ZIS="NQ"
IF GMRAZIS'["Q"
IF GMRAZIS'["M132"
SET %ZIS("B")="HOME"
KILL IOP
+5 ; Select the device (not open)
DO ^%ZIS
IF POP
KILL GMRAZIS
QUIT
+6 IF '$DATA(IO("S"))
Begin DoDot:1
+7 IF $EXTRACT(IOST)="P"
IF '$DATA(IO("Q"))
WRITE !?4,$CHAR(7),"PRINTED REPORTS MUST BE QUEUED.",!
SET POP=1
+8 QUIT
End DoDot:1
IF POP
SET POP=0
GOTO DEV
+9 IF $GET(GMRAZIS)?.E1"M"1N.E
Begin DoDot:1
+10 IF IOM<+$PIECE(GMRAZIS,"M",2)
WRITE !!?4,$CHAR(7),"THIS REPORT MUST BE SENT TO A PRINTER WITH A MARGIN OF AT LEAST "_+$PIECE(GMRAZIS,"M",2)_"."
SET POP=1
+11 QUIT
End DoDot:1
IF POP
SET POP=0
GOTO DEV
+12 IF $GET(GMRAZIS)?.E1"S"1N.E
Begin DoDot:1
+13 IF IOSL<+$PIECE(GMRAZIS,"S",2)
WRITE !!?4,$CHAR(7),"THIS REPORT MUST BE SENT TO A PRINTER WITH PAGE LENGTH OF AT LEAST "_+$PIECE(GMRAZIS,"S",2)_"."
SET POP=1
+14 QUIT
End DoDot:1
IF POP
SET POP=0
GOTO DEV
+15 ; Open the device
IF '$DATA(IO("Q"))
SET IOP=ION_";"_IOST_";"_IOM_";"_IOSL
SET %ZIS=""
DO ^%ZIS
IF POP
GOTO DEV
+16 KILL GMRAZIS
+17 QUIT
CLOSE ; Close device, and dequeue if queued.
+1 IF 'GMRAOUT
DO ENDPG^GMRADSP3
+2 WRITE !
DO ^%ZISC
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
SITE ; GET SITE PARAMTER NODE
+1 SET GMRASITE=$ORDER(^GMRD(120.84,"SITE",+$GET(DUZ(2)),0))
+2 IF 'GMRASITE
SET GMRASITE=$ORDER(^GMRD(120.84,"B","HOSPITAL",0))
IF 'GMRASITE
SET GMRASITE=$ORDER(^GMRD(120.84,0))
IF 'GMRASITE
SET GMRASITE=1
+3 QUIT
LOCK(X,Y,Z) ; LOCKS ^GMR(X,Y,0). IF IT CAN RETURNS 1, ELSE RETURNS 0
+1 ; OPTIONAL PAR. Z IF EXISTS AND TRUE WILL PRINT ERROR MSG IF NO LOCK
+2 LOCK +^GMR(X,Y,0):1
+3 IF '$TEST
if $GET(Z)
WRITE !,$CHAR(7),"THIS ENTRY BEING EDITED, TRY LATER."
+4 QUIT $TEST
UNLOCK(X,Y) ; UNLOCKS ^GMR(X,Y,0)
+1 LOCK -^GMR(X,Y,0)
+2 QUIT
OUTTYPE(GMRAY) ; INPUT VARIABLE IS INTERNAL FORMAT OF TYPE FIELD FOR
+1 ; FILES 120.8 AND 120.82. THIS FUNCTION RETURNS OUTPUT VALUE
+2 ; FOR THAT FIELD.
+3 NEW FXN,X
SET FXN=""
+4 FOR X=1:1:$LENGTH(GMRAY)
SET FXN=FXN_$SELECT(FXN="":"",1:", ")_$PIECE("^FOOD^DRUG^OTHER","^",$FIND("FDO",$EXTRACT(GMRAY,X)))
+5 QUIT FXN
INPTYPE(GMRAEN) ; THIS PROCEDURE WILL ALLOW USER TO EDIT TYPE FIELD FOR
+1 ; FILE AND ENTRY DESIGNATED IN GMRAEN. GMRAEN IS IN VARIABLE PTR.
+2 ; FORMAT.
+3 if '+GMRAEN!("^GMRD(120.82,^GMR(120.8,^"'[("^"_$PIECE(GMRAEN,";",2)_"^"))
QUIT
+4 NEW DIE,DA,DR,GMRADEF
+5 SET DIE="^"_$PIECE(GMRAEN,";",2)
SET DA=+GMRAEN
SET DR=$SELECT(DIE[120.82:1,1:3.1)_"////"
+6 SET GMRADEF=$PIECE($GET(@(DIE_DA_",0)")),"^",$SELECT(DIE[120.82:2,1:20))
+7 DO EDTTYPE(.GMRADEF)
+8 IF "^^"[GMRADEF
QUIT
+9 SET DR=DR_GMRADEF
DO ^DIE
+10 QUIT
EDTTYPE(GMRADEF) ; THIS PROCEDURE WILL ALLOW EMULATE THE EDITING OF
+1 ; TYPE FIELD. GMRADEF IS THE VARIABLE THAT WILL BE RETURNED, AND MUST
+2 ; BE PASSED BY REFERENCE. IT SHOULD BE SET TO THE DEFAULT VALUE OF
+3 ; THE TYPE PRIOR TO THE EDIT AND WILL BE RETURNED AS THE NEW VALUE.
+4 ; GMRAOUT WILL BE SET TO 1 IF USER ABNORMALLY EXITS.
+5 if '$DATA(GMRADEF)
QUIT
+6 NEW DIR,X,Y
+7 IF GMRADEF'=""
Begin DoDot:1
+8 SET X=""
+9 IF GMRADEF["D"
SET X=1
+10 IF GMRADEF["F"
SET X=X_$SELECT(X="":"",1:",")_2
+11 IF GMRADEF["O"
SET X=X_$SELECT(X="":"",1:",")_3
+12 SET GMRADEF=X
+13 QUIT
End DoDot:1
ASKTYP ; This line is where the query for type begins.
+1 SET DIR(0)="LA^1:3"
SET DIR("A",1)=" 1 Drug"
SET DIR("A",2)=" 2 Food"
SET DIR("A",3)=" 3 Other"
SET DIR("A")="Select Classification(s) of Causative Agent: "
if GMRADEF'=""
SET DIR("B")=GMRADEF
+2 SET DIR("?")="This response must be a list or a range, e.g., 1,3 or 1-3."
+3 DO ^DIR
+4 IF $DATA(DIRUT)
SET GMRADEF=""
SET GMRAOUT=1
QUIT
+5 SET GMRADEF=""
FOR X=1:1:3
IF Y[X
SET GMRADEF=GMRADEF_$EXTRACT("DFO",X)
+6 QUIT
INTTYPE(GMRAX) ; INPUT VARIABLE IS INTERNAL VALUE OF TYPE FIELD FOR FILES
+1 ; 120.8 AND 120.82. THIS PROCEDURE WILL KILL GMRAX IF IT IS INVALID,
+2 ; OR WILL RETURN GMRAX IN ITS PROPER FORMAT. GMRAX MUST BE PASSED BY
+3 ; REFERENCE.
+4 NEW FXN
SET FXN=1
+5 ; take text entry ($L>3) and codify or reject
IF $LENGTH(GMRAX)>3
Begin DoDot:1
+6 NEW I,J,K
+7 SET K=""
FOR I=1:1
SET J=$TRANSLATE($$UP^XLFSTR($PIECE(GMRAX,",",I))," ")
if J=""
QUIT
Begin DoDot:2
+8 IF "^DRUG^FOOD^OTHER^"[("^"_J_"^")
SET J=$EXTRACT(J)
IF K'[J
SET K=$SELECT(J="D":J_K,J="F":$EXTRACT("D",K["D")_J_$EXTRACT("O",K["O"),1:K_J)
+9 IF '$TEST
SET FXN=0
+10 QUIT
End DoDot:2
+11 IF FXN
SET GMRAX=K
+12 QUIT
End DoDot:1
+13 ; take coded entry ($L'>3) and validates/formats
IF '$TEST
Begin DoDot:1
+14 IF $LENGTH($TRANSLATE(GMRAX,"DFO"))!'$LENGTH(GMRAX)!($LENGTH(GMRAX,"D")>2)!($LENGTH(GMRAX,"F")>2)!($LENGTH(GMRAX,"O")>2)
SET FXN=0
QUIT
+15 SET GMRAX=$EXTRACT("D",GMRAX["D")_$EXTRACT("F",GMRAX["F")_$EXTRACT("O",GMRAX["O")
+16 QUIT
End DoDot:1
+17 IF 'FXN
KILL GMRAX
+18 QUIT
ASK(GMRATYPE,GMRAOUT,GMRASP) ;Answer yes or no to data type questions
+1 NEW DIR,Y,X
+2 SET DIR(0)="YA"
SET DIR("A")=GMRATYPE
+3 SET DIR("B")=$SELECT(GMRASP=0:"NO",1:"YES")
DO ^DIR
+4 if $DATA(DIRUT)
SET GMRAOUT=1
SET GMRASP=0
+5 if 'GMRAOUT
SET GMRASP=Y
+6 QUIT
