Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: QAMGPOP0

QAMGPOP0.m

Go to the documentation of this file.
  1. 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
  1. EN ;
  1. 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
  1. W ! D ^DIC G:Y'>0 EXIT S QAMGRPD0=+Y,QAMGNAM=Y(0,0)
  1. I $O(^QA(743.5,QAMGRPD0,"GRP",0)) D G EXIT:QAMQUIT=1,EN:QAMQUIT=2
  1. . K DIR S DIR(0)="SO^M:Merge data;D:Delete data;"
  1. . S DIR("A",1)="This group already contains group members."
  1. . S DIR("A",2)="Should the newly found entries be merged with"
  1. . S DIR("A",3)="the existing entries or should the old entries"
  1. . S DIR("A",4)="be deleted prior to the search?",DIR("A",5)=""
  1. . S DIR("A")="Delete or Merge"
  1. . D ^DIR
  1. . S QAMQUIT=$S($D(DTOUT):1,$D(DUOUT):1,$D(DIROUT):1,$D(DIRUT):2,1:0)
  1. . Q:Y="M"!QAMQUIT
  1. . K ^QA(743.5,QAMGRPD0,"GRP")
  1. . Q
  1. K DIC S DIC="^DIC(",DIC(0)="AEMNQZ",DIC("A")="Select FILE TO SEARCH: ",DIC("S")="I $D(^DIC(""AC"",""QAM"",+Y))"
  1. W ! D ^DIC G:Y'>0 EXIT S QAMFILE=+Y
  1. W !!,"Searching the ",Y(0,0)," file (#",+Y,")"
  1. S DIC=QAMFILE K ^TMP("QAM",$J) D EN^DIS
  1. I $D(^QA(743.5,QAMGRPD0,"GRP",0))[0 S ^(0)="^743.51A^^"
  1. S QAMCOUNT=$P(^QA(743.5,QAMGRPD0,"GRP",0),"^",4)
  1. S QAMTHIRD=$P(^QA(743.5,QAMGRPD0,"GRP",0),"^",3),QAMGRPD1=QAMTHIRD+1
  1. W !!,"Building the ",QAMGNAM," group . . ."
  1. F QAMIEN=0:0 S QAMIEN=$O(^TMP("QAM",$J,QAMIEN)) Q:QAMIEN'>0 D
  1. . Q:$O(^QA(743.5,QAMGRPD0,"GRP","AB",QAMIEN,0))
  1. . 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)
  1. . S X=^TMP("QAM",$J,QAMIEN)_";"_QAMIEN
  1. . S ^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)=X
  1. . L -^QA(743.5,QAMGRPD0,"GRP",QAMGRPD1,0)
  1. . S QAQADICT=743.51,QAQAFLD=.01,(D0,DA(1))=QAMGRPD0,(D1,DA)=QAMGRPD1
  1. . D ENSET^QAQAXREF
  1. . S QAMCOUNT=QAMCOUNT+1
  1. . Q
  1. S $P(^QA(743.5,QAMGRPD0,"GRP",0),"^",3,4)=$S($G(QAMGRPD1):QAMGRPD1,1:QAMTHIRD)_"^"_QAMCOUNT
  1. I $O(^TMP("QAM",$J,0))'>0 W !!,"No group entries were created !!"
  1. I $O(^QA(743.5,QAMGRPD0,"GRP",0))'>0 D
  1. . W " Deleting the ",QAMGNAM," group."
  1. . S DIK="^QA(743.5,",DA=QAMGRPD0 D ^DIK
  1. . Q
  1. EXIT ;
  1. K DA,DIC,DIK,QAMCOUNT,QAMFILE,QAMGNAM,QAMGRPD0,QAMGRPD1,QAMIEN,QAMTHIRD,QAQDICT,QAQFLD,X,Y,^TMP("QAM",$J)
  1. Q