source: WorldVistAEHR/trunk/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNAHOC2.m@ 767

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

initial load of WorldVistAEHR
File size: 3.4 KB
Line 
1SPNAHOC2 ;HISC/DAD-AD HOC REPORTS: SORT FROM/TO SELECTION ;9/9/96 14:01
2 ;;2.0;Spinal Cord Dysfunction;**15**;01/02/1997
3 ;
4BEGIN ; *** Prompt user for the beginning sort value
5 K DIR S DIR(0)=SPNDIR(0),DIR("A")=" Sort from: BEGINNING// "
6 I $G(SPNDIR("S"))]"" S DIR("S")=SPNDIR("S")
7 S DIR("?")="^D EN^SPNAHOCH(""H3"")"
8 W ! D ^DIR
9 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X[U) S (SPNNEXT,SPNQUIT)=1 Q
10 I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G BEGIN
11 S SPNBEGIN=$S(X="":"",X="@":"@",1:$E(Y,1,60))
12 I ((Y?4N)&(Y>1900))!($E(Y,3)="/") D
13 .I $L(SPNBEGIN)=4 S SPNBEGIN="01/01/"_SPNBEGIN
14 .I $L(SPNBEGIN)<10 S SPNBEGIN=$P(SPNBEGIN,"/",1)_"/"_$P(SPNBEGIN,"/",2)
15 .I $E(SPNBEGIN,4,5)="01" S $P(SPNBEGIN,"/",2)=""
16 I SPNBEGIN="" S SPNEND="" G FROMTO
17END ; *** Prompt user for the ending sort value
18 K DIR S DIR(0)=SPNDIR(0),DIR("A")=" Sort to: ENDING// "
19 I $G(SPNDIR("S"))]"" S DIR("S")=SPNDIR("S")
20 S DIR("?")="^D EN^SPNAHOCH(""H4"")"
21 W ! D ^DIR
22 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(X[U) S (SPNNEXT,SPNQUIT)=1 Q
23 I "PD"[$E(DIR(0)),X]"",X'="@",Y=-1 G END
24 S SPNEND=$S(X="":"",X="@":"@",1:$E(Y,1,60))
25 I ((Y?4N)&(Y>1900))!($E(Y,3)="/") D
26 .I $L(SPNEND)=4 S SPNEND="12/31/"_SPNEND
27 .I $L(SPNEND)<10 S SPNENDZ=SPNEND,SPNENDM=+$E(SPNEND,1,2),SPNENDM=$S("^01^03^05^07^08^10^12^"[(U_SPNENDM_U):31,SPNENDM'=02:30,$E(SPNENDZ,4,7)#4:28,1:29)
28 .I $L(SPNEND)<10 S SPNEND=$P(SPNEND,"/",1)_"/"_SPNENDM_"/"_$P(SPNEND,"/",2)
29 I SPNEND]"",SPNBEGIN'=SPNEND D G:SP BEGIN
30 . S (X,Y)=SPNBEGIN,%DT="TS" D:$E(DIR(0))="D" ^%DT S SPNBEGIN(0)=Y
31 . S (X,Y)=SPNEND,%DT="TS" D:$E(DIR(0))="D" ^%DT S SPNEND(0)=Y
32 . I SPNEND(0)']SPNBEGIN(0) D
33 .. S SP=1 W " ??",$C(7)
34 .. W !!?7,"The ENDING value must follow the BEGINNING value !!"
35 .. Q
36 . E S SP=0
37 . Q
38FROMTO ; *** Set the FR and TO sort strings
39 S FR(SPNSEQ)=SPNBEGIN,TO(SPNSEQ)=SPNEND
40 Q
41DIR ; *** DIR begining/ending sort input transforms
42DATE 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:"")
43 Q
44POINTER I $D(Y(0,0))#2 S Y=Y(0,0)
45 Q
46SET ;I $D(Y(0))#2 S Y=$P(Y(0),U)
47 Q
48FIX ; *** Process the sort/print suffixes and prefixes
49SUFFIX S SPNSUFFX=$P(SPNSELOP,";",2,99),SPNPREFX=""
50 I SPNSUFFX="" G:SPNSELOP'[";" PREFIX S SPNSELOP="" Q
51 F SP="L","R","C","Y","D","S","W","N","T","X","""" D Q:SPNSELOP=""
52 . I $L(";"_SPNSUFFX,";"_SP)>2 S SPNSELOP=""
53 . Q
54 Q:SPNSELOP=""
55 F SPI=1:1:$L(SPNSUFFX,";") D Q:'SPNOK
56 . S X=$P(SPNSUFFX,";",SPI),SPNOK=0
57 . F SP="S","L","C" S Y="1"""_SP_"""1.N" I X?@Y S SPNOK=1 Q
58 . S:X="S" SPNOK=1 I X?1"""".ANP1"""",$L(X,"""")#2 S SPNOK=1
59 . I SPNTYPE="S" S:X="TXT" SPNOK=1 Q
60 . F SP="R","Y","D","W","C-","Y-" S Y="1"""_SP_"""1.N" I X?@Y S SPNOK=1 Q
61 . F SP="N","T","W","X" I X=SP S SPNOK=1 Q
62 . Q
63 I 'SPNOK S SPNSELOP="" Q
64 I SPNSUFFX["""" D
65 . S SPNSUFFX(1)=$P($S($E(SPNSUFFX)="""":";",1:"")_SPNSUFFX,";""")
66 . S SPNSUFFX(2)=$P($S($E(SPNSUFFX)="""":";",1:"")_SPNSUFFX,";""",2,99)
67 . S SPNSUFFX(3)=$P(SPNSUFFX(2),";")
68 . S SPNSUFFX(2)=$P(SPNSUFFX(2),";",2,99)
69 . S SPNSUFFX=SPNSUFFX(1)_$S(SPNSUFFX(2)]"":";"_SPNSUFFX(2),1:"")_";"""_SPNSUFFX(3)
70 . Q
71 S:$E(SPNSUFFX)'=";" SPNSUFFX=";"_SPNSUFFX
72PREFIX S SPNSELOP=$P(SPNSELOP,";")
73 S SPNPREFX=$TR(SPNSELOP,$TR(SPNSELOP,SPNPREFX(0)))
74 I SPNPREFX]"" F SP=1:1:$L(SPNPREFX(0)) D Q:SPNSELOP=""
75 . I $L(SPNPREFX,$E(SPNPREFX(0),SP))>2 S SPNSELOP=""
76 . Q
77 S SPNSELOP=$E(SPNSELOP,$F(SPNSELOP_U,$E($TR(SPNSELOP,SPNPREFX(0))_U))-1,$L(SPNSELOP))
78 Q
Note: See TracBrowser for help on using the repository browser.