- 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 Jan 18, 2025@02:41:52 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