QAMEDT6 ;HISC/DAD-GROUP FILE EDIT ;7/12/93 14:24
;;1.0;Clinical Monitoring System;;09/13/1993
S QAMBRACE=$S($D(^QA(740,1,"QAM"))#2:$P(^("QAM"),"^",6),1:0)
EN1 K DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO S DIC="^QA(743.5,",DIC(0)="AELMNQ",DIC("A")="Select GROUP: ",DLAYGO=743.5 W ! D ^DIC G:Y'>0 EXIT
K DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO S (QAMD0,DA)=+Y,DIE="^QA(743.5,",DR=".01;.02" D ^DIE G:($D(DA)[0)!($D(Y)) EN1
S:$D(^QA(743.5,QAMD0,"GRP",0))[0 ^(0)="^743.51A^^" S QAMD1=+$P(^(0),"^",3),QAMDFLT=$S($D(^QA(743.5,QAMD0,"GRP",QAMD1,0))#2:$P(^(0),";"),1:"")
D GRPMEMBR G EN1
EXIT ;
K %,C,D0,D1,DA,DI,DIC,DIDEL,DIE,DIK,DGA1,DGT,DLAYGO,DQ,DR,QADIROUT,QADIRPNT,QAMD0,QAMD1,QAMD2,QAMBRACE,QAMDFLT,QAMDIC,QAMID,QAMIDENT,QAMINPUT,QAMQUIT,QAMTEXT,QAMY,VAERR,X,Y
Q
GRPMEMBR ; *** EDIT GROUP MEMBERS
W !,"Select GROUP MEMBER: " W:QAMDFLT]"" QAMDFLT,"// " R X:DTIME S:'$T X="^" S:(X="")&(QAMDFLT]"") X=QAMDFLT S QAMDFLT="",QAMINPUT=X Q:($E(X)="^")!(X="")
I $E(X)="?" W !!?5,"You may enter `[GROUP MEMBER' to select all entries that CONTAIN",!?5,"the text `GROUP MEMBER'. Enter `[*' to select ALL entries."
I W !?5,"You may use a prefix of minus (-) to delete a range of group",!?5,"members, for example `-[GROUP MEMBER' or `-[*'.",!?5,"WARNING: Use of the contains operator ([) is very computer intensive!"
I W !?5,"If you are having trouble adding another group member at the 'Select",!?5,"GROUP MEMBER:' prompt try enclosing the new entry in quotes, e.g.,",!?5,"""GROUP MEMBER""."
I QAMINPUT?.1"-"1"[".1"*".E S QAMQUIT=0 D CONTAIN G:QAMQUIT=1 GRPMEMBR
K DA,DIC,DIE,DIK,DINUM,DO,DR,DLAYGO,DIDEL,DIK S DIC="^QA(743.5,"_QAMD0_",""GRP"",",DIC(0)="EMQZ"_$S($E(X)'="`":"L",1:""),(DIDEL,DLAYGO)=743.5,(DA(1),D0)=QAMD0 D ^DIC G:Y'>0 GRPMEMBR
K DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO S DIE="^QA(743.5,"_QAMD0_",""GRP"",",DR=.01,(DLAYGO,DIDEL)=743.5,(DA,D1)=+Y,(DA(1),D0)=QAMD0 D ^DIE K DIDEL
G GRPMEMBR
CONTAIN ; *** PROCESS CONTAINS OPERATOR
I QAMBRACE'>0 W !!?3,"*** This function ([) has been turned off in the site parameter file ***",*7,! S QAMQUIT=2 Q
S QAMTEXT=$P(QAMINPUT,"[",2) I QAMTEXT="" S QAMQUIT=2 Q
W *7
ASK W !!?2,$S($E(QAMINPUT)="-":"Delete",1:"Add")," ",$S(QAMTEXT="*":"ALL entries",1:"all entries that contain `"_QAMTEXT_"' ") S %=2 D YN^DICN S QAMQUIT=% I (%=-1)!(%=2) W ! Q
I '% W !!?5,"Please answer Y(es) or N(o)." G ASK
W !,"Working",! G:QAMINPUT?1"-[".E DELETE
S QAMDIC(0)=$S($D(^QA(743.5,QAMD0,0))#2:+$P(^(0),"^",2),1:0),QAMDIC=$S($D(^DIC(QAMDIC(0),0,"GL"))#2:^("GL"),1:"") I QAMDIC="" S QAMQUIT=2 Q
F QAMD2=0:0 S QAMD2=$O(@(QAMDIC_"QAMD2)")) Q:QAMD2'>0 D ADD W "."
W ! Q
ADD ;
I $E(QAMTEXT)'="*" S Y=$P(@(QAMDIC_"QAMD2,0)"),"^"),C=$P(^DD(QAMDIC(0),.01,0),"^",2) D Y^DIQ K C Q:Y'[QAMTEXT
K DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO S DIC="^QA(743.5,"_QAMD0_",""GRP"",",DIC(0)="LMN",DIC("W")="W """"",(DA(1),D0)=QAMD0,DLAYGO=743.5,X="`"_QAMD2 D ^DIC
Q
DELETE ;
F QAMD1=0:0 S QAMD1=$O(^QA(743.5,QAMD0,"GRP",QAMD1)) Q:QAMD1'>0 D DEL W "."
W ! Q
DEL S X=$S($D(^QA(743.5,QAMD0,"GRP",QAMD1,0))#2:$P(^(0),";"),1:"") I $E(QAMTEXT)'="*" Q:X'[QAMTEXT
W " ",X," " K DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO S DIK="^QA(743.5,"_QAMD0_",""GRP"",",(DA,D1)=QAMD1,(DA(1),D0)=QAMD0,DIDEL=743.5 D ^DIK K DIK,DIDEL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMEDT6 3238 printed Dec 13, 2024@01:42:24 Page 2
QAMEDT6 ;HISC/DAD-GROUP FILE EDIT ;7/12/93 14:24
+1 ;;1.0;Clinical Monitoring System;;09/13/1993
+2 SET QAMBRACE=$SELECT($DATA(^QA(740,1,"QAM"))#2:$PIECE(^("QAM"),"^",6),1:0)
EN1 KILL DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO
SET DIC="^QA(743.5,"
SET DIC(0)="AELMNQ"
SET DIC("A")="Select GROUP: "
SET DLAYGO=743.5
WRITE !
DO ^DIC
if Y'>0
GOTO EXIT
+1 KILL DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO
SET (QAMD0,DA)=+Y
SET DIE="^QA(743.5,"
SET DR=".01;.02"
DO ^DIE
if ($DATA(DA)[0)!($DATA(Y))
GOTO EN1
+2 if $DATA(^QA(743.5,QAMD0,"GRP",0))[0
SET ^(0)="^743.51A^^"
SET QAMD1=+$PIECE(^(0),"^",3)
SET QAMDFLT=$SELECT($DATA(^QA(743.5,QAMD0,"GRP",QAMD1,0))#2:$PIECE(^(0),";"),1:"")
+3 DO GRPMEMBR
GOTO EN1
EXIT ;
+1 KILL %,C,D0,D1,DA,DI,DIC,DIDEL,DIE,DIK,DGA1,DGT,DLAYGO,DQ,DR,QADIROUT,QADIRPNT,QAMD0,QAMD1,QAMD2,QAMBRACE,QAMDFLT,QAMDIC,QAMID,QAMIDENT,QAMINPUT,QAMQUIT,QAMTEXT,QAMY,VAERR,X,Y
+2 QUIT
GRPMEMBR ; *** EDIT GROUP MEMBERS
+1 WRITE !,"Select GROUP MEMBER: "
if QAMDFLT]""
WRITE QAMDFLT,"// "
READ X:DTIME
if '$TEST
SET X="^"
if (X="")&(QAMDFLT]"")
SET X=QAMDFLT
SET QAMDFLT=""
SET QAMINPUT=X
if ($EXTRACT(X)="^")!(X="")
QUIT
+2 IF $EXTRACT(X)="?"
WRITE !!?5,"You may enter `[GROUP MEMBER' to select all entries that CONTAIN",!?5,"the text `GROUP MEMBER'. Enter `[*' to select ALL entries."
+3 IF $TEST
WRITE !?5,"You may use a prefix of minus (-) to delete a range of group",!?5,"members, for example `-[GROUP MEMBER' or `-[*'.",!?5,"WARNING: Use of the contains operator ([) is very computer intensive!"
+4 IF $TEST
WRITE !?5,"If you are having trouble adding another group member at the 'Select",!?5,"GROUP MEMBER:' prompt try enclosing the new entry in quotes, e.g.,",!?5,"""GROUP MEMBER""."
+5 IF QAMINPUT?.1"-"1"[".1"*".E
SET QAMQUIT=0
DO CONTAIN
if QAMQUIT=1
GOTO GRPMEMBR
+6 KILL DA,DIC,DIE,DIK,DINUM,DO,DR,DLAYGO,DIDEL,DIK
SET DIC="^QA(743.5,"_QAMD0_",""GRP"","
SET DIC(0)="EMQZ"_$SELECT($EXTRACT(X)'="`":"L",1:"")
SET (DIDEL,DLAYGO)=743.5
SET (DA(1),D0)=QAMD0
DO ^DIC
if Y'>0
GOTO GRPMEMBR
+7 KILL DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO
SET DIE="^QA(743.5,"_QAMD0_",""GRP"","
SET DR=.01
SET (DLAYGO,DIDEL)=743.5
SET (DA,D1)=+Y
SET (DA(1),D0)=QAMD0
DO ^DIE
KILL DIDEL
+8 GOTO GRPMEMBR
CONTAIN ; *** PROCESS CONTAINS OPERATOR
+1 IF QAMBRACE'>0
WRITE !!?3,"*** This function ([) has been turned off in the site parameter file ***",*7,!
SET QAMQUIT=2
QUIT
+2 SET QAMTEXT=$PIECE(QAMINPUT,"[",2)
IF QAMTEXT=""
SET QAMQUIT=2
QUIT
+3 WRITE *7
ASK WRITE !!?2,$SELECT($EXTRACT(QAMINPUT)="-":"Delete",1:"Add")," ",$SELECT(QAMTEXT="*":"ALL entries",1:"all entries that contain `"_QAMTEXT_"' ")
SET %=2
DO YN^DICN
SET QAMQUIT=%
IF (%=-1)!(%=2)
WRITE !
QUIT
+1 IF '%
WRITE !!?5,"Please answer Y(es) or N(o)."
GOTO ASK
+2 WRITE !,"Working",!
if QAMINPUT?1"-[".E
GOTO DELETE
+3 SET QAMDIC(0)=$SELECT($DATA(^QA(743.5,QAMD0,0))#2:+$PIECE(^(0),"^",2),1:0)
SET QAMDIC=$SELECT($DATA(^DIC(QAMDIC(0),0,"GL"))#2:^("GL"),1:"")
IF QAMDIC=""
SET QAMQUIT=2
QUIT
+4 FOR QAMD2=0:0
SET QAMD2=$ORDER(@(QAMDIC_"QAMD2)"))
if QAMD2'>0
QUIT
DO ADD
WRITE "."
+5 WRITE !
QUIT
ADD ;
+1 IF $EXTRACT(QAMTEXT)'="*"
SET Y=$PIECE(@(QAMDIC_"QAMD2,0)"),"^")
SET C=$PIECE(^DD(QAMDIC(0),.01,0),"^",2)
DO Y^DIQ
KILL C
if Y'[QAMTEXT
QUIT
+2 KILL DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO
SET DIC="^QA(743.5,"_QAMD0_",""GRP"","
SET DIC(0)="LMN"
SET DIC("W")="W """""
SET (DA(1),D0)=QAMD0
SET DLAYGO=743.5
SET X="`"_QAMD2
DO ^DIC
+3 QUIT
DELETE ;
+1 FOR QAMD1=0:0
SET QAMD1=$ORDER(^QA(743.5,QAMD0,"GRP",QAMD1))
if QAMD1'>0
QUIT
DO DEL
WRITE "."
+2 WRITE !
QUIT
DEL SET X=$SELECT($DATA(^QA(743.5,QAMD0,"GRP",QAMD1,0))#2:$PIECE(^(0),";"),1:"")
IF $EXTRACT(QAMTEXT)'="*"
if X'[QAMTEXT
QUIT
+1 WRITE " ",X," "
KILL DIC,DIE,DR,DLAYGO,DIDEL,DIK,DO
SET DIK="^QA(743.5,"_QAMD0_",""GRP"","
SET (DA,D1)=QAMD1
SET (DA(1),D0)=QAMD0
SET DIDEL=743.5
DO ^DIK
KILL DIK,DIDEL
+2 QUIT
