source: FOIAVistA/trunk/r/PAID-PRS/PRSECAL.m@ 1166

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1PRSECAL ;HISC/MH-CALENDAR OF CLASSES BY SERVICE AND DATE ;9/17/1998
2 ;;4.0;PAID;**44**;Sep 21, 1995
3EN1 ;ENTRY POINT FOR PRSE-CAL
4 S X=$G(^PRSE(452.7,1,"OFF")) I X=""!(X=1) D MSG6^PRSEMSG Q
5 D EN2^PRSEUTL3($G(DUZ)) I PRSESER=""&'(DUZ(0)="@") D MSG3^PRSEMSG G Q
6 S (PRSECAL,NQ,NQT,NSW1,NPC,NOUT,PSPC,PSP)=0,NSW2=1
7 D DATSEL^PRSEUTL G Q:$G(POUT) D SRT^PRSEUTL1 G Q:$G(POUT)
8 I $$EN4^PRSEUTL3($G(DUZ))!(DUZ(0)["@") D EN3^PRSEUTL1 G Q:$G(POUT)
9 I $G(PSP)=0,$G(PSPC)=0 S PSPC=PRSESER("TX")
10 W ! S ZTRTN="START^PRSECAL" D L,DEV^PRSEUTL G:POP!($D(ZTSK)) Q
11START ;
12 K ^TMP("PRSE",$J)
13 S PRSE132=$S(IOM'<132:1,1:0)
14 F DA=0:0 S DA=$O(^PRSE(452.8,DA)) Q:DA'>0 I $P($G(^PRSE(452.8,DA,0)),U,21)'=""!(DUZ(0)="@") D SORT
15 S X=$O(^TMP("PRSE",$J,0)) I X="" D NHDR W !,"THERE IS NO DATA FOR THIS REPORT" G QUIT
16 D NPRINT
17QUIT ;
18Q K ^TMP("PRSE",$J) D CLOSE^PRSEUTL,^PRSEKILL
19 Q
20NPRINT ;
21NO S PRSESP1="" F I=0:0 S PRSESP1=$O(^TMP("PRSE",$J,"L",PRSESP1)) Q:PRSESP1="" D NP Q:NQT
22 Q
23NP S PRSESP2="" F S PRSESP2=$O(^TMP("PRSE",$J,"L",PRSESP1,PRSESP2)) Q:PRSESP2="" S NSORT=$G(^TMP("PRSE",$J,"L",PRSESP1,PRSESP2)) D:NSORT NP1 Q:NQT
24 Q
25NP1 S PRSETYP="" F S PRSETYP=$O(^TMP("PRSE",$J,"L1",NSORT,PRSETYP)) Q:PRSETYP="" D NQ Q:NQT
26 Q
27NQ S PRSELNG=0 F S PRSELNG=$O(^TMP("PRSE",$J,"L1",NSORT,PRSETYP,PRSELNG)) Q:PRSELNG'>0 D NR Q:NQT
28 Q
29NR S PRSELOC="" F S PRSELOC=$O(^TMP("PRSE",$J,"L1",NSORT,PRSETYP,PRSELNG,PRSELOC)) Q:PRSELOC="" D NS Q:NQT
30 Q
31NS S PRSESVC="" F S PRSESVC=$O(^TMP("PRSE",$J,"L1",NSORT,PRSETYP,PRSELNG,PRSELOC,PRSESVC)) Q:PRSESVC="" D NPPRINT Q:NQT
32 Q
33NPPRINT I ($Y>(IOSL-9)!('NSW1)) D NHDR Q:NQT
34 S Y=$S(PRSESEL="D":PRSESP1,PRSESEL="C":PRSESP2,1:0)
35 S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_$S((+$P(Y,".",2)>0):"@"_$P(Y,".",2),1:"") I +$P(Y,"@",2)>0 S $P(Y,"@",2)=$S($P(Y,"@",2)?2N:$P(Y,"@",2)_"00",$P(Y,"@",2)?1N:$P(Y,"@",2)_"0",$P(Y,"@",2)?3N:$P(Y,"@",2)_"0",1:$P(Y,"@",2))
36 I PRSE132 D
37 . I PRSESEL="D" W:Y'="" !,Y W:'(PRSESP2=" BLANK") ?19,$E(PRSESP2,1,36)
38 . I PRSESEL="C" W:PRSESP2'=" BLANK" !,$E(PRSESP1,1,36) W:'(Y="") ?40,Y
39 . W:PRSELNG'=" BLANK" ?58,PRSELNG
40 . W:PRSETYP'=" BLANK" ?68,PRSETYP
41 . W:PRSELOC'=" BLANK" ?73,$E(PRSELOC,1,25)
42 . W:PRSESVC'=" BLANK" ?101,PRSESVC
43 . Q
44 E D
45 . I PRSESEL="D" W:Y'="" !,Y W:'(PRSESP2=" BLANK") ?14,$E(PRSESP2,1,19)
46 . I PRSESEL="C" W:PRSESP2'=" BLANK" !,$E(PRSESP1,1,19) W:'(Y="") ?24,Y
47 . W:PRSETYP'="" ?38,PRSETYP
48 . W:PRSELNG'=" BLANK" ?42,PRSELNG
49 . W:PRSELOC'=" BLANK" ?48,$E(PRSELOC,1,15)
50 . W:PRSESVC'=" BLANK" ?64,$E(PRSESVC,1,15)
51 . Q
52 Q
53NHDR I 'NOUT I 'NQ,NSW1,$E(IOST)="C" D ENDPG^PRSEUTL S NQT=+POUT Q:NQT
54 S NPC=NPC+1,NSW1=1 W:$E(IOST)="C"!(NPC>1) @IOF S X="T" D ^%DT D:+Y D^DIQ
55 I PRSE132 D
56 . W Y,?52,"CLASS REGISTRATION CALENDAR",?120,"PAGE: ",NPC,!!
57 . W:PRSESEL="D" "START DATE",?19,"CLASS TITLE"
58 . W:PRSESEL="C" "CLASS TITLE",?40,"START DATE"
59 . W ?58,"LENGTH",?66,"TYPE",?73,"LOCATION",?101,"SERVICE",!
60 . Q
61 E D
62 . W Y,?26,"CLASS REGISTRATION CALENDAR",?68,"PAGE: ",NPC,!!
63 . W:PRSESEL="D" "START DATE",?14,"CLASS TITLE",?35,"TYPE"
64 . W:PRSESEL="C" "CLASS TITLE",?22,"START DATE",?35,"TYPE"
65 . W ?40,"LENGTH",?48,"LOCATION",?64,"SERVICE",!
66 . Q
67 S NI="",$P(NI,"-",$S(PRSE132:133,1:81))="" W NI,!
68 Q
69L F X="PRSECLS","PRSESEL","PRSESER","NSW2","NOUT","NQ","NQT","NSW1","PSPC","NPC","PSP" S ZTSAVE(X)=""
70 Q
71SORT ; SORT SERVICE DATA
72 W:$E(IOST,1,2)="C-"&('$R(100)) "."
73 S N0=$P($G(^PRSE(452.8,+DA,0)),U),DATA=$G(^PRSE(452.1,+N0,0))
74 ;I $P(DATA,U,8)'=PRSESER&$P(DATA,U,9)!($G(DATA)="") Q
75 I PRSESEL="C" S PRSESP1=$S($D(^PRSE(452.1,+N0,0)):$P($G(^(0)),U),1:" BLANK")
76 I PRSESEL="D" S PRSESP2=$S($D(^PRSE(452.1,+N0,0)):$P($G(^(0)),U),1:" BLANK")
77 S PRSELNG=$S('($P($G(^PRSE(452.8,DA,0)),U,18)=""):$P(^(0),U,18),1:" BLANK"),PRSETYP=$S('($P($G(^(0)),U,5)=""):$P(^(0),U,5),1:" BLANK")
78 S N1=$P($G(^PRSE(452.8,DA,0)),U,21),PRSESVC=$S($D(^PRSP(454.1,+N1,0)):$P($G(^(0)),U),1:" BLANK")
79 I '$G(PSP),PRSESVC'=PSPC,$P($G(DATA),U,9) Q
80 F D1=0:0 S D1=$O(^PRSE(452.8,DA,3,D1)) Q:D1'>0 D SET
81 Q
82SET ;
83 S:TYP="S"!(YRST<DT) YRST=DT I +(^PRSE(452.8,DA,3,D1,0)<YRST)!(+^PRSE(452.8,DA,3,D1,0)>YREND) Q
84 I $D(^PRSE(452.8,DA,3,D1,0)),PRSESEL="D" S PRSESP1=$S((+^(0)>0):+^(0),1:0)
85 I $D(^PRSE(452.8,DA,3,D1,0)),PRSESEL="C" S PRSESP2=$S((+^(0)>0):+^(0),1:0)
86 S PRSELOC=$S('($P(^PRSE(452.8,DA,3,D1,0),U,2)=""):$P(^(0),U,2),1:" BLANK") D SAVE
87 Q
88SAVE S:PRSESP1="" PRSESP1=" " S:PRSESP2="" PRSESP2=" "
89 S:$G(NSORT)="" NSORT=1
90 N X S X=$G(^TMP("PRSE",$J,"L",PRSESP1,PRSESP2))
91 I X="" S X=NSORT,NSORT=NSORT+1,^TMP("PRSE",$J,"L",PRSESP1,PRSESP2)=X
92 S ^TMP("PRSE",$J,"L1",X,PRSETYP,PRSELNG,PRSELOC,PRSESVC)=""
93 Q
Note: See TracBrowser for help on using the repository browser.