QAMGPOP0 ;HISC/DAD-BUILD A PATIENT GROUP FROM A FM SEARCH ;9/3/93 13:20
;;1.0;Clinical Monitoring System;;09/13/1993
EN ;
K DIC S DIC="^QA(743.5,",DIC(0)="AELMNQZ",DIC("A")="Select GROUP: ",DIC("DR")=".02////2",DIC("S")="I $P(^(0),""^"",2)=2",DLAYGO=743.5
W ! D ^DIC G:Y'>0 EXIT S QAMGRPD0=+Y,QAMGNAM=Y(0,0)
I $O(^QA(743.5,QAMGRPD0,"GRP",0)) D G EXIT:QAMQUIT=1,EN:QAMQUIT=2
. K DIR S DIR(0)="SO^M:Merge data;D:Delete data;"
. S DIR("A",1)="This group already contains group members."
. S DIR("A",2)="Should the newly found entries be merged with"
. S DIR("A",3)="the existing entries or should the old entries"
. S DIR("A",4)="be deleted prior to the search?",DIR("A",5)=""
. S DIR("A")="Delete or Merge"
. D ^DIR
. S QAMQUIT=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,$D(DIRUT):2,1:0)
. Q:Y="M"!QAMQUIT
. K ^QA(743.5,QAMGRPD0,"GRP")
. Q
K DIC S DIC="^DIC(",DIC(0)="AEMNQZ",DIC("A")="Select FILE TO SEARCH: ",DIC("S")="I $D(^DIC(""AC"",""QAM"",+Y))"
W ! D ^DIC G:Y'>0 EXIT S QAMFILE=+Y
W !!,"Searching the ",Y(0,0)," file (#",+Y,")"
S DIC=QAMFILE K ^TMP("QAM",$J) D EN^DIS
I $D(^QA(743.5,QAMGRPD0,"GRP",0))[0 S ^(0)="^743.51A^^"
S QAMCOUNT=$P(^QA(743.5,QAMGRPD0,"GRP",0),"^",4)
S QAMTHIRD=$P(^QA(743.5,QAMGRPD0,"GRP",0),"^",3),QAMGRPD1=QAMTHIRD+1
W !!,"Building the ",QAMGNAM," group . . ."
F QAMIEN=0:0 S QAMIEN=$O(^TMP("QAM",$J,QAMIEN)) Q:QAMIEN'>0 D
. Q:$O(^QA(743.5,QAMGRPD0,"GRP","AB",QAMIEN,0))
. F QAMGRPD1=QAMGRPD1:1 L +^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0):0 Q:$T&($D(^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0))[0) L -^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)
. S X=^TMP("QAM",$J,QAMIEN)_";"_QAMIEN
. S ^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)=X
. L -^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)
. S QAQADICT=743.51,QAQAFLD=.01,(D0,DA(1))=QAMGRPD0,(D1,DA)=QAMGRPD1
. D ENSET^QAQAXREF
. S QAMCOUNT=QAMCOUNT+1
. Q
S $P(^QA(743.5,QAMGRPD0,"GRP",0),"^",3,4)=$S($G(QAMGRPD1):QAMGRPD1,1:QAMTHIRD)_"^"_QAMCOUNT
I $O(^TMP("QAM",$J,0))'>0 W !!,"No group entries were created !!"
I $O(^QA(743.5,QAMGRPD0,"GRP",0))'>0 D
. W " Deleting the ",QAMGNAM," group."
. S DIK="^QA(743.5,",DA=QAMGRPD0 D ^DIK
. Q
EXIT ;
K DA,DIC,DIK,QAMCOUNT,QAMFILE,QAMGNAM,QAMGRPD0,QAMGRPD1,QAMIEN,QAMTHIRD,QAQDICT,QAQFLD,X,Y,^TMP("QAM",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMGPOP0 2279 printed Apr 09, 2024@20:47:25 Page 2
QAMGPOP0 ;HISC/DAD-BUILD A PATIENT GROUP FROM A FM SEARCH ;9/3/93 13:20
+1 ;;1.0;Clinical Monitoring System;;09/13/1993
EN ;
+1 KILL DIC
SET DIC="^QA(743.5,"
SET DIC(0)="AELMNQZ"
SET DIC("A")="Select GROUP: "
SET DIC("DR")=".02////2"
SET DIC("S")="I $P(^(0),""^"",2)=2"
SET DLAYGO=743.5
+2 WRITE !
DO ^DIC
if Y'>0
GOTO EXIT
SET QAMGRPD0=+Y
SET QAMGNAM=Y(0,0)
+3 IF $ORDER(^QA(743.5,QAMGRPD0,"GRP",0))
Begin DoDot:1
+4 KILL DIR
SET DIR(0)="SO^M:Merge data;D:Delete data;"
+5 SET DIR("A",1)="This group already contains group members."
+6 SET DIR("A",2)="Should the newly found entries be merged with"
+7 SET DIR("A",3)="the existing entries or should the old entries"
+8 SET DIR("A",4)="be deleted prior to the search?"
SET DIR("A",5)=""
+9 SET DIR("A")="Delete or Merge"
+10 DO ^DIR
+11 SET QAMQUIT=$SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIROUT):1,$DATA(DIRUT):2,1:0)
+12 if Y="M"!QAMQUIT
QUIT
+13 KILL ^QA(743.5,QAMGRPD0,"GRP")
+14 QUIT
End DoDot:1
if QAMQUIT=1
GOTO EXIT
if QAMQUIT=2
GOTO EN
+15 KILL DIC
SET DIC="^DIC("
SET DIC(0)="AEMNQZ"
SET DIC("A")="Select FILE TO SEARCH: "
SET DIC("S")="I $D(^DIC(""AC"",""QAM"",+Y))"
+16 WRITE !
DO ^DIC
if Y'>0
GOTO EXIT
SET QAMFILE=+Y
+17 WRITE !!,"Searching the ",Y(0,0)," file (#",+Y,")"
+18 SET DIC=QAMFILE
KILL ^TMP("QAM",$JOB)
DO EN^DIS
+19 IF $DATA(^QA(743.5,QAMGRPD0,"GRP",0))[0
SET ^(0)="^743.51A^^"
+20 SET QAMCOUNT=$PIECE(^QA(743.5,QAMGRPD0,"GRP",0),"^",4)
+21 SET QAMTHIRD=$PIECE(^QA(743.5,QAMGRPD0,"GRP",0),"^",3)
SET QAMGRPD1=QAMTHIRD+1
+22 WRITE !!,"Building the ",QAMGNAM," group . . ."
+23 FOR QAMIEN=0:0
SET QAMIEN=$ORDER(^TMP("QAM",$JOB,QAMIEN))
if QAMIEN'>0
QUIT
Begin DoDot:1
+24 if $ORDER(^QA(743.5,QAMGRPD0,"GRP","AB",QAMIEN,0))
QUIT
+25 FOR QAMGRPD1=QAMGRPD1:1
LOCK +^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0):0
if $TEST&($DATA(^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0))[0)
QUIT
LOCK -^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)
+26 SET X=^TMP("QAM",$JOB,QAMIEN)_";"_QAMIEN
+27 SET ^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)=X
+28 LOCK -^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)
+29 SET QAQADICT=743.51
SET QAQAFLD=.01
SET (D0,DA(1))=QAMGRPD0
SET (D1,DA)=QAMGRPD1
+30 DO ENSET^QAQAXREF
+31 SET QAMCOUNT=QAMCOUNT+1
+32 QUIT
End DoDot:1
+33 SET $PIECE(^QA(743.5,QAMGRPD0,"GRP",0),"^",3,4)=$SELECT($GET(QAMGRPD1):QAMGRPD1,1:QAMTHIRD)_"^"_QAMCOUNT
+34 IF $ORDER(^TMP("QAM",$JOB,0))'>0
WRITE !!,"No group entries were created !!"
+35 IF $ORDER(^QA(743.5,QAMGRPD0,"GRP",0))'>0
Begin DoDot:1
+36 WRITE " Deleting the ",QAMGNAM," group."
+37 SET DIK="^QA(743.5,"
SET DA=QAMGRPD0
DO ^DIK
+38 QUIT
End DoDot:1
EXIT ;
+1 KILL DA,DIC,DIK,QAMCOUNT,QAMFILE,QAMGNAM,QAMGRPD0,QAMGRPD1,QAMIEN,QAMTHIRD,QAQDICT,QAQFLD,X,Y,^TMP("QAM",$JOB)
+2 QUIT
