source: WorldVistAEHR/trunk/r/QUALITY_ASSURANCE_INTEGRATION-QAQ/QAQAHOC2.m@ 1714

Last change on this file since 1714 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1QAQAHOC2 ;HISC/DAD-AD HOC REPORTS: SORT FROM/TO SELECTION ;2/8/93 13:10
2 ;;1.7;QM Integration Module;**1**;07/25/1995
3BEGIN ; *** 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
10END ; *** 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
25FROMTO ; *** Set the FR and TO sort strings
26 S FR(QAQSEQ)=QAQBEGIN,TO(QAQSEQ)=QAQEND,QAQBEGIN(QAQSEQ)=QAQBEGIN,QAQEND(QAQSEQ)=QAQEND
27 Q
28DIR ; *** DIR begining/ending sort input transforms
29DATE 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
31POINTER I $D(Y(0,0))#2 S Y=Y(0,0)
32 Q
33SET ;I $D(Y(0))#2 S Y=$P(Y(0),"^")
34 Q
35FIX ; *** Process the sort/print suffixes and prefixes
36SUFFIX 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
57PREFIX 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
Note: See TracBrowser for help on using the repository browser.