| [613] | 1 | DIBT1 ;SFISC/GFT,TKW-STORE A SORT TEMPLATE ;8/2/94 15:57
|
|---|
| 2 | ;;22.0;VA FileMan;;Mar 30, 1999
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | S1 K DIR S DIR(0)="O",DIR("A")="STORE IN 'SORT' TEMPLATE",DIR("?")="^D H1^DIBT1"
|
|---|
| 5 | D SAV Q:$D(DIRUT) D DIC Q
|
|---|
| 6 | ;
|
|---|
| 7 | S2 K DIR S DIR(0)="O",DIR("A")="STORE THESE ENTRY ID'S IN TEMPLATE",DIR("?")="^D H2^DIBT1"
|
|---|
| 8 | D SAV Q:$D(DIRUT) D MRG Q
|
|---|
| 9 | ;
|
|---|
| 10 | S3 K DIR S DIR(0)="O",DIR("A")="STORE RESULTS OF SEARCH IN TEMPLATE",DIR("?")="^D H3^DIBT1"
|
|---|
| 11 | S:$D(DIAR) DIR(0)=""
|
|---|
| 12 | D SAV Q:$D(DIRUT) D MRG Q
|
|---|
| 13 | ;
|
|---|
| 14 | SAV S DIR(0)="F"_DIR(0)_"^1,30"
|
|---|
| 15 | D ^DIR K DIR Q:$D(DIRUT)
|
|---|
| 16 | I $E(X)="[" S X=$P($E(X,2,99),"]",1)
|
|---|
| 17 | Q
|
|---|
| 18 | H1 N A,B S A="sort criteria",B="SORT" D H,DIC Q
|
|---|
| 19 | H2 N A,B S A="list of entries",B="SEARCH/SORT" D H,MRG Q
|
|---|
| 20 | H3 N A,B S A="list of entries from the search",B="SEARCH/SORT"
|
|---|
| 21 | W:$D(DIAR) !!,"You must store the results in a template.",!,"Otherwise you will have to rerun this search to archive the entries."
|
|---|
| 22 | D H,MRG Q
|
|---|
| 23 | H W !!,"If you wish to save this "_A_" for later re-use",!,"enter the name of a "_B_" TEMPLATE here (1-30 characters)." Q
|
|---|
| 24 | MRG ;
|
|---|
| 25 | S DIBT1=1
|
|---|
| 26 | DIC K DIC S DIC="^DIBT(",DLAYGO=0,DIC(0)="QELSZ",DIOVRD=1,DIC("S")="I "_$S($D(DIAR)&('$D(DIARI)):"",1:"'")_"$P(^(0),U,8)"
|
|---|
| 27 | S DIC("S")=DIC("S")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5)!$D(DIEDT)",D="F"_DK
|
|---|
| 28 | D IX^DIC S DIBTY=Y K DIC,DLAYGO,DIEDT,DIOVRD G QDIC:Y'>0
|
|---|
| 29 | N X,DIBTSEC S DIBTSEC="" I $O(^DIBT(+Y,0))]"" S DIBTSEC=Y(0) D ALR
|
|---|
| 30 | I $D(DIRUT)!(Y'>0) G QDIC
|
|---|
| 31 | D NOW^%DTC
|
|---|
| 32 | S ^DIBT("F"_DK,$P(Y,U,2),+Y)=1,^DIBT(+Y,0)=$P(Y,U,2)_U_+$J(%,0,4)_U_$S(DIBTSEC]"":$P(DIBTSEC,U,3),1:DUZ(0))_U_DK_U_DUZ_U_$S(DIBTSEC]"":$P(DIBTSEC,U,6),1:DUZ(0)) I $D(DIAR),'$D(DIARI) S $P(^(0),U,8)=1
|
|---|
| 33 | K DIBTSEC N DIE,DA,DI,DK,DR,Y S DIE="^DIBT(",DA=+DIBTY,DR=10,DIOVRD=1 D ^DIE K DUOUT,DIROUT,DIRUT
|
|---|
| 34 | QDIC K DIBT1,DIBTY,DIOVRD,%,%X,%Y Q
|
|---|
| 35 | ALR W !,$C(7) I $D(DIBT),+Y=DIBT W "NO!! YOU ARE USING THAT TEMPLATE FOR YOUR LIST OF ENTRIES!" S Y=-1 Q
|
|---|
| 36 | I $D(DISV),+Y=DISV W "NO!! YOU ARE GOING TO STORE SEARCH RESULTS IN THAT TEMPLATE!" S Y=-1 Q
|
|---|
| 37 | N DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="DATA ALREADY STORED THERE....OK TO PURGE" D ^DIR Q:$D(DIRUT)
|
|---|
| 38 | I Y=1 S %Y="" D S Y=DIBTY Q
|
|---|
| 39 | .F S %Y=$O(^DIBT(+DIBTY,%Y)) Q:%Y="" I %Y'="%D",%Y'="ROU",%Y'="ROUOLD",%Y'="DIPT" K ^DIBT(+DIBTY,%Y)
|
|---|
| 40 | .Q
|
|---|
| 41 | S %Y=-1 I $O(^DIBT(+DIBTY,1,0))'>0!'$D(DIBT1) S Y=-1 Q
|
|---|
| 42 | F %=0:0 S %=$O(^(%)),%Y=%Y+1 Q:%'>0
|
|---|
| 43 | K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A",1)="WANT TO MERGE THESE ENTRIES",DIR("A")="WITH THE "_%Y_" ALREADY IN '"_$P(DIBTY,U,2)_"' TEMPLATE"
|
|---|
| 44 | D ^DIR S Y=$S(Y=0:-1,1:DIBTY) W ! Q
|
|---|
