- 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 Jan 18, 2025@02:43:40 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