- DIPT ;SFISC/XAK,TKW-DISPLAY PRINT OR SORT TEMPLATE ;3DEC2008
- ;;22.0;VA FileMan;**157**;Mar 30, 1999;Build 9
- ;Per VHA Directive 2004-038, this routine should not be modified.
- 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
- DIPT ;SFISC/XAK,TKW-DISPLAY PRINT OR SORT TEMPLATE ;3DEC2008
- +1 ;;22.0;VA FileMan;**157**;Mar 30, 1999;Build 9
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 NEW DS,DIWD,D,DRK,J,D9,Y,L,DA
- +4 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
- +5 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
