DIP11 ;SFISC/XAK,TKW-GET SORT TEMPLATE ;29MAR2010
;;22.0;VA FileMan;**97,163*;Mar 30, 1999;Build 30
;Per VHA Directive 2004-038, this routine should not be modified.
SCREENTM(Z,D2) ;Z=ZERO NODE OF SORT TEMPLATE; D2 = THERE IS SORT-BY LOGIC
I $P(Z,U,4)-DL Q 0 ;TEMPLATE MUST BE FOR THIS FILE
I 'D2&'L D Q $D(Z) ;IN SILENT MODE (L=0), DON'T PICK SEARCH OR INQUIRY TYPE IF THERE'S A SORT TYPE OF SAME NAME
.N NAME,I S NAME=$P(Z,U) F I=0:0 S I=$O(^DIBT("B",NAME,I)) Q:'I I I-Y,$P($G(^DIBT(I,0)),U,4)=DL,$D(^(2)) K Z Q
I DUZ(0)="@" Q 1
I D2 Q:'L 1 Q:$P(Z,U,3)="" 1 Q $TR($P(Z,U,3),DUZ(0))'=$P(Z,U,3) ;IF A SORT TEMPLATE, ACCESS CODES MUST MATCH
I '$P(Z,U,5) Q 1
I $P(Z,U,5)=DUZ Q 1 ;If a SEARCH or INQUIRY TEMPLATE, USER MUST MATCH
Q 0
;
TEM ;
G B^DIP:DJ-1 K DPP,DIC
S X=$P($E(X,2,99),"]",1),DIC(0)="ZQS"_$E("E",'($D(BY)#2)!''L),DIC="^DIBT(",D="F"_DL
S DIC("S")="I $$SCREENTM^DIP11(^(0),$D(^(2)))"
;I $P(^(0),U,4)=DL,$S(L=0!(DUZ(0)=""@""):1,'$D(^(1)):$TR(DUZ(0),$P(^(^(0),U,6)'=DUZ(0)&$L(DUZ(0),'$P(^(0),U,5):1,1:$P(^(0),U,5)=DUZ),$D(^(1))!'$D(^(""DIS""))"
I X?."?" S:X'?1"???" X="??" D IX^DIC S DJ=0 Q
D ^DIC I Y<0 S DJ=0 Q
EMPTY I '$D(^DIBT(+Y,2)),'$D(^(1)) W:'$G(DIQUIET) !,"This SEARCH template has no search results!" S DJ=0 Q
S DPP(DJ)=DL_"^^'"_$P(Y,U,2)_"' NUMBER^@'"_P,(DIBT1,X)=+Y,DIBT2=$P(Y(0),U),D=DIC_X_C K DIC
I '$D(FLDS),$G(^DIBT(X,"DIPT"))]"" S FLDS="["_^("DIPT")_"]" I L D
. N %,A S %(1)=^("DIPT") D BLD^DIALOG(8030,.%,"","A") W ! F %=0:0 S %=$O(A(%)) Q:'% W A(%),!
. S L=0 Q
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
.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
.Q
ENDIPT I $G(^DIBT(X,"BY0"))="",'$D(^DIBT(X,2)) Q
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
S D=$G(^DIBT(X,"BY0")) I $P(D,U)]"",$P(D,U,2) D
. N Y K DISPAR(0) S BY(0)="^"_$P(D,U),L(0)=$P(D,U,2)
. F D=1:1:(L(0)-1) D
.. S Y=$G(^DIBT(X,"BY0D",D,0))
.. I '$D(FR(0,D))#2,$P(Y,U,2)]"" S FR(0,D)=$P(Y,U,2)
.. I '$D(TO(0,D))#2,$P(Y,U,3)]"" S TO(0,D)=$P(Y,U,3)
.. I $G(^DIBT(X,"BY0D",D,1))]"" S DISPAR(0,D)=^(1) S:$G(^DIBT(X,"BY0D",D,2))]"" DISPAR(0,D,"OUT")=^(2)
.. Q
. N X D EN^DIP10 Q
;S DJ=$O(DPP(999),-1)+1
F D=0:0 S D=$O(^DIBT(X,2,D)) Q:'D D
.N A,B,C S DPP(DJ)=$G(^DIBT(X,2,D,0))
.S A="A" F S A=$O(^DIBT(X,2,D,A)) Q:A="" I A'="SER" S DPP(DJ,A)=^(A)
.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
..I B=1 S:$P(C,U)=+C DPP(DJ,+C)=$P(C,U,2) Q
..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
..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"))
..Q
.S DJ=DJ+1 Q
T0 Q:$D(DIBTRPT)
I $D(DIAR) S DIARU=X ;I '$P(DIARB,U,2) S $P(DIARB,U,2)=DIARU
F D=0:0 S D=$O(^DIBT(X,3,D)) Q:D="" S DSC(D)=^(D)
I 'L!($D(DPP(0))&(DUZ(0)'="@")) G T1
S %=$P(^DIBT(X,0),U,6)
I %]"" F D=1:1:$L(%) I DUZ(0)[$E(%,D)!(DUZ(0)="@") S %="" Q
I %="",X'<1 S %=$P(Y(0),U,1) D G Q:$D(DIRUT) I %=1 K DIBTOLD G EDT^DIP0
. N X,Y K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="WANT TO EDIT '"_%_"' TEMPLATE" D ^DIR K DIR
. S %=Y Q
T1 F DJ=$G(DPP(0))+1:1 Q:'$D(DPP(DJ)) D I '$D(DJ)!($D(DTOUT))!($D(DIRUT)) G Q
. 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)
. D DTYP^DIP1,STXT^DIP1(DJ,$G(DPP(DJ,"F")),$G(DPP(DJ,"T")),DITYP)
.; Save off old "IX" node to preserve it if template is hand-edited.
. I DJ=1 N DISAVIX,DIRECSRT S DISAVIX=$G(DPP(DJ,"IX")),DIRECSRT=0
. K DPP(DJ,"IX")
. 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
.. 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
.. S Z=$E(Z,($L(X)+1),99),Z=$P(Z,"""",2) Q:Z="" I '$D(^DD(S,0,"IX",Z)) D Q:Z=""
... Q:S=405&(Z="ATT3") S Z="" Q
T12 .. S DPP(DJ,"IX")=DISAVIX,DPP(DJ,"SER")="998^998"
.. 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
PROMPT . I $D(DPP(DJ,"ASK")) S DPP(DJ,"ASK")=1 I $G(DICNVDPP)'=1 D DIP11^DIP1 Q ;GFT PATCH 97
. I DJ=1,DISAVIX=1 Q
. D OPT^DIP12 Q
Q:$G(DICNVDPP)=1
D DPQ^DIP1 S X="["_DIBT2 K DIARE,DIARS,DIARB Q
;
CNVCM ;Convert V20 DPP array to V21 DPP array (for prints queued in V20 to run in V21)
N D,I,J,X,Y,Z,N
F D=0:0 S D=$O(DPP(D)) Q:'D S X=$G(DPP(D,"CM")) I X["S X(" D
. S (I,Z)=0 F S Y=$F(X,"S X(",Z) Q:'Y S Z=Y,I=I+1
. Q:'Z S N=+$E(X,Z) Q:'N
. I $L(X)+16>248 D Q
.. S Z="OVF",I=-1 F S Z=$O(DPP(D,Z)) Q:$E(Z,1,3)'="OVF" S I=$E(Z,4,99)
.. S Z="OVF"_(I+1),Y=$P(X," S X=",1) S:Y]"" Y=Y_" "
.. S DPP(D,"CM")=Y_"X DPP("_D_","""_Z_""",9.2) I $G(X("_N_"))]"""" S DISX("_N_")=X("_N_")"
.. S Y=$P(X," S X=",2,99),DPP(D,Z,9.2)=$P("S X=",U,(Y]""))_Y Q
. S DPP(D,"CM")=$P(X,"S X(",1,I)_"S DISX("_$P(X,"S X(",I+1,99)
. Q
Q
;
Q S:$D(DUOUT)!($D(DTOUT)) X="^" G Q^DIP
;DIALOG #8030 'Because...sort template...linked w/Print template...
DIP11 ;SFISC/XAK,TKW-GET SORT TEMPLATE ;29MAR2010
+1 ;;22.0;VA FileMan;**97,163*;Mar 30, 1999;Build 30
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
SCREENTM(Z,D2) ;Z=ZERO NODE OF SORT TEMPLATE; D2 = THERE IS SORT-BY LOGIC
+1 ;TEMPLATE MUST BE FOR THIS FILE
IF $PIECE(Z,U,4)-DL
QUIT 0
+2 ;IN SILENT MODE (L=0), DON'T PICK SEARCH OR INQUIRY TYPE IF THERE'S A SORT TYPE OF SAME NAME
IF 'D2&'L
Begin DoDot:1
+3 NEW NAME,I
SET NAME=$PIECE(Z,U)
FOR I=0:0
SET I=$ORDER(^DIBT("B",NAME,I))
IF 'I
QUIT
IF I-Y
IF $PIECE($GET(^DIBT(I,0)),U,4)=DL
IF $DATA(^(2))
KILL Z
QUIT
End DoDot:1
QUIT $DATA(Z)
+4 IF DUZ(0)="@"
QUIT 1
+5 ;IF A SORT TEMPLATE, ACCESS CODES MUST MATCH
IF D2
IF 'L
QUIT 1
IF $PIECE(Z,U,3)=""
QUIT 1
QUIT $TRANSLATE($PIECE(Z,U,3),DUZ(0))'=$PIECE(Z,U,3)
+6 IF '$PIECE(Z,U,5)
QUIT 1
+7 ;If a SEARCH or INQUIRY TEMPLATE, USER MUST MATCH
IF $PIECE(Z,U,5)=DUZ
QUIT 1
+8 QUIT 0
+9 ;
TEM ;
+1 IF DJ-1
GOTO B^DIP
KILL DPP,DIC
+2 SET X=$PIECE($EXTRACT(X,2,99),"]",1)
SET DIC(0)="ZQS"_$EXTRACT("E",'($DATA(BY)#2)!''L)
SET DIC="^DIBT("
SET D="F"_DL
+3 SET DIC("S")="I $$SCREENTM^DIP11(^(0),$D(^(2)))"
+4 ;I $P(^(0),U,4)=DL,$S(L=0!(DUZ(0)=""@""):1,'$D(^(1)):$TR(DUZ(0),$P(^(^(0),U,6)'=DUZ(0)&$L(DUZ(0),'$P(^(0),U,5):1,1:$P(^(0),U,5)=DUZ),$D(^(1))!'$D(^(""DIS""))"
+5 IF X?."?"
IF X'?1"???"
SET X="??"
DO IX^DIC
SET DJ=0
QUIT
+6 DO ^DIC
IF Y<0
SET DJ=0
QUIT
EMPTY IF '$DATA(^DIBT(+Y,2))
IF '$DATA(^(1))
IF '$GET(DIQUIET)
WRITE !,"This SEARCH template has no search results!"
SET DJ=0
QUIT
+1 SET DPP(DJ)=DL_"^^'"_$PIECE(Y,U,2)_"' NUMBER^@'"_P
SET (DIBT1,X)=+Y
SET DIBT2=$PIECE(Y(0),U)
SET D=DIC_X_C
KILL DIC
+2 IF '$DATA(FLDS)
IF $GET(^DIBT(X,"DIPT"))]""
SET FLDS="["_^("DIPT")_"]"
IF L
Begin DoDot:1
+3 NEW %,A
SET %(1)=^("DIPT")
DO BLD^DIALOG(8030,.%,"","A")
WRITE !
FOR %=0:0
SET %=$ORDER(A(%))
IF '%
QUIT
WRITE A(%),!
+4 SET L=0
QUIT
End DoDot:1
+5 IF $DATA(^DIBT(X,1))
SET DIC=D_1_C
SET DPP(DJ,"SER")="998^998"
DO ENT^DIP10(DJ,DIBT1)
IF $DATA(^DIBT(X,1))
SET Y=1
Begin DoDot:1
+6 FOR DY=1:1
SET Y=$ORDER(^(Y,-1))
IF Y=""
SET Y=-1
IF $ORDER(^(Y))
SET Y=$ORDER(^(Y))
IF $DATA(^(Y))<9
SET DPP(DJ,"IX")=DIC_DI_U_DY
SET DIBT=X
QUIT
+7 QUIT
End DoDot:1
ENDIPT IF $GET(^DIBT(X,"BY0"))=""
IF '$DATA(^DIBT(X,2))
QUIT
+1 IF $GET(^DIBT(X,"BY0"))=""
IF $GET(^DIBT(X,2,0))=""
SET %Y="DPP("
SET %X=D_2_C
DO %XY^%RCR
SET DIBTOLD=""
DO CNVCM
GOTO T0
+2 SET D=$GET(^DIBT(X,"BY0"))
IF $PIECE(D,U)]""
IF $PIECE(D,U,2)
Begin DoDot:1
+3 NEW Y
KILL DISPAR(0)
SET BY(0)="^"_$PIECE(D,U)
SET L(0)=$PIECE(D,U,2)
+4 FOR D=1:1:(L(0)-1)
Begin DoDot:2
+5 SET Y=$GET(^DIBT(X,"BY0D",D,0))
+6 IF '$DATA(FR(0,D))#2
IF $PIECE(Y,U,2)]""
SET FR(0,D)=$PIECE(Y,U,2)
+7 IF '$DATA(TO(0,D))#2
IF $PIECE(Y,U,3)]""
SET TO(0,D)=$PIECE(Y,U,3)
+8 IF $GET(^DIBT(X,"BY0D",D,1))]""
SET DISPAR(0,D)=^(1)
IF $GET(^DIBT(X,"BY0D",D,2))]""
SET DISPAR(0,D,"OUT")=^(2)
+9 QUIT
End DoDot:2
+10 NEW X
DO EN^DIP10
QUIT
End DoDot:1
+11 ;S DJ=$O(DPP(999),-1)+1
+12 FOR D=0:0
SET D=$ORDER(^DIBT(X,2,D))
IF 'D
QUIT
Begin DoDot:1
+13 NEW A,B,C
SET DPP(DJ)=$GET(^DIBT(X,2,D,0))
+14 SET A="A"
FOR
SET A=$ORDER(^DIBT(X,2,D,A))
IF A=""
QUIT
IF A'="SER"
SET DPP(DJ,A)=^(A)
+15 FOR B=1,2,3
FOR A=0:0
SET A=$ORDER(^DIBT(X,2,D,B,A))
IF 'A
QUIT
SET C=$GET(^(A,0))
Begin DoDot:2
+16 IF B=1
IF $PIECE(C,U)=+C
SET DPP(DJ,+C)=$PIECE(C,U,2)
QUIT
+17 IF B=2
IF ($PIECE(C,U)=+C)&($PIECE(C,U,2)=+$PIECE(C,U,2))
SET DPP(DJ,+C,$PIECE(C,U,2))=$PIECE(C,U,3,7)_U_$GET(^DIBT(X,2,D,2,A,"RCOD"))
QUIT
+18 IF $PIECE(C,U,1)]""
IF $PIECE(C,U,2)]""
SET DPP(DJ,$PIECE(C,U,1),$PIECE(C,U,2))=$GET(^DIBT(X,2,D,3,A,"OVF0"))
+19 QUIT
End DoDot:2
+20 SET DJ=DJ+1
QUIT
End DoDot:1
T0 IF $DATA(DIBTRPT)
QUIT
+1 ;I '$P(DIARB,U,2) S $P(DIARB,U,2)=DIARU
IF $DATA(DIAR)
SET DIARU=X
+2 FOR D=0:0
SET D=$ORDER(^DIBT(X,3,D))
IF D=""
QUIT
SET DSC(D)=^(D)
+3 IF 'L!($DATA(DPP(0))&(DUZ(0)'="@"))
GOTO T1
+4 SET %=$PIECE(^DIBT(X,0),U,6)
+5 IF %]""
FOR D=1:1:$LENGTH(%)
IF DUZ(0)[$EXTRACT(%,D)!(DUZ(0)="@")
SET %=""
QUIT
+6 IF %=""
IF X'<1
SET %=$PIECE(Y(0),U,1)
Begin DoDot:1
+7 NEW X,Y
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="WANT TO EDIT '"_%_"' TEMPLATE"
DO ^DIR
KILL DIR
+8 SET %=Y
QUIT
End DoDot:1
IF $DATA(DIRUT)
GOTO Q
IF %=1
KILL DIBTOLD
GOTO EDT^DIP0
T1 FOR DJ=$GET(DPP(0))+1:1
IF '$DATA(DPP(DJ))
QUIT
Begin DoDot:1
+1 NEW DL,DU,DV,X,Y,Z,DIFLD,DIFLDREG
KILL DPP(DJ,"PTRIX")
SET DL=$PIECE(DPP(DJ),U)
SET Y=$PIECE(DPP(DJ),U,2,3)
+2 DO DTYP^DIP1
DO STXT^DIP1(DJ,$GET(DPP(DJ,"F")),$GET(DPP(DJ,"T")),DITYP)
+3 ; Save off old "IX" node to preserve it if template is hand-edited.
+4 IF DJ=1
NEW DISAVIX,DIRECSRT
SET DISAVIX=$GET(DPP(DJ,"IX"))
SET DIRECSRT=0
+5 KILL DPP(DJ,"IX")
+6 IF $PIECE(DPP(DJ),U,4)'["-"
IF '$DATA(DPP(DJ,"SRTTXT"))
IF $PIECE($GET(DPP(DJ,"F")),U)'="?z"
IF $PIECE($GET(DPP(DJ,"T")),U)'="@"
DO XR^DIP
IF DJ=1
IF DISAVIX]""
IF DISAVIX'=$GET(DPP(DJ,"IX"))
Begin DoDot:2
+7 NEW I,X,Y,Z
SET X=$PIECE(DISAVIX,U,3)
SET Z=$PIECE(DISAVIX,U,2)
IF $EXTRACT(Z,1,$LENGTH(X))'=X
SET DIRECSRT=1
GOTO T12
+8 SET Z=$EXTRACT(Z,($LENGTH(X)+1),99)
SET Z=$PIECE(Z,"""",2)
IF Z=""
QUIT
IF '$DATA(^DD(S,0,"IX",Z))
Begin DoDot:3
+9 IF S=405&(Z="ATT3")
QUIT
SET Z=""
QUIT
End DoDot:3
IF Z=""
QUIT
T12 SET DPP(DJ,"IX")=DISAVIX
SET DPP(DJ,"SER")="998^998"
+1 IF DIRECSRT=1
IF $PIECE(DPP(DJ),U,2)=""
IF '($PIECE($PIECE(DPP(DJ),U,4),"""",2))
IF '$DATA(DPP(DJ,"CM"))
SET $PIECE(DPP(DJ),U,2)=0
End DoDot:2
PROMPT ;GFT PATCH 97
IF $DATA(DPP(DJ,"ASK"))
SET DPP(DJ,"ASK")=1
IF $GET(DICNVDPP)'=1
DO DIP11^DIP1
QUIT
+1 IF DJ=1
IF DISAVIX=1
QUIT
+2 DO OPT^DIP12
QUIT
End DoDot:1
IF '$DATA(DJ)!($DATA(DTOUT))!($DATA(DIRUT))
GOTO Q
+3 IF $GET(DICNVDPP)=1
QUIT
+4 DO DPQ^DIP1
SET X="["_DIBT2
KILL DIARE,DIARS,DIARB
QUIT
+5 ;
CNVCM ;Convert V20 DPP array to V21 DPP array (for prints queued in V20 to run in V21)
+1 NEW D,I,J,X,Y,Z,N
+2 FOR D=0:0
SET D=$ORDER(DPP(D))
IF 'D
QUIT
SET X=$GET(DPP(D,"CM"))
IF X["S X("
Begin DoDot:1
+3 SET (I,Z)=0
FOR
SET Y=$FIND(X,"S X(",Z)
IF 'Y
QUIT
SET Z=Y
SET I=I+1
+4 IF 'Z
QUIT
SET N=+$EXTRACT(X,Z)
IF 'N
QUIT
+5 IF $LENGTH(X)+16>248
Begin DoDot:2
+6 SET Z="OVF"
SET I=-1
FOR
SET Z=$ORDER(DPP(D,Z))
IF $EXTRACT(Z,1,3)'="OVF"
QUIT
SET I=$EXTRACT(Z,4,99)
+7 SET Z="OVF"_(I+1)
SET Y=$PIECE(X," S X=",1)
IF Y]""
SET Y=Y_" "
+8 SET DPP(D,"CM")=Y_"X DPP("_D_","""_Z_""",9.2) I $G(X("_N_"))]"""" S DISX("_N_")=X("_N_")"
+9 SET Y=$PIECE(X," S X=",2,99)
SET DPP(D,Z,9.2)=$PIECE("S X=",U,(Y]""))_Y
QUIT
End DoDot:2
QUIT
+10 SET DPP(D,"CM")=$PIECE(X,"S X(",1,I)_"S DISX("_$PIECE(X,"S X(",I+1,99)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
Q IF $DATA(DUOUT)!($DATA(DTOUT))
SET X="^"
GOTO Q^DIP
+1 ;DIALOG #8030 'Because...sort template...linked w/Print template...
