- 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 Feb 18, 2025@23:57:43 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