- DIP1 ;SFISC/GFT,TKW-PROCESS FROM-TO ;24APR2014
- ;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
- ;;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.
- ;
- D DJ Q
- ;
- ;
- DUP D DPQ G DIP1^DIQQQ:$D(A(1))
- I '($D(BY)#2),$D(DPP((+$G(DPP(0))+2),"T"))!$D(DPP((+$G(DPP(0))+3)))!$D(DPP(0))!$D(DXS) S DK=S G S^DIBT
- DIP2 S DC=0 D:'$D(DISYS) OS^DII G ^DIP2
- ;
- FTEM I $G(DIBT1) I $O(^DIBT(DIBT1,2,0))!$G(^DIBT(DIBT1,"BY0"))]"" D
- .I $D(DIBTOLD) D SNEW^DIBT Q
- .D US^DIBT Q
- N ;
- S DCC=DI,C="," G DIP2
- ;
- DPQ K A S DPP=$G(DPP(0)) F X=DPP+1:1 Q:$D(DPP(X))#2=0 S A=$E($P(DPP(X),U,1,3),1,60),Y=$P(DPP(X),U,4),DPP=X S:Y'["'" (A($D(A(A))),A(A))=0 I Y'["@",Y'["'" S DPQ(+DPP(X),$P(Y,"""",2)+$P(DPP(X),U,2))=""
- K DPP(X) Q
- ;
- DIP11 ;FROM DIP11
- N F1,F2,F3,T1,T2,T3 D FT^DIP12
- K DPP(DJ,"F"),DPP(DJ,"T"),DIARS,DIARE G J
- ;
- ;
- DJ ;PROCESS A LEVEL OF SORTING. CALLED FROM DIP ROUTINE AT 2 PLACES
- N F1,F2,F3,T1,T2,T3,DIFLD,DIFLDREG
- D DTYP I DITYP-4,$G(R)[";TXT" W:L $C(7)," ONLY FREE-TEXT FIELDS CAN HAVE ;TXT MODIFIER" G Q
- I $D(DPP(DJ,"F")) D OPT^DIP12 Q
- D FT^DIP12
- J ;
- N DIFRO,DIPR
- S A=+DPP(DJ),R=$P(DPP(DJ),U,3)
- I $P(DPP(DJ),U,10)=3 S T3=$G(T2),F3=$G(F2)
- I $P(DPP(DJ),U,10)=1,T3?.E1"@24:00" S T3=$P(T3,"@")
- I DIFLD,$D(^DD(A,DIFLD,0)) S DC=$P(^(0),U,2,3),DIPR=$P(^(0),U)
- E I DIFLDREG]"",$D(^DD(A,.001,0)) S DC=$P(^(0),U,2,3),DIPR=$P(^(0),U)
- E S DC=$P(DPP(DJ),U,7,8),DIPR=$P(DPP(DJ),";""",2,99),DIPR=$P(DIPR,"""",1,$L(DIPR,"""")-1),DIPR=$S(DIPR'="":DIPR,1:R),%=$E(DIPR,$L(DIPR)-1,$L(DIPR)),%=$S(%=": ":2,$E(%,2)=":":1,1:0) I % S DIPR=$E(DIPR,1,$L(DIPR)-%)
- K DIC,DIARE,DIARS N DIFRTO
- S K DIERR,DPP(DJ,"SRTTXT")
- S A=$$EZBLD^DIALOG(7070),DIFRTO="?" I 'L I $D(FR)#2!($O(FR(0))) D Z("FR") I DIFRTO'="?" G S0 ;PROMPT 'FIRST'
- I $D(DISV) D FROM^DIARCALC
- PREV K DIR I $G(F3)]"" S A=F3,X=$G(DPP(DJ,"TXT")) S:X="" X=$G(DIPP(DIJ,"TXT")) I X]"" S DIR("A",1)=$J("",DJ-1*2)_"* Previous selection: "_X ;p14
- S DIR(0)="FOU^1:245",DIR("A")=$J("",DJ-1*2)_$$EZBLD^DIALOG(7068,DIPR),DIR("?")="^D DIP1^DIQQ(1)" S:A]"" DIR("B")=A ;**CCO/NI 'START WITH'
- D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DTOUT)!$D(DUOUT)
- I X=$$EZBLD^DIALOG(7070) S A=X,X="" ;**CCO/NI
- K DIR,DIRUT,DIROUT,DIERR
- S0 I X="",A=$$EZBLD^DIALOG(7070) D:$P(DPP(DJ),U,5)[";TXT" STXT(DJ,"","",DITYP) D OPT^DIP12 Q ;**CCO/NI
- D CHECK:X'="" I X'="" I X'?.ANP!($D(DIERR)) G:DIFRTO="?" S G Q
- I $D(DICOMPUTED) M DPP(DJ,"FCOMPUTED")=DICOMPUTED K DICOMPUTED
- QUOTE I $A(X)=34,'$G(DIQUIET),DIFRTO="?" D BLD^DIALOG(7075),MSG^DIALOG("WH")
- D PAR(1,Y)
- D FRV
- S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S (B,DPP(DJ,"F"))=Y
- T ;NOW THE 'TO' HALF OF THE JOB
- K DIERR S Y="z",A=$$EZBLD^DIALOG(7071),DIFRTO="?" I 'L I $D(TO)#2!($O(TO(0))) D Z("TO") I DIFRTO'="?" G T0 ;**CCO/NI
- I $D(DISV) D TO^DIARCALC
- G T0:$G(DIAR)=4
- TOPR K DIR S DIR(0)="FOU^1:245",DIR("A")=$J("",DJ-1*2)_$$EZBLD^DIALOG(7069,DIPR),DIR("?")="^D DIP1^DIQQ(2)" D S:A]"" DIR("B")=A
- .I $G(T3)]"" S A=T3 I $G(T1)]"",'$D(DIPP(DJ,"TCOMPUTED")),'$D(DPP(DJ,"TCOMPUTED")),$$BEF^DIU5(T1,$P(B,U)) S A=$$EZBLD^DIALOG(7071) ;PROMPT 'LAST' IF 'TO' IS BEFORE FIRST
- D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DUOUT)!($D(DTOUT))
- LAST I X=$$EZBLD^DIALOG(7071) S X="",Y="z" ;**CCO/NI
- K DIR,DIRUT,DIROUT,DIERR
- T0 S Y(0)=""
- D STXT(DJ,B,"^"_X,DITYP)
- I $D(DPP(DJ,"SRTTXT")) S:$G(DPP(DJ,"F"))]"" B=DPP(DJ,"F")
- D:X]"" CHECK I $D(DIERR) G:DIFRTO="?" T G Q
- I $D(DICOMPUTED) M DPP(DJ,"TCOMPUTED")=DICOMPUTED K DICOMPUTED
- 2400 I DITYP=1,Y,Y'["." S Y=Y_".24",X=X_"@2400",Y(0)=Y(0)_"@24:00"
- I Y'="z" D PAR(2,Y)
- S:$D(DPP(DJ,"SRTTXT")) Y=$P(" ",U,(X'="@"))_Y S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S DPP(DJ,"T")=Y
- I B["?z"!($P(Y,U)="@") D OPT^DIP12 Q
- I '$D(DPP(DJ,"TCOMPUTED")),'$D(DPP(DJ,"FCOMPUTED")),$$BEF^DIU5($P(Y,U),$P(B,U)) D:'$G(DIQUIET) FER1^DIQQ G:DIFRTO="?" T G Q ;'START WITH' FOLLOWS 'GO TO'
- D OPT^DIP12
- Q
- ;
- ;
- CHECK ;MAY RETURN 'DICOMPUTED'
- S Y(0)=""
- K DICOMPUTED I X?1"@"1.E D I $D(DICOMPUTED) Q
- .N GFT,GFTRY,Y,%,DA,DICOMPX,DICOMP
- .S GFT=X,(X,GFTRY)=$E(X,2,999),DICOMP=$E("X",$G(DUZ(0))'="@"),DA="X(" D ^DICOMP
- .I $D(X) S %=1,Y="DO YOU MEAN '"_GFTRY_"' AS A VARIABLE" I '$G(DIQUIET) W !?63-$L(Y),Y D YN^DICN K:%-1 X
- .M:$D(X) DICOMPUTED=X S X=GFT
- D CK^DIP12 ;MAY CHANGE Y(0)
- Q
- ;
- FRV N M I +$P(Y,"E")=Y S Y=Y-$S(Y:.000001,$P(DPP(DJ),U,2)'=0&$L(DC):1,1:0) Q
- F %=$L($E(Y,1,30)):-1:1 S M=$A(Y,%) I M>32 S Y=$E(Y,1,%-1)_$C(M-1)_$C(122) Q
- Q
- ;
- DTYP ;FIGURE OUT FIELD TYPE. COME HERE FROM ABOVE, AND ALSO T1+2^DIP11
- N S S DIFLDREG=$P(DPP(DJ),U,2),DIFLD=DIFLDREG+$P($P(DPP(DJ),U,4),"""",2) I 'DIFLD,DIFLDREG'="" S DIFLD=.001
- S S=$P(DPP(DJ),U)
- D1 K DITYP S DITYP=""
- I DIFLD D DTYP^DIOU(+S,DIFLD,.DITYP) I $G(^DD(S,DIFLD,2))]"",DITYP'=1 S DITYP=4 ;GFT
- I DITYP=6,$G(DITYP("T"))=1 S DITYP("D")="TS"
- S:$G(DITYP("T")) DITYP=DITYP("T")
- I DITYP="",'DIFLD,$P(DPP(DJ),U,7)]"" D
- . N I,X S X=$P(DPP(DJ),U,7),I=""
- . F S I=$O(^DI(.81,"C",I)) Q:I="" I X[I S DITYP=$O(^(I,0)) Q
- . S:DITYP=1 DITYP("D")="TS"
- . Q
- S:'DITYP DITYP=4
- DTYPQ S $P(DPP(DJ),U,10)=DITYP Q
- ;
- Q K DITYP,DIERR,DIR S:$D(DTOUT) X="^" G Q^DIP ;WE ARE ABORTING
- ;
- PAR(M,Y) ;REMEMBER PARAMETER IF THERE IS A ";P" SPECIFIER. M=1 or M=2
- S M=$P($P($P($P(DPP(DJ),U,5),";P",2),";",1),"-",M)
- I M?1.ANP S DIPA($E(M,1,30))=Y
- Q
- ;
- Z(%) I %="FR" S X=$S($D(FR)#2:$P(FR,",",DJ),$D(FR(DJ))#2:FR(DJ),1:"?")
- I %="TO" S X=$S($D(TO)#2:$P(TO,",",DJ),$D(TO(DJ))#2:TO(DJ),1:"?")
- I X'="?" S DIFRTO=""
- Q
- ;
- STXT(DJ,F,T,DITYP) ;DETERMINE IF USER WANTS TO SORT FREE-TEXT FIELDS CONTAINING NUMBERS AS TEXT. COME HERE FROM ABOVE AND ALSO T1+2^DIP11
- K DPP(DJ,"SRTTXT") Q:"3,4"'[DITYP
- N F2,T2 S F2=$P(F,U,2),T2=$P(T,U,2)
- I F2]"" Q:F2=T2 Q:($E(F2,1)?1A)&($E(T2,1)?1A) I F2?1.N.1".".N,T2?1.N.1".".N Q:+F2'=F2&(+T2'=T2)
- I $P($G(DPP(DJ)),U,5)[";TXT" S DPP(DJ,"SRTTXT")="SORT" G N2
- Q:+$E(F2,"E")=F2&(+$E(T2,"E")=T2)
- I F2?1.N.1".".N,+F2'=F2 S DPP(DJ,"SRTTXT")="RANGE"
- I T2?1.N.1".".N,+T2'=T2 S DPP(DJ,"SRTTXT")="RANGE"
- N2 Q:'$D(DPP(DJ,"SRTTXT"))
- K DPP(DJ,"IX"),DPP(DJ,"PTRIX")
- I F]"",$P(F,U)'="?z",$G(DPP(DJ,"F"))]"" N Y D S DPP(DJ,"F")=Y_U_$P(F,U,2,3)
- . S Y=$P(F,U) I F2]"" S Y=" "_F2 D FRV
- . Q
- Q:$G(DPP(DJ,"T"))=""!("@"[$P(T,U))
- S DPP(DJ,"T")=$S($P(T,U,2)]"":" "_$P(T,U,2)_U_$P(T,U,2,3),1:T) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP1 6436 printed Feb 19, 2025@00:18:51 Page 2
- DIP1 ;SFISC/GFT,TKW-PROCESS FROM-TO ;24APR2014
- +1 ;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
- +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 DO DJ
- QUIT
- +8 ;
- +9 ;
- DUP DO DPQ
- if $DATA(A(1))
- GOTO DIP1^DIQQQ
- +1 IF '($DATA(BY)#2)
- IF $DATA(DPP((+$GET(DPP(0))+2),"T"))!$DATA(DPP((+$GET(DPP(0))+3)))!$DATA(DPP(0))!$DATA(DXS)
- SET DK=S
- GOTO S^DIBT
- DIP2 SET DC=0
- if '$DATA(DISYS)
- DO OS^DII
- GOTO ^DIP2
- +1 ;
- FTEM IF $GET(DIBT1)
- IF $ORDER(^DIBT(DIBT1,2,0))!$GET(^DIBT(DIBT1,"BY0"))]""
- Begin DoDot:1
- +1 IF $DATA(DIBTOLD)
- DO SNEW^DIBT
- QUIT
- +2 DO US^DIBT
- QUIT
- End DoDot:1
- N ;
- +1 SET DCC=DI
- SET C=","
- GOTO DIP2
- +2 ;
- DPQ KILL A
- SET DPP=$GET(DPP(0))
- FOR X=DPP+1:1
- if $DATA(DPP(X))#2=0
- QUIT
- SET A=$EXTRACT($PIECE(DPP(X),U,1,3),1,60)
- SET Y=$PIECE(DPP(X),U,4)
- SET DPP=X
- if Y'["'"
- SET (A($DATA(A(A))),A(A))=0
- IF Y'["@"
- IF Y'["'"
- SET DPQ(+DPP(X),$PIECE(Y,"""",2)+$PIECE(DPP(X),U,2))=""
- +1 KILL DPP(X)
- QUIT
- +2 ;
- DIP11 ;FROM DIP11
- +1 NEW F1,F2,F3,T1,T2,T3
- DO FT^DIP12
- +2 KILL DPP(DJ,"F"),DPP(DJ,"T"),DIARS,DIARE
- GOTO J
- +3 ;
- +4 ;
- DJ ;PROCESS A LEVEL OF SORTING. CALLED FROM DIP ROUTINE AT 2 PLACES
- +1 NEW F1,F2,F3,T1,T2,T3,DIFLD,DIFLDREG
- +2 DO DTYP
- IF DITYP-4
- IF $GET(R)[";TXT"
- if L
- WRITE $CHAR(7)," ONLY FREE-TEXT FIELDS CAN HAVE ;TXT MODIFIER"
- GOTO Q
- +3 IF $DATA(DPP(DJ,"F"))
- DO OPT^DIP12
- QUIT
- +4 DO FT^DIP12
- J ;
- +1 NEW DIFRO,DIPR
- +2 SET A=+DPP(DJ)
- SET R=$PIECE(DPP(DJ),U,3)
- +3 IF $PIECE(DPP(DJ),U,10)=3
- SET T3=$GET(T2)
- SET F3=$GET(F2)
- +4 IF $PIECE(DPP(DJ),U,10)=1
- IF T3?.E1"@24:00"
- SET T3=$PIECE(T3,"@")
- +5 IF DIFLD
- IF $DATA(^DD(A,DIFLD,0))
- SET DC=$PIECE(^(0),U,2,3)
- SET DIPR=$PIECE(^(0),U)
- +6 IF '$TEST
- IF DIFLDREG]""
- IF $DATA(^DD(A,.001,0))
- SET DC=$PIECE(^(0),U,2,3)
- SET DIPR=$PIECE(^(0),U)
- +7 IF '$TEST
- SET DC=$PIECE(DPP(DJ),U,7,8)
- SET DIPR=$PIECE(DPP(DJ),";""",2,99)
- SET DIPR=$PIECE(DIPR,"""",1,$LENGTH(DIPR,"""")-1)
- SET DIPR=$SELECT(DIPR'="":DIPR,1:R)
- SET %=$EXTRACT(DIPR,$LENGTH(DIPR)-1,$LENGTH(DIPR))
- SET %=$SELECT(%=": ":2,$EXTRACT(%,2)=":":1,1:0)
- IF %
- SET DIPR=$EXTRACT(DIPR,1,$LENGTH(DIPR)-%)
- +8 KILL DIC,DIARE,DIARS
- NEW DIFRTO
- S KILL DIERR,DPP(DJ,"SRTTXT")
- +1 ;PROMPT 'FIRST'
- SET A=$$EZBLD^DIALOG(7070)
- SET DIFRTO="?"
- IF 'L
- IF $DATA(FR)#2!($ORDER(FR(0)))
- DO Z("FR")
- IF DIFRTO'="?"
- GOTO S0
- +2 IF $DATA(DISV)
- DO FROM^DIARCALC
- PREV ;p14
- KILL DIR
- IF $GET(F3)]""
- SET A=F3
- SET X=$GET(DPP(DJ,"TXT"))
- if X=""
- SET X=$GET(DIPP(DIJ,"TXT"))
- IF X]""
- SET DIR("A",1)=$JUSTIFY("",DJ-1*2)_"* Previous selection: "_X
- +1 ;**CCO/NI 'START WITH'
- SET DIR(0)="FOU^1:245"
- SET DIR("A")=$JUSTIFY("",DJ-1*2)_$$EZBLD^DIALOG(7068,DIPR)
- SET DIR("?")="^D DIP1^DIQQ(1)"
- if A]""
- SET DIR("B")=A
- +2 DO ^DIR
- if $DATA(DTOUT)
- WRITE $CHAR(7)
- if $DATA(DTOUT)!$DATA(DUOUT)
- GOTO Q
- +3 ;**CCO/NI
- IF X=$$EZBLD^DIALOG(7070)
- SET A=X
- SET X=""
- +4 KILL DIR,DIRUT,DIROUT,DIERR
- S0 ;**CCO/NI
- IF X=""
- IF A=$$EZBLD^DIALOG(7070)
- if $PIECE(DPP(DJ),U,5)[";TXT"
- DO STXT(DJ,"","",DITYP)
- DO OPT^DIP12
- QUIT
- +1 if X'=""
- DO CHECK
- IF X'=""
- IF X'?.ANP!($DATA(DIERR))
- if DIFRTO="?"
- GOTO S
- GOTO Q
- +2 IF $DATA(DICOMPUTED)
- MERGE DPP(DJ,"FCOMPUTED")=DICOMPUTED
- KILL DICOMPUTED
- QUOTE IF $ASCII(X)=34
- IF '$GET(DIQUIET)
- IF DIFRTO="?"
- DO BLD^DIALOG(7075)
- DO MSG^DIALOG("WH")
- +1 DO PAR(1,Y)
- +2 DO FRV
- +3 SET Y=Y_U_X
- if Y(0)]""
- SET Y=Y_U_Y(0)
- SET (B,DPP(DJ,"F"))=Y
- T ;NOW THE 'TO' HALF OF THE JOB
- +1 ;**CCO/NI
- KILL DIERR
- SET Y="z"
- SET A=$$EZBLD^DIALOG(7071)
- SET DIFRTO="?"
- IF 'L
- IF $DATA(TO)#2!($ORDER(TO(0)))
- DO Z("TO")
- IF DIFRTO'="?"
- GOTO T0
- +2 IF $DATA(DISV)
- DO TO^DIARCALC
- +3 if $GET(DIAR)=4
- GOTO T0
- TOPR KILL DIR
- SET DIR(0)="FOU^1:245"
- SET DIR("A")=$JUSTIFY("",DJ-1*2)_$$EZBLD^DIALOG(7069,DIPR)
- SET DIR("?")="^D DIP1^DIQQ(2)"
- Begin DoDot:1
- +1 ;PROMPT 'LAST' IF 'TO' IS BEFORE FIRST
- IF $GET(T3)]""
- SET A=T3
- IF $GET(T1)]""
- IF '$DATA(DIPP(DJ,"TCOMPUTED"))
- IF '$DATA(DPP(DJ,"TCOMPUTED"))
- IF $$BEF^DIU5(T1,$PIECE(B,U))
- SET A=$$EZBLD^DIALOG(7071)
- End DoDot:1
- if A]""
- SET DIR("B")=A
- +2 DO ^DIR
- if $DATA(DTOUT)
- WRITE $CHAR(7)
- if $DATA(DUOUT)!($DATA(DTOUT))
- GOTO Q
- LAST ;**CCO/NI
- IF X=$$EZBLD^DIALOG(7071)
- SET X=""
- SET Y="z"
- +1 KILL DIR,DIRUT,DIROUT,DIERR
- T0 SET Y(0)=""
- +1 DO STXT(DJ,B,"^"_X,DITYP)
- +2 IF $DATA(DPP(DJ,"SRTTXT"))
- if $GET(DPP(DJ,"F"))]""
- SET B=DPP(DJ,"F")
- +3 if X]""
- DO CHECK
- IF $DATA(DIERR)
- if DIFRTO="?"
- GOTO T
- GOTO Q
- +4 IF $DATA(DICOMPUTED)
- MERGE DPP(DJ,"TCOMPUTED")=DICOMPUTED
- KILL DICOMPUTED
- 2400 IF DITYP=1
- IF Y
- IF Y'["."
- SET Y=Y_".24"
- SET X=X_"@2400"
- SET Y(0)=Y(0)_"@24:00"
- +1 IF Y'="z"
- DO PAR(2,Y)
- +2 if $DATA(DPP(DJ,"SRTTXT"))
- SET Y=$PIECE(" ",U,(X'="@"))_Y
- SET Y=Y_U_X
- if Y(0)]""
- SET Y=Y_U_Y(0)
- SET DPP(DJ,"T")=Y
- +3 IF B["?z"!($PIECE(Y,U)="@")
- DO OPT^DIP12
- QUIT
- +4 ;'START WITH' FOLLOWS 'GO TO'
- IF '$DATA(DPP(DJ,"TCOMPUTED"))
- IF '$DATA(DPP(DJ,"FCOMPUTED"))
- IF $$BEF^DIU5($PIECE(Y,U),$PIECE(B,U))
- if '$GET(DIQUIET)
- DO FER1^DIQQ
- if DIFRTO="?"
- GOTO T
- GOTO Q
- +5 DO OPT^DIP12
- +6 QUIT
- +7 ;
- +8 ;
- CHECK ;MAY RETURN 'DICOMPUTED'
- +1 SET Y(0)=""
- +2 KILL DICOMPUTED
- IF X?1"@"1.E
- Begin DoDot:1
- +3 NEW GFT,GFTRY,Y,%,DA,DICOMPX,DICOMP
- +4 SET GFT=X
- SET (X,GFTRY)=$EXTRACT(X,2,999)
- SET DICOMP=$EXTRACT("X",$GET(DUZ(0))'="@")
- SET DA="X("
- DO ^DICOMP
- +5 IF $DATA(X)
- SET %=1
- SET Y="DO YOU MEAN '"_GFTRY_"' AS A VARIABLE"
- IF '$GET(DIQUIET)
- WRITE !?63-$LENGTH(Y),Y
- DO YN^DICN
- if %-1
- KILL X
- +6 if $DATA(X)
- MERGE DICOMPUTED=X
- SET X=GFT
- End DoDot:1
- IF $DATA(DICOMPUTED)
- QUIT
- +7 ;MAY CHANGE Y(0)
- DO CK^DIP12
- +8 QUIT
- +9 ;
- FRV NEW M
- IF +$PIECE(Y,"E")=Y
- SET Y=Y-$SELECT(Y:.000001,$PIECE(DPP(DJ),U,2)'=0&$LENGTH(DC):1,1:0)
- QUIT
- +1 FOR %=$LENGTH($EXTRACT(Y,1,30)):-1:1
- SET M=$ASCII(Y,%)
- IF M>32
- SET Y=$EXTRACT(Y,1,%-1)_$CHAR(M-1)_$CHAR(122)
- QUIT
- +2 QUIT
- +3 ;
- DTYP ;FIGURE OUT FIELD TYPE. COME HERE FROM ABOVE, AND ALSO T1+2^DIP11
- +1 NEW S
- SET DIFLDREG=$PIECE(DPP(DJ),U,2)
- SET DIFLD=DIFLDREG+$PIECE($PIECE(DPP(DJ),U,4),"""",2)
- IF 'DIFLD
- IF DIFLDREG'=""
- SET DIFLD=.001
- +2 SET S=$PIECE(DPP(DJ),U)
- D1 KILL DITYP
- SET DITYP=""
- +1 ;GFT
- IF DIFLD
- DO DTYP^DIOU(+S,DIFLD,.DITYP)
- IF $GET(^DD(S,DIFLD,2))]""
- IF DITYP'=1
- SET DITYP=4
- +2 IF DITYP=6
- IF $GET(DITYP("T"))=1
- SET DITYP("D")="TS"
- +3 if $GET(DITYP("T"))
- SET DITYP=DITYP("T")
- +4 IF DITYP=""
- IF 'DIFLD
- IF $PIECE(DPP(DJ),U,7)]""
- Begin DoDot:1
- +5 NEW I,X
- SET X=$PIECE(DPP(DJ),U,7)
- SET I=""
- +6 FOR
- SET I=$ORDER(^DI(.81,"C",I))
- if I=""
- QUIT
- IF X[I
- SET DITYP=$ORDER(^(I,0))
- QUIT
- +7 if DITYP=1
- SET DITYP("D")="TS"
- +8 QUIT
- End DoDot:1
- +9 if 'DITYP
- SET DITYP=4
- DTYPQ SET $PIECE(DPP(DJ),U,10)=DITYP
- QUIT
- +1 ;
- Q ;WE ARE ABORTING
- KILL DITYP,DIERR,DIR
- if $DATA(DTOUT)
- SET X="^"
- GOTO Q^DIP
- +1 ;
- PAR(M,Y) ;REMEMBER PARAMETER IF THERE IS A ";P" SPECIFIER. M=1 or M=2
- +1 SET M=$PIECE($PIECE($PIECE($PIECE(DPP(DJ),U,5),";P",2),";",1),"-",M)
- +2 IF M?1.ANP
- SET DIPA($EXTRACT(M,1,30))=Y
- +3 QUIT
- +4 ;
- Z(%) IF %="FR"
- SET X=$SELECT($DATA(FR)#2:$PIECE(FR,",",DJ),$DATA(FR(DJ))#2:FR(DJ),1:"?")
- +1 IF %="TO"
- SET X=$SELECT($DATA(TO)#2:$PIECE(TO,",",DJ),$DATA(TO(DJ))#2:TO(DJ),1:"?")
- +2 IF X'="?"
- SET DIFRTO=""
- +3 QUIT
- +4 ;
- STXT(DJ,F,T,DITYP) ;DETERMINE IF USER WANTS TO SORT FREE-TEXT FIELDS CONTAINING NUMBERS AS TEXT. COME HERE FROM ABOVE AND ALSO T1+2^DIP11
- +1 KILL DPP(DJ,"SRTTXT")
- if "3,4"'[DITYP
- QUIT
- +2 NEW F2,T2
- SET F2=$PIECE(F,U,2)
- SET T2=$PIECE(T,U,2)
- +3 IF F2]""
- if F2=T2
- QUIT
- if ($EXTRACT(F2,1)?1A)&($EXTRACT(T2,1)?1A)
- QUIT
- IF F2?1.N.1".".N
- IF T2?1.N.1".".N
- if +F2'=F2&(+T2'=T2)
- QUIT
- +4 IF $PIECE($GET(DPP(DJ)),U,5)[";TXT"
- SET DPP(DJ,"SRTTXT")="SORT"
- GOTO N2
- +5 if +$EXTRACT(F2,"E")=F2&(+$EXTRACT(T2,"E")=T2)
- QUIT
- +6 IF F2?1.N.1".".N
- IF +F2'=F2
- SET DPP(DJ,"SRTTXT")="RANGE"
- +7 IF T2?1.N.1".".N
- IF +T2'=T2
- SET DPP(DJ,"SRTTXT")="RANGE"
- N2 if '$DATA(DPP(DJ,"SRTTXT"))
- QUIT
- +1 KILL DPP(DJ,"IX"),DPP(DJ,"PTRIX")
- +2 IF F]""
- IF $PIECE(F,U)'="?z"
- IF $GET(DPP(DJ,"F"))]""
- NEW Y
- Begin DoDot:1
- +3 SET Y=$PIECE(F,U)
- IF F2]""
- SET Y=" "_F2
- DO FRV
- +4 QUIT
- End DoDot:1
- SET DPP(DJ,"F")=Y_U_$PIECE(F,U,2,3)
- +5 if $GET(DPP(DJ,"T"))=""!("@"[$PIECE(T,U))
- QUIT
- +6 SET DPP(DJ,"T")=$SELECT($PIECE(T,U,2)]"":" "_$PIECE(T,U,2)_U_$PIECE(T,U,2,3),1:T)
- QUIT
