GMRACMR1 ;HIRMFO/WAA-Find clinics and wards ;12/16/97 10:35
;;4.0;Adverse Reaction Tracking;**9**;Mar 29, 1996
MDIC() ; FUNTION RETURNS S ^TMP($J,"GMRAWC",GMRANUM,GMRAX)=""
; FUNCTION VALUE IS -1 IF USER ABORTS, 0 IF NO LOCS PICKED, ELSE 1
N DIC,MDIC,NEG,X,Y K GMRANLOC,^TMP($J,"GMRAWC") S GMRANUM=0
DIC W !,$S('$D(^TMP($J,"GMRAWC")):"Select",1:"Another")_" Location: " R X:DTIME E S X="^^"
I $$UP^XLFSTR(X)="ALL" D G:X="" DIC
.F S %=1 W !,"Do you mean ALL Locations" D YN^DICN S:%=-1 X="^",%=2 Q:% W !,"Enter Y for yes you mean ALL or N for no.",$C(7)
.I %=2 K % Q
.I %=1 K % S X=0 F S X=$O(^SC(X)) Q:X<1 D
..I $$SCRIACT^GMRACMR1(X) S ^TMP($J,"GMRAWC",X)=$P($G(^SC(X,0)),U,3)
..Q
.K % S X=""
.Q
RETURN I "^^"[X S MDIC=$S(X["^":-1,1:$D(^TMP($J,"GMRAWC"))) Q MDIC
I X?1"?".E D HLP S:Y<0 X="^^" G:Y<0 RETURN S X="?"
S NEG=X?1"-".E,X=$E(X,NEG+1,$L(X)),DIC="^SC(",DIC(0)="EQMZ",DIC("S")="I $$SCRIACT^GMRACMR1(+Y)" D ^DIC K DIC,DLAYGO I +Y'>0 G DIC
I 'NEG S GMRANUM=GMRANUM+1,^TMP($J,"GMRAWC",+Y)=$P(^SC(+Y,0),U,3)
E K ^TMP($J,"GMRAWC",+Y)
G DIC
HLP ; PRINT LOCATIONS SELECTED ALREADY
W $C(7) I $D(^TMP($J,"GMRAWC")) W !?3,"YOU HAVE ALREADY SELECTED: "
S Y="",X=0 F S Y=$O(^TMP($J,"GMRAWC",+Y)) Q:Y="" W !?5,$P(^SC(+Y,0),U) S X=X+1 I X>5 W !,"""^"" TO STOP: " R X:DTIME S:'$T X="^^" S:X="^^" Y=-1 Q:X="^"!(Y<0) S X=0
Q:Y<0
W !!?3,"You may deselect from the list by typing a '-' followed by location name.",!?4,"E.g. -3E would delete 3E from the list of locations already selected."
W !?4,"You may enter the word ALL to select all appropriate locations."
Q
SCRIACT(X) ; GIVEN X AS 44 ENTRY, THIS SCREEN WILL DETERMINE IF IT IS
; ACTIVE OR NOT FOR THIS REPORT. RETURNS 0 IF IT IS NOT, ELSE 1
S X("ANS")=0,X(0)=$G(^SC(X,0))
I X(0)'="" D
.I GMRAQST'[$P(X(0),U,3) Q
.I $P(X(0),U,3)="W" D
..S GMRA42=+$G(^SC(X,42)) Q:GMRA42=""!($G(^DIC(42,GMRA42,0))="")
..I '$O(^DIC(42,GMRA42,"OOS",0)) S X("ANS")=1 Q
..I GMRASEL["1" S X("ANS")=$$ACT42(DT,DT)
..I 'X("ANS"),GMRASEL["3" S X("ANS")=$$ACT42(GMRAST,GMRAED)
..Q
.I GMRASEL["2","^C^M^"[(U_$P(X(0),U,3)_U) D
..S X("I")=$G(^SC(X,"I"))
..I $P(X("I"),U)]"",$P(X("I"),U)<$S(GMRASEL["2"!(GMRASEL["3"):GMRAST,1:DT) D Q
...Q:$P(X("I"),U,2)=""!(GMRASEL'["2"&(GMRASEL'["3"))
...Q:$P(X("I"),U,2)'=""&($P(X("I"),U,2)'<GMRAED)
...S X("ANS")=1
...Q
..S X("ANS")=1
..Q
.Q
Q X("ANS")
ACT42(START,END) ; DETERMINES IF A WARD IS ACTIVE DURING A D/T RANGE
; WARD IS IN GMRA42, AND PASS IN START AND END AS D/T RANGE
N ANS,OOS
S ANS(0)=0,ANS=1,OOS(1)=9999999-(START+.000001) ;**NEW CODE RM-5/24/93
F S OOS(1)=$O(^DIC(42,GMRA42,"OOS","AINV",OOS(1))) Q:OOS(1)<1 D Q:ANS(0)
.S OOS(2)=0 F S OOS(2)=$O(^DIC(42,GMRA42,"OOS","AINV",OOS(1),OOS(2))) Q:OOS(2)<1 D Q:ANS(0)
..S OOS=$G(^DIC(42,GMRA42,"OOS",OOS(2),0)) Q:OOS=""
..I '$P(OOS,U,6) Q
..S ANS(0)=1,ANS=0 I $S($P(OOS,U,4)="":0,1:$P(OOS,U,4)<END) S ANS=1 ;**NEW CODE RM-5/24/93
..Q
.Q
Q ANS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRACMR1 2988 printed Apr 09, 2024@20:43:35 Page 2
GMRACMR1 ;HIRMFO/WAA-Find clinics and wards ;12/16/97 10:35
+1 ;;4.0;Adverse Reaction Tracking;**9**;Mar 29, 1996
MDIC() ; FUNTION RETURNS S ^TMP($J,"GMRAWC",GMRANUM,GMRAX)=""
+1 ; FUNCTION VALUE IS -1 IF USER ABORTS, 0 IF NO LOCS PICKED, ELSE 1
+2 NEW DIC,MDIC,NEG,X,Y
KILL GMRANLOC,^TMP($JOB,"GMRAWC")
SET GMRANUM=0
DIC WRITE !,$SELECT('$DATA(^TMP($JOB,"GMRAWC")):"Select",1:"Another")_" Location: "
READ X:DTIME
IF '$TEST
SET X="^^"
+1 IF $$UP^XLFSTR(X)="ALL"
Begin DoDot:1
+2 FOR
SET %=1
WRITE !,"Do you mean ALL Locations"
DO YN^DICN
if %=-1
SET X="^"
SET %=2
if %
QUIT
WRITE !,"Enter Y for yes you mean ALL or N for no.",$CHAR(7)
+3 IF %=2
KILL %
QUIT
+4 IF %=1
KILL %
SET X=0
FOR
SET X=$ORDER(^SC(X))
if X<1
QUIT
Begin DoDot:2
+5 IF $$SCRIACT^GMRACMR1(X)
SET ^TMP($JOB,"GMRAWC",X)=$PIECE($GET(^SC(X,0)),U,3)
+6 QUIT
End DoDot:2
+7 KILL %
SET X=""
+8 QUIT
End DoDot:1
if X=""
GOTO DIC
RETURN IF "^^"[X
SET MDIC=$SELECT(X["^":-1,1:$DATA(^TMP($JOB,"GMRAWC")))
QUIT MDIC
+1 IF X?1"?".E
DO HLP
if Y<0
SET X="^^"
if Y<0
GOTO RETURN
SET X="?"
+2 SET NEG=X?1"-".E
SET X=$EXTRACT(X,NEG+1,$LENGTH(X))
SET DIC="^SC("
SET DIC(0)="EQMZ"
SET DIC("S")="I $$SCRIACT^GMRACMR1(+Y)"
DO ^DIC
KILL DIC,DLAYGO
IF +Y'>0
GOTO DIC
+3 IF 'NEG
SET GMRANUM=GMRANUM+1
SET ^TMP($JOB,"GMRAWC",+Y)=$PIECE(^SC(+Y,0),U,3)
+4 IF '$TEST
KILL ^TMP($JOB,"GMRAWC",+Y)
+5 GOTO DIC
HLP ; PRINT LOCATIONS SELECTED ALREADY
+1 WRITE $CHAR(7)
IF $DATA(^TMP($JOB,"GMRAWC"))
WRITE !?3,"YOU HAVE ALREADY SELECTED: "
+2 SET Y=""
SET X=0
FOR
SET Y=$ORDER(^TMP($JOB,"GMRAWC",+Y))
if Y=""
QUIT
WRITE !?5,$PIECE(^SC(+Y,0),U)
SET X=X+1
IF X>5
WRITE !,"""^"" TO STOP: "
READ X:DTIME
if '$TEST
SET X="^^"
if X="^^"
SET Y=-1
if X="^"!(Y<0)
QUIT
SET X=0
+3 if Y<0
QUIT
+4 WRITE !!?3,"You may deselect from the list by typing a '-' followed by location name.",!?4,"E.g. -3E would delete 3E from the list of locations already selected."
+5 WRITE !?4,"You may enter the word ALL to select all appropriate locations."
+6 QUIT
SCRIACT(X) ; GIVEN X AS 44 ENTRY, THIS SCREEN WILL DETERMINE IF IT IS
+1 ; ACTIVE OR NOT FOR THIS REPORT. RETURNS 0 IF IT IS NOT, ELSE 1
+2 SET X("ANS")=0
SET X(0)=$GET(^SC(X,0))
+3 IF X(0)'=""
Begin DoDot:1
+4 IF GMRAQST'[$PIECE(X(0),U,3)
QUIT
+5 IF $PIECE(X(0),U,3)="W"
Begin DoDot:2
+6 SET GMRA42=+$GET(^SC(X,42))
if GMRA42=""!($GET(^DIC(42,GMRA42,0))="")
QUIT
+7 IF '$ORDER(^DIC(42,GMRA42,"OOS",0))
SET X("ANS")=1
QUIT
+8 IF GMRASEL["1"
SET X("ANS")=$$ACT42(DT,DT)
+9 IF 'X("ANS")
IF GMRASEL["3"
SET X("ANS")=$$ACT42(GMRAST,GMRAED)
+10 QUIT
End DoDot:2
+11 IF GMRASEL["2"
IF "^C^M^"[(U_$PIECE(X(0),U,3)_U)
Begin DoDot:2
+12 SET X("I")=$GET(^SC(X,"I"))
+13 IF $PIECE(X("I"),U)]""
IF $PIECE(X("I"),U)<$SELECT(GMRASEL["2"!(GMRASEL["3"):GMRAST,1:DT)
Begin DoDot:3
+14 if $PIECE(X("I"),U,2)=""!(GMRASEL'["2"&(GMRASEL'["3"))
QUIT
+15 if $PIECE(X("I"),U,2)'=""&($PIECE(X("I"),U,2)'<GMRAED)
QUIT
+16 SET X("ANS")=1
+17 QUIT
End DoDot:3
QUIT
+18 SET X("ANS")=1
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT X("ANS")
ACT42(START,END) ; DETERMINES IF A WARD IS ACTIVE DURING A D/T RANGE
+1 ; WARD IS IN GMRA42, AND PASS IN START AND END AS D/T RANGE
+2 NEW ANS,OOS
+3 ;**NEW CODE RM-5/24/93
SET ANS(0)=0
SET ANS=1
SET OOS(1)=9999999-(START+.000001)
+4 FOR
SET OOS(1)=$ORDER(^DIC(42,GMRA42,"OOS","AINV",OOS(1)))
if OOS(1)<1
QUIT
Begin DoDot:1
+5 SET OOS(2)=0
FOR
SET OOS(2)=$ORDER(^DIC(42,GMRA42,"OOS","AINV",OOS(1),OOS(2)))
if OOS(2)<1
QUIT
Begin DoDot:2
+6 SET OOS=$GET(^DIC(42,GMRA42,"OOS",OOS(2),0))
if OOS=""
QUIT
+7 IF '$PIECE(OOS,U,6)
QUIT
+8 ;**NEW CODE RM-5/24/93
SET ANS(0)=1
SET ANS=0
IF $SELECT($PIECE(OOS,U,4)="":0,1:$PIECE(OOS,U,4)<END)
SET ANS=1
+9 QUIT
End DoDot:2
if ANS(0)
QUIT
+10 QUIT
End DoDot:1
if ANS(0)
QUIT
+11 QUIT ANS
