| [613] | 1 | QAQAHOC2 ;HISC/DAD-AD HOC REPORTS: SORT FROM/TO SELECTION ;2/8/93 13:10
|
|---|
| 2 | ;;1.7;QM Integration Module;**1**;07/25/1995
|
|---|
| 3 | BEGIN ; *** Prompt user for the beginning sort value
|
|---|
| 4 | K DIR S DIR(0)=QAQDIR(0),DIR("A")=" Sort from: BEGINNING// ",DIR("?")="^D EN^QAQAHOCH(""H3"")"
|
|---|
| 5 | W ! D ^DIR
|
|---|
| 6 | I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X["^") S (QAQNEXT,QAQQUIT)=1 Q
|
|---|
| 7 | I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G BEGIN
|
|---|
| 8 | S QAQBEGIN=$S(X="":"",X="@":"@",1:$E(Y,1,60))
|
|---|
| 9 | I QAQBEGIN="" S QAQEND="" G FROMTO
|
|---|
| 10 | END ; *** Prompt user for the ending sort value
|
|---|
| 11 | K DIR S DIR(0)=QAQDIR(0),DIR("A")=" Sort to: ENDING// ",DIR("?")="^D EN^QAQAHOCH(""H4"")"
|
|---|
| 12 | W ! D ^DIR
|
|---|
| 13 | I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X["^") S (QAQNEXT,QAQQUIT)=1 Q
|
|---|
| 14 | I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G END
|
|---|
| 15 | S QAQEND=$S(X="":"",X="@":"@",1:$E(Y,1,60))
|
|---|
| 16 | I QAQEND]"",QAQBEGIN'=QAQEND D G:QA BEGIN
|
|---|
| 17 | . S (X,Y)=QAQBEGIN,%DT="TS" D:$E(DIR(0))="D" ^%DT S QAQBEGIN(0)=Y
|
|---|
| 18 | . S (X,Y)=QAQEND,%DT="TS" D:$E(DIR(0))="D" ^%DT S QAQEND(0)=Y
|
|---|
| 19 | . I QAQEND(0)']QAQBEGIN(0) D
|
|---|
| 20 | .. W " ??",*7,!!?7,"The ENDING value must follow the BEGINNING value !!"
|
|---|
| 21 | .. S QA=1
|
|---|
| 22 | .. Q
|
|---|
| 23 | . E S QA=0
|
|---|
| 24 | . Q
|
|---|
| 25 | FROMTO ; *** Set the FR and TO sort strings
|
|---|
| 26 | S FR(QAQSEQ)=QAQBEGIN,TO(QAQSEQ)=QAQEND,QAQBEGIN(QAQSEQ)=QAQBEGIN,QAQEND(QAQSEQ)=QAQEND
|
|---|
| 27 | Q
|
|---|
| 28 | DIR ; *** DIR begining/ending sort input transforms
|
|---|
| 29 | DATE I Y S:Y#1 Y=$J(Y,0,6) S Y=$S($E(Y,4,5):$E(Y,4,5)_"/",1:"")_$S($E(Y,6,7):$E(Y,6,7)_"/",1:"")_(1700+$E(Y,1,3))_$S(Y#1:"@"_$E(Y,9,10)_":"_$E(Y,11,12)_":"_$E(Y,13,14),1:"")
|
|---|
| 30 | Q
|
|---|
| 31 | POINTER I $D(Y(0,0))#2 S Y=Y(0,0)
|
|---|
| 32 | Q
|
|---|
| 33 | SET ;I $D(Y(0))#2 S Y=$P(Y(0),"^")
|
|---|
| 34 | Q
|
|---|
| 35 | FIX ; *** Process the sort/print suffixes and prefixes
|
|---|
| 36 | SUFFIX S QAQSUFFX=$P(QAQSELOP,";",2,99),QAQPREFX=""
|
|---|
| 37 | I QAQSUFFX="" G:QAQSELOP'[";" PREFIX S QAQSELOP="" Q
|
|---|
| 38 | F QA="L","R","C","Y","D","S","W","N","T","X","""" I $L(";"_QAQSUFFX,";"_QA)>2 S QAQSELOP="" Q
|
|---|
| 39 | Q:QAQSELOP=""
|
|---|
| 40 | F QAI=1:1:$L(QAQSUFFX,";") D Q:'QAQOK
|
|---|
| 41 | . S X=$P(QAQSUFFX,";",QAI),QAQOK=0
|
|---|
| 42 | . F QA="S","L","C" S Y="1"""_QA_"""1.N" I X?@Y S QAQOK=1 Q
|
|---|
| 43 | . S:X="S" QAQOK=1 I X?1"""".ANP1"""",$L(X,"""")#2 S QAQOK=1
|
|---|
| 44 | . Q:QAQTYPE="S"
|
|---|
| 45 | . F QA="R","Y","D","W","C-","Y-" S Y="1"""_QA_"""1.N" I X?@Y S QAQOK=1 Q
|
|---|
| 46 | . F QA="N","T","W","X" I X=QA S QAQOK=1 Q
|
|---|
| 47 | . Q
|
|---|
| 48 | I 'QAQOK S QAQSELOP="" Q
|
|---|
| 49 | I QAQSUFFX["""" D
|
|---|
| 50 | . S QAQSUFFX(1)=$P($S($E(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""")
|
|---|
| 51 | . S QAQSUFFX(2)=$P($S($E(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""",2,99)
|
|---|
| 52 | . S QAQSUFFX(3)=$P(QAQSUFFX(2),";")
|
|---|
| 53 | . S QAQSUFFX(2)=$P(QAQSUFFX(2),";",2,99)
|
|---|
| 54 | . S QAQSUFFX=QAQSUFFX(1)_$S(QAQSUFFX(2)]"":";"_QAQSUFFX(2),1:"")_";"""_QAQSUFFX(3)
|
|---|
| 55 | . Q
|
|---|
| 56 | S:$E(QAQSUFFX)'=";" QAQSUFFX=";"_QAQSUFFX
|
|---|
| 57 | PREFIX S QAQSELOP=$P(QAQSELOP,";")
|
|---|
| 58 | S QAQPREFX=$TR(QAQSELOP,$TR(QAQSELOP,QAQPREFX(0)))
|
|---|
| 59 | I QAQPREFX]"" F QA=1:1:$L(QAQPREFX(0)) I $L(QAQPREFX,$E(QAQPREFX(0),QA))>2 S QAQSELOP="" Q
|
|---|
| 60 | S QAQSELOP=$E(QAQSELOP,$F(QAQSELOP_"^",$E($TR(QAQSELOP,QAQPREFX(0))_"^"))-1,999)
|
|---|
| 61 | Q
|
|---|
