DIPT ;SFISC/XAK,TKW-DISPLAY PRINT OR SORT TEMPLATE ;3DEC2008
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
N DS,DIWD,D,DRK,J,D9,Y,L,DA
Q:'$D(^DIPT(D0,0)) S (DRK,J(0))=$P(^(0),U,4),L=0,DS(1)=0,D(L)="0FIELD",D9="",Y=2
F DS(1)=0:0 S DS(1)=$O(^DIPT(D0,"F",DS(1))) Q:DS(1)="" S DY=^(DS(1)) D Y
WRITE D:D9]"" UP F D=2:1 Q:'$D(DS(D)) S X=DS(D) W !?DIWD(D)*2,$S(D=2:"FIRST",1:"THEN")_$S($G(DDXP)=3:" EXPORT ",1:" PRINT ")_$P(DIWD(D),+DIWD(D),2)_": "_X_"//" I '$D(D) K DD
W ! S X="" Q
;
;
Y ;from DIPTED, too
S X=$P(DY,$C(126)),DY=$P(DY,$C(126),2,99) Q:X=""
I D9]"" G UP:$P(X,D9)]"" S X=$P(X,D9,2,99)
R I X'>0 G 0:$E(X,2)'=","&'X S:+X D9=D9_+X_",",DRK=-X S:X<0 L=L+1,D(L)=L_$P($G(^DIC(DRK,0)),U)_" FIELD" D CAPTION S DS(Y)=X,DIWD(Y)=D(L-1),Y=Y+1 G Y
G NC:X'["," S DA=$P(X,",") G NC:+DA'=DA
S:DA<0 DA=-DA G Y:'$D(^DD(DRK,DA,0)) S X=$P(X,",",2,99),DS(Y)=$P(^(0),U),%=+X,D=+$P(^(0),U,2),DIWD(Y)=L_$P(^DD(DRK,0),U)
MUL G Y:'$D(^DD(D,.01,0)) I $P(^(0),U,2)["W",$D(^DD(DRK,DA,0)) G W ;to get naked reference back to Label of WP field at top level
S DRK=D,D9=D9_DA_",",Y=Y+1,L=L+1,(DIWD(Y),D(L))=L_$P(^DD(D,0),U) G R
NC S %=+X,D=DRK_U_% I $D(^DIPT(D0,"DCL",D)) S X=X_$E(^(D),$L(^(D)))
G Y:'$D(^DD(DRK,%,0))
W S X=$P(^(0),U)_$E(X,$L(%)+1,999)
P S DS(Y)=X,DIWD(Y)=D(L),Y=Y+1 G Y
;
0 S:X?1"0".E X="NUMBER"_$E(X,2,999)
D CAPTION G P
;
CAPTION S %=$F(X,";Z;""") I '% S D=X Q
S %=%-$L($P(X,";")),X=";"_$P(X,";",2,99) F D=%:0 S D=$F(X,"""",D) I ";"[$E(X,D) S X=$E(X,%,D-2)_$E(X,1,%-5)_$E(X,D,999) Q
Q
;
;
UP ;from DIPTED, too
S DRK=J(0),%=D9,DA=""
DOWN I X[",",+X=$P(X,","),$P(D9,DA_+X_",")="" S DA=DA_+X_",",%=$P(%,",",2,99),DRK=$S(X'>0:-X,1:+$P(^DD(DRK,+X,0),U,2)),X=$P(X,",",2,99) G DOWN
NUL S D9=DA,DS(Y)="",DIWD(Y)=D(L),L=L-1,Y=Y+1,%=$P(%,",",2,99) G NUL:%]"",R
;
;
;
;
;
DIBT ; DISPLAY SORT FIELDS --Field 1620 of File .401
I '$D(^DIBT(D0,0))!'$D(^(2)) S X="" Q
K DIPP,DPP N DIBTRPT,DIBTOLD,C,D,DCC
S X=D0,(DJ,DIBTRPT)=1,C=",",D="^DIBT("_D0_",",DCC=$G(^DIC(+$P(^DIBT(D0,0),U,4),0,"GL")) D ENDIPT^DIP11 S X="" K DIBTRPT,DCC
F DIJ=0:0 S DIJ=$O(DPP(DIJ)) Q:DIJ="" S DIPP(DIJ)=DPP(DIJ),%=+DPP(DIJ),DJ=DIJ D E1^DIP0 S %X=0 D E2^DIP0
K DPP,DIJJ F DIJ=0:0 S DIJ=$O(DIPP(DIJ)) Q:DIJ="" D DJ
K DIPP,DIJ,DPP,DJ,%X,%Y,C S X="" Q
;
DJ W !?DIJ*2-2,$S(DIJ>1:"WITHIN "_DPP(DIJ-1)_", ",1:"")_"SORT BY: "_$P($P(DIPP(DIJ),U,4),"""",1)_$P(DIPP(DIJ),U,3)_$P(DIPP(DIJ),U,5)_"//" S DPP(DIJ)=$P(DIPP(DIJ),U,3)
I $D(^DD(+DIPP(DIJ),+$P(DIPP(DIJ),U,2),0)) S X=+$P(^(0),U,2) I X,$D(DIPP(DIJ,X)),$D(^DD(X,0)) W !?DIJ*2-2,$P(^(0),U,1)_": "_DIPP(DIJ,X)_"//" K DIPP(DIJ,X)
F %=0:0 S %=$O(DIPP(DIJ,%)) Q:'% I $D(DIPP(DIJ,%))#2 W !?DIJ*2-2,$S('$D(^DD(%,0,"UP")):$O(^("NM",0))_" ",1:""),$P(^DD(%,0),U,1)_": "_DIPP(DIJ,%)_"//" S DPP(DIJ)=DIPP(DIJ,%)
I $D(^DIBT(D0,2,DIJ,"ASK")) W " (User is asked range)" Q
Q:'$D(^DIBT(D0,2,DIJ,"F"))&('$D(^("TXT")))
I $D(^DIBT(D0,2,DIJ,"TXT")) W " ("_^("TXT")_")" Q
S Y=^("F"),%Y=$S('$D(^("T")):"",^("T")="z":"",1:^("T")) S:Y[".9999" Y=$P(Y,".",1)+1 X:Y?1"2"6N.NP ^DD("DD") S %=$F(Y,"z"),X=" From '"_$S(%:$E(Y,1,%-3)_$C($A(Y,%-2)+1),1:Y)_"'",Y=%Y
I Y]"" S:Y[".9999" Y=Y\1 X:Y?1"2"6N.NP ^DD("DD") S X=X_" To '"_Y_"'"
W X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIPT 3475 printed Apr 09, 2024@21:47 Page 2
DIPT ;SFISC/XAK,TKW-DISPLAY PRINT OR SORT TEMPLATE ;3DEC2008
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 NEW DS,DIWD,D,DRK,J,D9,Y,L,DA
+8 if '$DATA(^DIPT(D0,0))
QUIT
SET (DRK,J(0))=$PIECE(^(0),U,4)
SET L=0
SET DS(1)=0
SET D(L)="0FIELD"
SET D9=""
SET Y=2
+9 FOR DS(1)=0:0
SET DS(1)=$ORDER(^DIPT(D0,"F",DS(1)))
if DS(1)=""
QUIT
SET DY=^(DS(1))
DO Y
WRITE if D9]""
DO UP
FOR D=2:1
if '$DATA(DS(D))
QUIT
SET X=DS(D)
WRITE !?DIWD(D)*2,$SELECT(D=2:"FIRST",1:"THEN")_$SELECT($GET(DDXP)=3:" EXPORT ",1:" PRINT ")_$PIECE(DIWD(D),+DIWD(D),2)_": "_X_"//"
IF '$DATA(D)
KILL DD
+1 WRITE !
SET X=""
QUIT
+2 ;
+3 ;
Y ;from DIPTED, too
+1 SET X=$PIECE(DY,$CHAR(126))
SET DY=$PIECE(DY,$CHAR(126),2,99)
if X=""
QUIT
+2 IF D9]""
if $PIECE(X,D9)]""
GOTO UP
SET X=$PIECE(X,D9,2,99)
R IF X'>0
if $EXTRACT(X,2)'=","&'X
GOTO 0
if +X
SET D9=D9_+X_","
SET DRK=-X
if X<0
SET L=L+1
SET D(L)=L_$PIECE($GET(^DIC(DRK,0)),U)_" FIELD"
DO CAPTION
SET DS(Y)=X
SET DIWD(Y)=D(L-1)
SET Y=Y+1
GOTO Y
+1 if X'[","
GOTO NC
SET DA=$PIECE(X,",")
if +DA'=DA
GOTO NC
+2 if DA<0
SET DA=-DA
if '$DATA(^DD(DRK,DA,0))
GOTO Y
SET X=$PIECE(X,",",2,99)
SET DS(Y)=$PIECE(^(0),U)
SET %=+X
SET D=+$PIECE(^(0),U,2)
SET DIWD(Y)=L_$PIECE(^DD(DRK,0),U)
MUL ;to get naked reference back to Label of WP field at top level
if '$DATA(^DD(D,.01,0))
GOTO Y
IF $PIECE(^(0),U,2)["W"
IF $DATA(^DD(DRK,DA,0))
GOTO W
+1 SET DRK=D
SET D9=D9_DA_","
SET Y=Y+1
SET L=L+1
SET (DIWD(Y),D(L))=L_$PIECE(^DD(D,0),U)
GOTO R
NC SET %=+X
SET D=DRK_U_%
IF $DATA(^DIPT(D0,"DCL",D))
SET X=X_$EXTRACT(^(D),$LENGTH(^(D)))
+1 if '$DATA(^DD(DRK,%,0))
GOTO Y
W SET X=$PIECE(^(0),U)_$EXTRACT(X,$LENGTH(%)+1,999)
P SET DS(Y)=X
SET DIWD(Y)=D(L)
SET Y=Y+1
GOTO Y
+1 ;
0 if X?1"0".E
SET X="NUMBER"_$EXTRACT(X,2,999)
+1 DO CAPTION
GOTO P
+2 ;
CAPTION SET %=$FIND(X,";Z;""")
IF '%
SET D=X
QUIT
+1 SET %=%-$LENGTH($PIECE(X,";"))
SET X=";"_$PIECE(X,";",2,99)
FOR D=%:0
SET D=$FIND(X,"""",D)
IF ";"[$EXTRACT(X,D)
SET X=$EXTRACT(X,%,D-2)_$EXTRACT(X,1,%-5)_$EXTRACT(X,D,999)
QUIT
+2 QUIT
+3 ;
+4 ;
UP ;from DIPTED, too
+1 SET DRK=J(0)
SET %=D9
SET DA=""
DOWN IF X[","
IF +X=$PIECE(X,",")
IF $PIECE(D9,DA_+X_",")=""
SET DA=DA_+X_","
SET %=$PIECE(%,",",2,99)
SET DRK=$SELECT(X'>0:-X,1:+$PIECE(^DD(DRK,+X,0),U,2))
SET X=$PIECE(X,",",2,99)
GOTO DOWN
NUL SET D9=DA
SET DS(Y)=""
SET DIWD(Y)=D(L)
SET L=L-1
SET Y=Y+1
SET %=$PIECE(%,",",2,99)
if %]""
GOTO NUL
GOTO R
+1 ;
+2 ;
+3 ;
+4 ;
+5 ;
DIBT ; DISPLAY SORT FIELDS --Field 1620 of File .401
+1 IF '$DATA(^DIBT(D0,0))!'$DATA(^(2))
SET X=""
QUIT
+2 KILL DIPP,DPP
NEW DIBTRPT,DIBTOLD,C,D,DCC
+3 SET X=D0
SET (DJ,DIBTRPT)=1
SET C=","
SET D="^DIBT("_D0_","
SET DCC=$GET(^DIC(+$PIECE(^DIBT(D0,0),U,4),0,"GL"))
DO ENDIPT^DIP11
SET X=""
KILL DIBTRPT,DCC
+4 FOR DIJ=0:0
SET DIJ=$ORDER(DPP(DIJ))
if DIJ=""
QUIT
SET DIPP(DIJ)=DPP(DIJ)
SET %=+DPP(DIJ)
SET DJ=DIJ
DO E1^DIP0
SET %X=0
DO E2^DIP0
+5 KILL DPP,DIJJ
FOR DIJ=0:0
SET DIJ=$ORDER(DIPP(DIJ))
if DIJ=""
QUIT
DO DJ
+6 KILL DIPP,DIJ,DPP,DJ,%X,%Y,C
SET X=""
QUIT
+7 ;
DJ WRITE !?DIJ*2-2,$SELECT(DIJ>1:"WITHIN "_DPP(DIJ-1)_", ",1:"")_"SORT BY: "_$PIECE($PIECE(DIPP(DIJ),U,4),"""",1)_$PIECE(DIPP(DIJ),U,3)_$PIECE(DIPP(DIJ),U,5)_"//"
SET DPP(DIJ)=$PIECE(DIPP(DIJ),U,3)
+1 IF $DATA(^DD(+DIPP(DIJ),+$PIECE(DIPP(DIJ),U,2),0))
SET X=+$PIECE(^(0),U,2)
IF X
IF $DATA(DIPP(DIJ,X))
IF $DATA(^DD(X,0))
WRITE !?DIJ*2-2,$PIECE(^(0),U,1)_": "_DIPP(DIJ,X)_"//"
KILL DIPP(DIJ,X)
+2 FOR %=0:0
SET %=$ORDER(DIPP(DIJ,%))
if '%
QUIT
IF $DATA(DIPP(DIJ,%))#2
WRITE !?DIJ*2-2,$SELECT('$DATA(^DD(%,0,"UP")):$ORDER(^("NM",0))_" ",1:""),$PIECE(^DD(%,0),U,1)_": "_DIPP(DIJ,%)_"//"
SET DPP(DIJ)=DIPP(DIJ,%)
+3 IF $DATA(^DIBT(D0,2,DIJ,"ASK"))
WRITE " (User is asked range)"
QUIT
+4 if '$DATA(^DIBT(D0,2,DIJ,"F"))&('$DATA(^("TXT")))
QUIT
+5 IF $DATA(^DIBT(D0,2,DIJ,"TXT"))
WRITE " ("_^("TXT")_")"
QUIT
+6 SET Y=^("F")
SET %Y=$SELECT('$DATA(^("T")):"",^("T")="z":"",1:^("T"))
if Y[".9999"
SET Y=$PIECE(Y,".",1)+1
if Y?1"2"6N.NP
XECUTE ^DD("DD")
SET %=$FIND(Y,"z")
SET X=" From '"_$SELECT(%:$EXTRACT(Y,1,%-3)_$CHAR($ASCII(Y,%-2)+1),1:Y)_"'"
SET Y=%Y
+7 IF Y]""
if Y[".9999"
SET Y=Y\1
if Y?1"2"6N.NP
XECUTE ^DD("DD")
SET X=X_" To '"_Y_"'"
+8 WRITE X
