QAQAHOC2 ;HISC/DAD-AD HOC REPORTS: SORT FROM/TO SELECTION ;2/8/93 13:10
;;1.7;QM Integration Module;**1**;07/25/1995
BEGIN ; *** Prompt user for the beginning sort value
K DIR S DIR(0)=QAQDIR(0),DIR("A")=" Sort from: BEGINNING// ",DIR("?")="^D EN^QAQAHOCH(""H3"")"
W ! D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X["^") S (QAQNEXT,QAQQUIT)=1 Q
I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G BEGIN
S QAQBEGIN=$S(X="":"",X="@":"@",1:$E(Y,1,60))
I QAQBEGIN="" S QAQEND="" G FROMTO
END ; *** Prompt user for the ending sort value
K DIR S DIR(0)=QAQDIR(0),DIR("A")=" Sort to: ENDING// ",DIR("?")="^D EN^QAQAHOCH(""H4"")"
W ! D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X["^") S (QAQNEXT,QAQQUIT)=1 Q
I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G END
S QAQEND=$S(X="":"",X="@":"@",1:$E(Y,1,60))
I QAQEND]"",QAQBEGIN'=QAQEND D G:QA BEGIN
. S (X,Y)=QAQBEGIN,%DT="TS" D:$E(DIR(0))="D" ^%DT S QAQBEGIN(0)=Y
. S (X,Y)=QAQEND,%DT="TS" D:$E(DIR(0))="D" ^%DT S QAQEND(0)=Y
. I QAQEND(0)']QAQBEGIN(0) D
.. W " ??",*7,!!?7,"The ENDING value must follow the BEGINNING value !!"
.. S QA=1
.. Q
. E S QA=0
. Q
FROMTO ; *** Set the FR and TO sort strings
S FR(QAQSEQ)=QAQBEGIN,TO(QAQSEQ)=QAQEND,QAQBEGIN(QAQSEQ)=QAQBEGIN,QAQEND(QAQSEQ)=QAQEND
Q
DIR ; *** DIR begining/ending sort input transforms
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:"")
Q
POINTER I $D(Y(0,0))#2 S Y=Y(0,0)
Q
SET ;I $D(Y(0))#2 S Y=$P(Y(0),"^")
Q
FIX ; *** Process the sort/print suffixes and prefixes
SUFFIX S QAQSUFFX=$P(QAQSELOP,";",2,99),QAQPREFX=""
I QAQSUFFX="" G:QAQSELOP'[";" PREFIX S QAQSELOP="" Q
F QA="L","R","C","Y","D","S","W","N","T","X","""" I $L(";"_QAQSUFFX,";"_QA)>2 S QAQSELOP="" Q
Q:QAQSELOP=""
F QAI=1:1:$L(QAQSUFFX,";") D Q:'QAQOK
. S X=$P(QAQSUFFX,";",QAI),QAQOK=0
. F QA="S","L","C" S Y="1"""_QA_"""1.N" I X?@Y S QAQOK=1 Q
. S:X="S" QAQOK=1 I X?1"""".ANP1"""",$L(X,"""")#2 S QAQOK=1
. Q:QAQTYPE="S"
. F QA="R","Y","D","W","C-","Y-" S Y="1"""_QA_"""1.N" I X?@Y S QAQOK=1 Q
. F QA="N","T","W","X" I X=QA S QAQOK=1 Q
. Q
I 'QAQOK S QAQSELOP="" Q
I QAQSUFFX["""" D
. S QAQSUFFX(1)=$P($S($E(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""")
. S QAQSUFFX(2)=$P($S($E(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""",2,99)
. S QAQSUFFX(3)=$P(QAQSUFFX(2),";")
. S QAQSUFFX(2)=$P(QAQSUFFX(2),";",2,99)
. S QAQSUFFX=QAQSUFFX(1)_$S(QAQSUFFX(2)]"":";"_QAQSUFFX(2),1:"")_";"""_QAQSUFFX(3)
. Q
S:$E(QAQSUFFX)'=";" QAQSUFFX=";"_QAQSUFFX
PREFIX S QAQSELOP=$P(QAQSELOP,";")
S QAQPREFX=$TR(QAQSELOP,$TR(QAQSELOP,QAQPREFX(0)))
I QAQPREFX]"" F QA=1:1:$L(QAQPREFX(0)) I $L(QAQPREFX,$E(QAQPREFX(0),QA))>2 S QAQSELOP="" Q
S QAQSELOP=$E(QAQSELOP,$F(QAQSELOP_"^",$E($TR(QAQSELOP,QAQPREFX(0))_"^"))-1,999)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQAHOC2 2867 printed Apr 09, 2024@21:34:04 Page 2
QAQAHOC2 ;HISC/DAD-AD HOC REPORTS: SORT FROM/TO SELECTION ;2/8/93 13:10
+1 ;;1.7;QM Integration Module;**1**;07/25/1995
BEGIN ; *** Prompt user for the beginning sort value
+1 KILL DIR
SET DIR(0)=QAQDIR(0)
SET DIR("A")=" Sort from: BEGINNING// "
SET DIR("?")="^D EN^QAQAHOCH(""H3"")"
+2 WRITE !
DO ^DIR
+3 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(X["^")
SET (QAQNEXT,QAQQUIT)=1
QUIT
+4 IF "PD"[$EXTRACT(DIR(0))
IF X]""
IF X'="@"
IF Y=-1
GOTO BEGIN
+5 SET QAQBEGIN=$SELECT(X="":"",X="@":"@",1:$EXTRACT(Y,1,60))
+6 IF QAQBEGIN=""
SET QAQEND=""
GOTO FROMTO
END ; *** Prompt user for the ending sort value
+1 KILL DIR
SET DIR(0)=QAQDIR(0)
SET DIR("A")=" Sort to: ENDING// "
SET DIR("?")="^D EN^QAQAHOCH(""H4"")"
+2 WRITE !
DO ^DIR
+3 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(X["^")
SET (QAQNEXT,QAQQUIT)=1
QUIT
+4 IF "PD"[$EXTRACT(DIR(0))
IF X]""
IF X'="@"
IF Y=-1
GOTO END
+5 SET QAQEND=$SELECT(X="":"",X="@":"@",1:$EXTRACT(Y,1,60))
+6 IF QAQEND]""
IF QAQBEGIN'=QAQEND
Begin DoDot:1
+7 SET (X,Y)=QAQBEGIN
SET %DT="TS"
if $EXTRACT(DIR(0))="D"
DO ^%DT
SET QAQBEGIN(0)=Y
+8 SET (X,Y)=QAQEND
SET %DT="TS"
if $EXTRACT(DIR(0))="D"
DO ^%DT
SET QAQEND(0)=Y
+9 IF QAQEND(0)']QAQBEGIN(0)
Begin DoDot:2
+10 WRITE " ??",*7,!!?7,"The ENDING value must follow the BEGINNING value !!"
+11 SET QA=1
+12 QUIT
End DoDot:2
+13 IF '$TEST
SET QA=0
+14 QUIT
End DoDot:1
if QA
GOTO BEGIN
FROMTO ; *** Set the FR and TO sort strings
+1 SET FR(QAQSEQ)=QAQBEGIN
SET TO(QAQSEQ)=QAQEND
SET QAQBEGIN(QAQSEQ)=QAQBEGIN
SET QAQEND(QAQSEQ)=QAQEND
+2 QUIT
DIR ; *** DIR begining/ending sort input transforms
DATE IF Y
if Y#1
SET Y=$JUSTIFY(Y,0,6)
SET Y=$SELECT($EXTRACT(Y,4,5):$EXTRACT(Y,4,5)_"/",1:"")_$SELECT($EXTRACT(Y,6,7):$EXTRACT(Y,6,7)_"/",1:"")_(1700+$EXTRACT(Y,1,3))_$SELECT(Y#1:"@"_$EXTRACT(Y,9,10)_":"_$EXTRACT(Y,11,12)_":"_$EXTRACT(Y,13,14),1:"")
+1 QUIT
POINTER IF $DATA(Y(0,0))#2
SET Y=Y(0,0)
+1 QUIT
SET ;I $D(Y(0))#2 S Y=$P(Y(0),"^")
+1 QUIT
FIX ; *** Process the sort/print suffixes and prefixes
SUFFIX SET QAQSUFFX=$PIECE(QAQSELOP,";",2,99)
SET QAQPREFX=""
+1 IF QAQSUFFX=""
if QAQSELOP'[";"
GOTO PREFIX
SET QAQSELOP=""
QUIT
+2 FOR QA="L","R","C","Y","D","S","W","N","T","X",""""
IF $LENGTH(";"_QAQSUFFX,";"_QA)>2
SET QAQSELOP=""
QUIT
+3 if QAQSELOP=""
QUIT
+4 FOR QAI=1:1:$LENGTH(QAQSUFFX,";")
Begin DoDot:1
+5 SET X=$PIECE(QAQSUFFX,";",QAI)
SET QAQOK=0
+6 FOR QA="S","L","C"
SET Y="1"""_QA_"""1.N"
IF X?@Y
SET QAQOK=1
QUIT
+7 if X="S"
SET QAQOK=1
IF X?1"""".ANP1""""
IF $LENGTH(X,"""")#2
SET QAQOK=1
+8 if QAQTYPE="S"
QUIT
+9 FOR QA="R","Y","D","W","C-","Y-"
SET Y="1"""_QA_"""1.N"
IF X?@Y
SET QAQOK=1
QUIT
+10 FOR QA="N","T","W","X"
IF X=QA
SET QAQOK=1
QUIT
+11 QUIT
End DoDot:1
if 'QAQOK
QUIT
+12 IF 'QAQOK
SET QAQSELOP=""
QUIT
+13 IF QAQSUFFX[""""
Begin DoDot:1
+14 SET QAQSUFFX(1)=$PIECE($SELECT($EXTRACT(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""")
+15 SET QAQSUFFX(2)=$PIECE($SELECT($EXTRACT(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""",2,99)
+16 SET QAQSUFFX(3)=$PIECE(QAQSUFFX(2),";")
+17 SET QAQSUFFX(2)=$PIECE(QAQSUFFX(2),";",2,99)
+18 SET QAQSUFFX=QAQSUFFX(1)_$SELECT(QAQSUFFX(2)]"":";"_QAQSUFFX(2),1:"")_";"""_QAQSUFFX(3)
+19 QUIT
End DoDot:1
+20 if $EXTRACT(QAQSUFFX)'=";"
SET QAQSUFFX=";"_QAQSUFFX
PREFIX SET QAQSELOP=$PIECE(QAQSELOP,";")
+1 SET QAQPREFX=$TRANSLATE(QAQSELOP,$TRANSLATE(QAQSELOP,QAQPREFX(0)))
+2 IF QAQPREFX]""
FOR QA=1:1:$LENGTH(QAQPREFX(0))
IF $LENGTH(QAQPREFX,$EXTRACT(QAQPREFX(0),QA))>2
SET QAQSELOP=""
QUIT
+3 SET QAQSELOP=$EXTRACT(QAQSELOP,$FIND(QAQSELOP_"^",$EXTRACT($TRANSLATE(QAQSELOP,QAQPREFX(0))_"^"))-1,999)
+4 QUIT
