Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: QAQAHOC2

QAQAHOC2.m

Go to the documentation of this file.
  1. 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
  1. BEGIN ; *** Prompt user for the beginning sort value
  1. K DIR S DIR(0)=QAQDIR(0),DIR("A")=" Sort from: BEGINNING// ",DIR("?")="^D EN^QAQAHOCH(""H3"")"
  1. W ! D ^DIR
  1. I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X["^") S (QAQNEXT,QAQQUIT)=1 Q
  1. I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G BEGIN
  1. S QAQBEGIN=$S(X="":"",X="@":"@",1:$E(Y,1,60))
  1. I QAQBEGIN="" S QAQEND="" G FROMTO
  1. END ; *** Prompt user for the ending sort value
  1. K DIR S DIR(0)=QAQDIR(0),DIR("A")=" Sort to: ENDING// ",DIR("?")="^D EN^QAQAHOCH(""H4"")"
  1. W ! D ^DIR
  1. I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X["^") S (QAQNEXT,QAQQUIT)=1 Q
  1. I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G END
  1. S QAQEND=$S(X="":"",X="@":"@",1:$E(Y,1,60))
  1. I QAQEND]"",QAQBEGIN'=QAQEND D G:QA BEGIN
  1. . S (X,Y)=QAQBEGIN,%DT="TS" D:$E(DIR(0))="D" ^%DT S QAQBEGIN(0)=Y
  1. . S (X,Y)=QAQEND,%DT="TS" D:$E(DIR(0))="D" ^%DT S QAQEND(0)=Y
  1. . I QAQEND(0)']QAQBEGIN(0) D
  1. .. W " ??",*7,!!?7,"The ENDING value must follow the BEGINNING value !!"
  1. .. S QA=1
  1. .. Q
  1. . E S QA=0
  1. . Q
  1. FROMTO ; *** Set the FR and TO sort strings
  1. S FR(QAQSEQ)=QAQBEGIN,TO(QAQSEQ)=QAQEND,QAQBEGIN(QAQSEQ)=QAQBEGIN,QAQEND(QAQSEQ)=QAQEND
  1. Q
  1. DIR ; *** DIR begining/ending sort input transforms
  1. 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:"")
  1. Q
  1. POINTER I $D(Y(0,0))#2 S Y=Y(0,0)
  1. Q
  1. SET ;I $D(Y(0))#2 S Y=$P(Y(0),"^")
  1. Q
  1. FIX ; *** Process the sort/print suffixes and prefixes
  1. SUFFIX S QAQSUFFX=$P(QAQSELOP,";",2,99),QAQPREFX=""
  1. I QAQSUFFX="" G:QAQSELOP'[";" PREFIX S QAQSELOP="" Q
  1. F QA="L","R","C","Y","D","S","W","N","T","X","""" I $L(";"_QAQSUFFX,";"_QA)>2 S QAQSELOP="" Q
  1. Q:QAQSELOP=""
  1. F QAI=1:1:$L(QAQSUFFX,";") D Q:'QAQOK
  1. . S X=$P(QAQSUFFX,";",QAI),QAQOK=0
  1. . F QA="S","L","C" S Y="1"""_QA_"""1.N" I X?@Y S QAQOK=1 Q
  1. . S:X="S" QAQOK=1 I X?1"""".ANP1"""",$L(X,"""")#2 S QAQOK=1
  1. . Q:QAQTYPE="S"
  1. . F QA="R","Y","D","W","C-","Y-" S Y="1"""_QA_"""1.N" I X?@Y S QAQOK=1 Q
  1. . F QA="N","T","W","X" I X=QA S QAQOK=1 Q
  1. . Q
  1. I 'QAQOK S QAQSELOP="" Q
  1. I QAQSUFFX["""" D
  1. . S QAQSUFFX(1)=$P($S($E(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""")
  1. . S QAQSUFFX(2)=$P($S($E(QAQSUFFX)="""":";",1:"")_QAQSUFFX,";""",2,99)
  1. . S QAQSUFFX(3)=$P(QAQSUFFX(2),";")
  1. . S QAQSUFFX(2)=$P(QAQSUFFX(2),";",2,99)
  1. . S QAQSUFFX=QAQSUFFX(1)_$S(QAQSUFFX(2)]"":";"_QAQSUFFX(2),1:"")_";"""_QAQSUFFX(3)
  1. . Q
  1. S:$E(QAQSUFFX)'=";" QAQSUFFX=";"_QAQSUFFX
  1. PREFIX S QAQSELOP=$P(QAQSELOP,";")
  1. S QAQPREFX=$TR(QAQSELOP,$TR(QAQSELOP,QAQPREFX(0)))
  1. I QAQPREFX]"" F QA=1:1:$L(QAQPREFX(0)) I $L(QAQPREFX,$E(QAQPREFX(0),QA))>2 S QAQSELOP="" Q
  1. S QAQSELOP=$E(QAQSELOP,$F(QAQSELOP_"^",$E($TR(QAQSELOP,QAQPREFX(0))_"^"))-1,999)
  1. Q