source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIP11.m@ 1076

Last change on this file since 1076 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1DIP11 ;SFISC/XAK,TKW-GET SORT TEMPLATE ;01:30 PM 13 Feb 2002
2 ;;22.0;VA FileMan;**97**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4TEM ;
5 G B^DIP:DJ-1 K DPP,DIC
6 S X=$P($E(X,2,99),"]",1),DIC(0)="ZQS"_$E("E",'($D(BY)#2)!''L),DIC="^DIBT(",D="F"_DL
7 S DIC("S")="I $P(^(0),U,4)=DL,$S(L=0:1,'$D(^(1)):1,'$P(^(0),U,5):1,1:$P(^(0),U,5)=DUZ)"
8 I X?."?" S:X'?1"???" X="??" D IX^DIC S DJ=0 Q
9 D ^DIC I Y<0 S DJ=0 Q
10 I $D(^DIBT(+Y,"DIS")),'$D(^(1)) W:'$G(DIQUIET) !,"This SEARCH template has no search results!" S DJ=0 Q
11 S DPP(DJ)=DL_"^^'"_$P(Y,U,2)_"' NUMBER^@'"_P,(DIBT1,X)=+Y,DIBT2=$P(Y(0),U),D=DIC_X_C K DIC
12 I '$D(FLDS),$G(^DIBT(X,"DIPT"))]"" S FLDS="["_^("DIPT")_"]" I L D
13 . N %,A S %(1)=^("DIPT") D BLD^DIALOG(8030,.%,"","A") W ! F %=0:0 S %=$O(A(%)) Q:'% W A(%),!
14 . S L=0 Q
15 I $D(^DIBT(X,1)) S DIC=D_1_C,DPP(DJ,"SER")="998^998" D ENT^DIP10(DJ,DIBT1) I $D(^DIBT(X,1)) S Y=1 D
16 .F DY=1:1 S Y=$O(^(Y,-1)) S:Y="" Y=-1 S:$O(^(Y)) Y=$O(^(Y)) I $D(^(Y))<9 S DPP(DJ,"IX")=DIC_DI_U_DY,DIBT=X Q
17 .Q
18ENDIPT I $G(^DIBT(X,"BY0"))="",'$D(^DIBT(X,2)) Q
19 I $G(^DIBT(X,"BY0"))="",$G(^DIBT(X,2,0))="" S %Y="DPP(",%X=D_2_C D %XY^%RCR S DIBTOLD="" D CNVCM G T0
20 S D=$G(^DIBT(X,"BY0")) I $P(D,U)]"",$P(D,U,2) D
21 . N Y K DISPAR(0) S BY(0)="^"_$P(D,U),L(0)=$P(D,U,2)
22 . F D=1:1:(L(0)-1) D
23 .. S Y=$G(^DIBT(X,"BY0D",D,0))
24 .. I '$D(FR(0,D))#2,$P(Y,U,2)]"" S FR(0,D)=$P(Y,U,2)
25 .. I '$D(TO(0,D))#2,$P(Y,U,3)]"" S TO(0,D)=$P(Y,U,3)
26 .. I $G(^DIBT(X,"BY0D",D,1))]"" S DISPAR(0,D)=^(1) S:$G(^DIBT(X,"BY0D",D,2))]"" DISPAR(0,D,"OUT")=^(2)
27 .. Q
28 . N X D EN^DIP10 Q
29 ;S DJ=$O(DPP(999),-1)+1
30 F D=0:0 S D=$O(^DIBT(X,2,D)) Q:'D D
31 .N A,B,C S DPP(DJ)=^DIBT(X,2,D,0)
32 .S A="A" F S A=$O(^DIBT(X,2,D,A)) Q:A="" I A'="SER" S DPP(DJ,A)=^(A)
33 .F B=1,2,3 F A=0:0 S A=$O(^DIBT(X,2,D,B,A)) Q:'A S C=$G(^(A,0)) D
34 ..I B=1 S:$P(C,U)=+C DPP(DJ,+C)=$P(C,U,2) Q
35 ..I B=2 S:($P(C,U)=+C)&($P(C,U,2)=+$P(C,U,2)) DPP(DJ,+C,$P(C,U,2))=$P(C,U,3,7)_U_$G(^DIBT(X,2,D,2,A,"RCOD")) Q
36 ..I $P(C,U,1)]"",$P(C,U,2)]"" S DPP(DJ,$P(C,U,1),$P(C,U,2))=$G(^DIBT(X,2,D,3,A,"OVF0"))
37 ..Q
38 .S DJ=DJ+1 Q
39T0 Q:$D(DIBTRPT)
40 I $D(DIAR) S DIARU=X ;I '$P(DIARB,U,2) S $P(DIARB,U,2)=DIARU
41 F D=0:0 S D=$O(^DIBT(X,3,D)) Q:D="" S DSC(D)=^(D)
42 I 'L!($D(DPP(0))&(DUZ(0)'="@")) G T1
43 S %=$P(^DIBT(X,0),U,6)
44 I %]"" F D=1:1:$L(%) I DUZ(0)[$E(%,D)!(DUZ(0)="@") S %="" Q
45 I %="",X'<1 S %=$P(Y(0),U,1) D G Q:$D(DIRUT) I %=1 K DIBTOLD G EDT^DIP0
46 . N X,Y K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="WANT TO EDIT '"_%_"' TEMPLATE" D ^DIR K DIR
47 . S %=Y Q
48T1 F DJ=$G(DPP(0))+1:1 Q:'$D(DPP(DJ)) D I '$D(DJ)!($D(DTOUT))!($D(DIRUT)) G Q
49 . N DL,DU,DV,X,Y,Z,DIFLD,DIFLDREG K DPP(DJ,"PTRIX") S DL=$P(DPP(DJ),U),Y=$P(DPP(DJ),U,2,3)
50 . D DTYP^DIP1,STXT^DIP1(DJ,$G(DPP(DJ,"F")),$G(DPP(DJ,"T")),DITYP)
51 .; Save off old "IX" node to preserve it if template is hand-edited.
52 . I DJ=1 N DISAVIX,DIRECSRT S DISAVIX=$G(DPP(DJ,"IX")),DIRECSRT=0
53 . K DPP(DJ,"IX")
54 . I $P(DPP(DJ),U,4)'["-",'$D(DPP(DJ,"SRTTXT")),$P($G(DPP(DJ,"F")),U)'="?z",$P($G(DPP(DJ,"T")),U)'="@" D XR^DIP I DJ=1,DISAVIX]"",DISAVIX'=$G(DPP(DJ,"IX")) D
55 .. N I,X,Y,Z S X=$P(DISAVIX,U,3),Z=$P(DISAVIX,U,2) I $E(Z,1,$L(X))'=X S DIRECSRT=1 G T12
56 .. S Z=$E(Z,($L(X)+1),99),Z=$P(Z,"""",2) Q:Z="" I '$D(^DD(S,0,"IX",Z)) D Q:Z=""
57 ... Q:S=405&(Z="ATT3") S Z="" Q
58T12 .. S DPP(DJ,"IX")=DISAVIX,DPP(DJ,"SER")="998^998"
59 .. I DIRECSRT=1,$P(DPP(DJ),U,2)="",'($P($P(DPP(DJ),U,4),"""",2)),'$D(DPP(DJ,"CM")) S $P(DPP(DJ),U,2)=0
60PROMPT . I $D(DPP(DJ,"ASK")) S DPP(DJ,"ASK")=1 I $G(DICNVDPP)'=1 D DIP11^DIP1 Q ;GFT PATCH 97
61 . I DJ=1,DISAVIX=1 Q
62 . D OPT^DIP12 Q
63 Q:$G(DICNVDPP)=1
64 D DPQ^DIP1 S X="["_DIBT2 K DIARE,DIARS,DIARB Q
65 ;
66CNVCM ;Convert V20 DPP array to V21 DPP array (for prints queued in V20 to run in V21)
67 N D,I,J,X,Y,Z,N
68 F D=0:0 S D=$O(DPP(D)) Q:'D S X=$G(DPP(D,"CM")) I X["S X(" D
69 . S (I,Z)=0 F S Y=$F(X,"S X(",Z) Q:'Y S Z=Y,I=I+1
70 . Q:'Z S N=+$E(X,Z) Q:'N
71 . I $L(X)+16>248 D Q
72 .. S Z="OVF",I=-1 F S Z=$O(DPP(D,Z)) Q:$E(Z,1,3)'="OVF" S I=$E(Z,4,99)
73 .. S Z="OVF"_(I+1),Y=$P(X," S X=",1) S:Y]"" Y=Y_" "
74 .. S DPP(D,"CM")=Y_"X DPP("_D_","""_Z_""",9.2) I $G(X("_N_"))]"""" S DISX("_N_")=X("_N_")"
75 .. S Y=$P(X," S X=",2,99),DPP(D,Z,9.2)=$P("S X=",U,(Y]""))_Y Q
76 . S DPP(D,"CM")=$P(X,"S X(",1,I)_"S DISX("_$P(X,"S X(",I+1,99)
77 . Q
78 Q
79 ;
80Q S:$D(DUOUT)!($D(DTOUT)) X="^" G Q^DIP
81 ;DIALOG #8030 'Because...sort template...linked w/Print template...
Note: See TracBrowser for help on using the repository browser.