DIP0 ;SFISC/XAK-COMPUTED FIELD ON A SORT, EDITING A SORT TEMPLATE ;2015-01-01 2:08 PM
;;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.
;
S P=P_Q,DPP=$P(X,U,1)
C ;
S DICOMP=N_$E("?",''L),DM=X,DQI="Y(",DA="DPP("_DJ_",""OVF"_N_""",",DICMX="D M^DIO2" G COLON:X?.E1":" D EN^DICOMP K DUOUT G X:'$D(X),X:Y["m"
D XA,BB^DIP:Y["B" S:Y["D" R=R_"^^D" S Y=U_DPP,DPP(DJ,"CM")=X_" I D"_(N#100)_">0 S DISX("_DJ_")=X" G S^DIP
;
XA F %=0:0 S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)")
Q
;
;
COLON D ^DICOMPW K DUOUT
I $D(X),$S($D(DIL(+DP)):DIL(+DP)=DL,1:1) S DPP(DJ,DL,+Y)=DP_U_(Y["m")_U_X,DIL(+DP)=DL,N=+Y,DL=+DP,DV=$J("",DJ*2-2)_$O(^DD(DL,0,"NM",0))_" FIELD" S:$D(DIPP(DIJ,+DP))#2 $P(DIPP(DIJ),U,3)=DIPP(DIJ,+DP) D XA,L G Y^DIP
X I $G(BY)]"" S:BY[";" R=BY,BY=$P(BY,";"),R=U_$P(R,BY,2,9) S (X,DPP)=DM_","_BY,BY="" G C ;TRY TACKING ON THE REST OF THE "BY", AFTER THE FIRST COMMA, BOTH TO 'X' AND TO 'DPP'
I $G(DIQUIET) G Q^DIP
G B^DIP
;
EDT ;
S DIE="^DIBT(",DR=".01;3;6",DA=X,DIPP=DI,DIOVRD=1 D ^DIE S DI=DIPP,DE=$S(L=0!L:"SORT",1:L) K DR,DIE,DIPP,DIOVRD I '$D(DA)!($D(Y)) S (X,DJ)=+$G(DPP(0)) Q
S %=$G(DPP(0,"IX")) I $P(%,U,2)]"",$P(%,U,4) D I $G(DPP(0))']"" S (X,DJ)=0 Q
. N X,I,Y,F,T,O,Q,DIEDITBY S DIEDITBY=1 K FR(0),TO(0),DISPAR(0),DIPP
. S BY(0)="^"_$P(%,U,2),L(0)=$P(%,U,4)
. F I=L(0):1 Q:'$D(DPP(I)) M DIPP(I)=DPP(I) K DPP(I)
. F I=1:1:(L(0)-1) D Q:'$G(L(0))
.. S F=$P($G(DPP(I,"F")),U,2),T=$P($G(DPP(I,"T")),U,2) S:F]"" FR(0,I)=F S:T]"" TO(0,I)=T
.. S O=$P($G(DPP(I)),U,4),Q="" S:O["!" Q=Q_"!" S:O["#" Q=Q_"#" S:$P($G(DPP(I)),U,5)]"" Q=Q_"^"_$P(DPP(I),U,5) S:Q]"" DISPAR(0,I)=Q
.. I $G(DISPAR(0,I))]"",$G(DPP(I,"OUT"))]"" S DISPAR(0,I,"OUT")=DPP(I,"OUT")
.. K DPP(I) Q
. D BYOK^DIP100
. I $G(DPP(0))]"" S X=DPP(0) F I=0:0 S I=$O(DIPP(I)) Q:'I S X=X+1 M DPP(X)=DIPP(I)
. K DIPP Q
S DIPP="",DIJ=0 F DJ=$G(DPP(0)):0 S DJ=$O(DPP(DJ)) Q:'DJ S DIJ=DIJ+1,%X="DPP(DJ,",%Y="DIPP(DIJ," D %XY^%RCR
S DIJ=0 F DJ=$G(DPP(0)):0 S DJ=$O(DPP(DJ)) Q:DJ="" D
. S DIJ=DIJ+1 N X S X=$P(DPP(DJ),U,4),X=$TR(X,"B",""),X=$S(X[Q:$P(X,Q,($L(X,Q)-1)),1:X)
. S $P(DIPP(DIJ),U,3)=X_$P(DPP(DJ),U,3)_$P(DPP(DJ),U,5)
. S %=+DPP(DJ) D E1 S %X=0 D E2 K DPP(DJ)
. Q
S DJ=$G(DPP(0)),DIJ=0 F S DIJ=+$O(DIPP(DIJ)) Q:'DIJ S DJ=DJ+1 D DJ^DIP Q:$D(DTOUT)!($D(DIRUT))!('$D(DJ)) W:X="@" " Deleted."
K DIPP,DIJJ S:X'=U X=1 S:'$D(DXS) DXS=1 S DIEDT=1 Q
E1 ;
F DIJJ=0:1 Q:'$D(^DD(%,0,"UP")) S DIPP(DIJ,%)=$P(DIPP(DIJ),U,3),%=+^("UP"),$P(DIPP(DIJ),U,3)=$O(^("NM",0)),$P(DIPP(DIJ),U,1)=%
Q
E2 S %X=$O(DPP(DJ,%X)) I %X'>0 K %X Q
G E2:'$D(DPP(DJ,%X,100)) S %=%X D E1 S %=DPP(DJ,%X,100)
I $P(%,U,3) S DIPP(DIJ,+%)=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$P(^DIC(+%,0),U)_":",$P(DIPP(DIJ),U)=+% G E2
I %'["Y(1)" S %=$F(%,"OVF0") Q:'% S %=+$E(DPP(DJ,%X,100),%+2,99),%=$P(DPP(DJ,%X,100),U)_U_DPP(DJ,"OVF0",%) Q:%'["Y(1)"
WHO S G=$TR($P($P($P(%,"Y(1)",2),")):^(",2),")"),""""),P=$P(%,"Y(1)",3),P=$P($P(P,"U,",2),")") I G]"",P]"" S P=+$O(^DD(%X,"GL",G,P,0))
I P,$D(^DD(%X,P,0)) S:DIJJ DIPP(DIJ,+%)=DIPP(DIJ,%X),DIPP(DIJ,%X)=$P(^(0),U)_":" S:'DIJJ DIPP(DIJ,+%)=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$P(^(0),U)_":"
G E2
;
;
;
L ;FROM DIP: READ SORT-BY VALUE
I $D(BY)#2 K DIC S DIC="^DD(DL,",DIC(0)="Z",X=$P(BY,","),BY=$P(BY,",",2,99) I X'="@" K DV Q
K DIR D
. N X S DIR(0)="FOU",DIR("A")=DV
. S X=$P($G(DIPP(DIJ)),U,3) I X]"" S DIR("B")=X
. E I DJ=1 N DICAN S DICAN=$$FIND^DIUCANON(.401,DL) I DICAN S (X,DIR("B"))="["_$P(DICAN,U,2)_"]" ;CANONIC SORT TEMPLATE
. I X="" S X=$G(DV(1)) I X]"" S DIR(0)="FOAU",DIR("A")=DV_": "_X_"// "
. S DIR(0)=DIR(0)_"^1:255",DIR("?")="^D DIC^DIP0"
D ^DIR K DIR,DV,DIRUT,DIROUT S:$D(DTOUT) X="^"
K:X?1"^"1.E DUOUT
I X="@" K DPP(DJ) S DJ=DJ-1
D SETDIC Q
;
SETDIC K DIC S DIC="^DD(DL,"
S DIC("S")="S %=$P(^(0),U,2) I %'[""m"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W""&$S($D(DIL(+%)):DIL(+%)=DL,1:1))"_$S($D(DICS):" "_DICS,1:"")
S DIC("W")="W:$P(^(0),U,2) "" multiple)""" I $T(DICW^DIALOGZ)]"" D DICW^DIALOGZ(DL)
S DIC(0)="ZE"_$E("O",$D(DIPP)#10) Q
;
DIC D SETDIC,^DIC,DIP^DIQQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP0 4327 printed Dec 13, 2024@02:52:36 Page 2
DIP0 ;SFISC/XAK-COMPUTED FIELD ON A SORT, EDITING A SORT TEMPLATE ;2015-01-01 2:08 PM
+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 SET P=P_Q
SET DPP=$PIECE(X,U,1)
C ;
+1 SET DICOMP=N_$EXTRACT("?",''L)
SET DM=X
SET DQI="Y("
SET DA="DPP("_DJ_",""OVF"_N_""","
SET DICMX="D M^DIO2"
if X?.E1":"
GOTO COLON
DO EN^DICOMP
KILL DUOUT
if '$DATA(X)
GOTO X
if Y["m"
GOTO X
+2 DO XA
if Y["B"
DO BB^DIP
if Y["D"
SET R=R_"^^D"
SET Y=U_DPP
SET DPP(DJ,"CM")=X_" I D"_(N#100)_">0 S DISX("_DJ_")=X"
GOTO S^DIP
+3 ;
XA FOR %=0:0
SET %=$ORDER(X(%))
if %=""
QUIT
SET @(DA_"%)=X(%)")
+1 QUIT
+2 ;
+3 ;
COLON DO ^DICOMPW
KILL DUOUT
+1 IF $DATA(X)
IF $SELECT($DATA(DIL(+DP)):DIL(+DP)=DL,1:1)
SET DPP(DJ,DL,+Y)=DP_U_(Y["m")_U_X
SET DIL(+DP)=DL
SET N=+Y
SET DL=+DP
SET DV=$JUSTIFY("",DJ*2-2)_$ORDER(^DD(DL,0,"NM",0))_" FIELD"
if $DATA(DIPP(DIJ,+DP))#2
SET $PIECE(DIPP(DIJ),U,3)=DIPP(DIJ,+DP)
DO XA
DO L
GOTO Y^DIP
X ;TRY TACKING ON THE REST OF THE "BY", AFTER THE FIRST COMMA, BOTH TO 'X' AND TO 'DPP'
IF $GET(BY)]""
if BY[";"
SET R=BY
SET BY=$PIECE(BY,";")
SET R=U_$PIECE(R,BY,2,9)
SET (X,DPP)=DM_","_BY
SET BY=""
GOTO C
+1 IF $GET(DIQUIET)
GOTO Q^DIP
+2 GOTO B^DIP
+3 ;
EDT ;
+1 SET DIE="^DIBT("
SET DR=".01;3;6"
SET DA=X
SET DIPP=DI
SET DIOVRD=1
DO ^DIE
SET DI=DIPP
SET DE=$SELECT(L=0!L:"SORT",1:L)
KILL DR,DIE,DIPP,DIOVRD
IF '$DATA(DA)!($DATA(Y))
SET (X,DJ)=+$GET(DPP(0))
QUIT
+2 SET %=$GET(DPP(0,"IX"))
IF $PIECE(%,U,2)]""
IF $PIECE(%,U,4)
Begin DoDot:1
+3 NEW X,I,Y,F,T,O,Q,DIEDITBY
SET DIEDITBY=1
KILL FR(0),TO(0),DISPAR(0),DIPP
+4 SET BY(0)="^"_$PIECE(%,U,2)
SET L(0)=$PIECE(%,U,4)
+5 FOR I=L(0):1
if '$DATA(DPP(I))
QUIT
MERGE DIPP(I)=DPP(I)
KILL DPP(I)
+6 FOR I=1:1:(L(0)-1)
Begin DoDot:2
+7 SET F=$PIECE($GET(DPP(I,"F")),U,2)
SET T=$PIECE($GET(DPP(I,"T")),U,2)
if F]""
SET FR(0,I)=F
if T]""
SET TO(0,I)=T
+8 SET O=$PIECE($GET(DPP(I)),U,4)
SET Q=""
if O["!"
SET Q=Q_"!"
if O["#"
SET Q=Q_"#"
if $PIECE($GET(DPP(I)),U,5)]""
SET Q=Q_"^"_$PIECE(DPP(I),U,5)
if Q]""
SET DISPAR(0,I)=Q
+9 IF $GET(DISPAR(0,I))]""
IF $GET(DPP(I,"OUT"))]""
SET DISPAR(0,I,"OUT")=DPP(I,"OUT")
+10 KILL DPP(I)
QUIT
End DoDot:2
if '$GET(L(0))
QUIT
+11 DO BYOK^DIP100
+12 IF $GET(DPP(0))]""
SET X=DPP(0)
FOR I=0:0
SET I=$ORDER(DIPP(I))
if 'I
QUIT
SET X=X+1
MERGE DPP(X)=DIPP(I)
+13 KILL DIPP
QUIT
End DoDot:1
IF $GET(DPP(0))']""
SET (X,DJ)=0
QUIT
+14 SET DIPP=""
SET DIJ=0
FOR DJ=$GET(DPP(0)):0
SET DJ=$ORDER(DPP(DJ))
if 'DJ
QUIT
SET DIJ=DIJ+1
SET %X="DPP(DJ,"
SET %Y="DIPP(DIJ,"
DO %XY^%RCR
+15 SET DIJ=0
FOR DJ=$GET(DPP(0)):0
SET DJ=$ORDER(DPP(DJ))
if DJ=""
QUIT
Begin DoDot:1
+16 SET DIJ=DIJ+1
NEW X
SET X=$PIECE(DPP(DJ),U,4)
SET X=$TRANSLATE(X,"B","")
SET X=$SELECT(X[Q:$PIECE(X,Q,($LENGTH(X,Q)-1)),1:X)
+17 SET $PIECE(DIPP(DIJ),U,3)=X_$PIECE(DPP(DJ),U,3)_$PIECE(DPP(DJ),U,5)
+18 SET %=+DPP(DJ)
DO E1
SET %X=0
DO E2
KILL DPP(DJ)
+19 QUIT
End DoDot:1
+20 SET DJ=$GET(DPP(0))
SET DIJ=0
FOR
SET DIJ=+$ORDER(DIPP(DIJ))
if 'DIJ
QUIT
SET DJ=DJ+1
DO DJ^DIP
if $DATA(DTOUT)!($DATA(DIRUT))!('$DATA(DJ))
QUIT
if X="@"
WRITE " Deleted."
+21 KILL DIPP,DIJJ
if X'=U
SET X=1
if '$DATA(DXS)
SET DXS=1
SET DIEDT=1
QUIT
E1 ;
+1 FOR DIJJ=0:1
if '$DATA(^DD(%,0,"UP"))
QUIT
SET DIPP(DIJ,%)=$PIECE(DIPP(DIJ),U,3)
SET %=+^("UP")
SET $PIECE(DIPP(DIJ),U,3)=$ORDER(^("NM",0))
SET $PIECE(DIPP(DIJ),U,1)=%
+2 QUIT
E2 SET %X=$ORDER(DPP(DJ,%X))
IF %X'>0
KILL %X
QUIT
+1 if '$DATA(DPP(DJ,%X,100))
GOTO E2
SET %=%X
DO E1
SET %=DPP(DJ,%X,100)
+2 IF $PIECE(%,U,3)
SET DIPP(DIJ,+%)=$PIECE(DIPP(DIJ),U,3)
SET $PIECE(DIPP(DIJ),U,3)=$PIECE(^DIC(+%,0),U)_":"
SET $PIECE(DIPP(DIJ),U)=+%
GOTO E2
+3 IF %'["Y(1)"
SET %=$FIND(%,"OVF0")
if '%
QUIT
SET %=+$EXTRACT(DPP(DJ,%X,100),%+2,99)
SET %=$PIECE(DPP(DJ,%X,100),U)_U_DPP(DJ,"OVF0",%)
if %'["Y(1)"
QUIT
WHO SET G=$TRANSLATE($PIECE($PIECE($PIECE(%,"Y(1)",2),")):^(",2),")"),"""")
SET P=$PIECE(%,"Y(1)",3)
SET P=$PIECE($PIECE(P,"U,",2),")")
IF G]""
IF P]""
SET P=+$ORDER(^DD(%X,"GL",G,P,0))
+1 IF P
IF $DATA(^DD(%X,P,0))
if DIJJ
SET DIPP(DIJ,+%)=DIPP(DIJ,%X)
SET DIPP(DIJ,%X)=$PIECE(^(0),U)_":"
if 'DIJJ
SET DIPP(DIJ,+%)=$PIECE(DIPP(DIJ),U,3)
SET $PIECE(DIPP(DIJ),U,3)=$PIECE(^(0),U)_":"
+2 GOTO E2
+3 ;
+4 ;
+5 ;
L ;FROM DIP: READ SORT-BY VALUE
+1 IF $DATA(BY)#2
KILL DIC
SET DIC="^DD(DL,"
SET DIC(0)="Z"
SET X=$PIECE(BY,",")
SET BY=$PIECE(BY,",",2,99)
IF X'="@"
KILL DV
QUIT
+2 KILL DIR
Begin DoDot:1
+3 NEW X
SET DIR(0)="FOU"
SET DIR("A")=DV
+4 SET X=$PIECE($GET(DIPP(DIJ)),U,3)
IF X]""
SET DIR("B")=X
+5 ;CANONIC SORT TEMPLATE
IF '$TEST
IF DJ=1
NEW DICAN
SET DICAN=$$FIND^DIUCANON(.401,DL)
IF DICAN
SET (X,DIR("B"))="["_$PIECE(DICAN,U,2)_"]"
+6 IF X=""
SET X=$GET(DV(1))
IF X]""
SET DIR(0)="FOAU"
SET DIR("A")=DV_": "_X_"// "
+7 SET DIR(0)=DIR(0)_"^1:255"
SET DIR("?")="^D DIC^DIP0"
End DoDot:1
+8 DO ^DIR
KILL DIR,DV,DIRUT,DIROUT
if $DATA(DTOUT)
SET X="^"
+9 if X?1"^"1.E
KILL DUOUT
+10 IF X="@"
KILL DPP(DJ)
SET DJ=DJ-1
+11 DO SETDIC
QUIT
+12 ;
SETDIC KILL DIC
SET DIC="^DD(DL,"
+1 SET DIC("S")="S %=$P(^(0),U,2) I %'[""m"",$S('%:1,1:$P(^DD(+%,.01,0),U,2)'[""W""&$S($D(DIL(+%)):DIL(+%)=DL,1:1))"_$SELECT($DATA(DICS):" "_DICS,1:"")
+2 SET DIC("W")="W:$P(^(0),U,2) "" multiple)"""
IF $TEXT(DICW^DIALOGZ)]""
DO DICW^DIALOGZ(DL)
+3 SET DIC(0)="ZE"_$EXTRACT("O",$DATA(DIPP)#10)
QUIT
+4 ;
DIC DO SETDIC
DO ^DIC
DO DIP^DIQQ
QUIT
