source: FOIAVistA/trunk/r/PAID-PRS/PRSEUTL.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 5.1 KB
Line 
1PRSEUTL ;HISC/JH/MD-EMPLOYEE EDUCATION REPORT - UTILITY ;4/24/1998
2 ;;4.0;PAID;**13,25,32,41**;Sep 21, 1995
3INS ; INSERVICE SELECTION
4 S DIR(0)="SO^M:Mandatory Training (MI);C:Continuing Education;O:Other/Miscellaneous;W:Ward/Unit-Location Training;A:All",DIR("A")="Select Sort Parameter"
5 D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) S POUT=1 Q
6 S PRSESEL=Y
7 Q
8INS2 ; INSERVICE SELECTION
9 S DIR(0)="SO^M:Mandatory Training (MI);C:Continuing Education;O:Other/Miscellaneous;W:Ward/Unit-Location Training;A:All;L:All without Mandatory;H:All without Hosptial Wide Mandatory"
10 S DIR("A")="Select Sort Parameter"
11 D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) S POUT=1 Q
12 S PRSESEL=Y
13 Q
14DATSEL ;
15 S DATSEL=U_$G(DATSEL)_U,DIR(0)="SO^C:Calendar Year;F:Fiscal Year;"
16 I DATSEL'["^NS^" S DIR(0)=DIR(0)_"S:Selected Date Range;"
17 S DIR("A")="Select a Sort Parameter"
18 D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) S POUT=1 Q
19 S TYP=Y,YR=$E(DT,1,3)+1700 I TYP="F" S MN=$E(DT,4,5) S:MN>9 YR=(YR+1)
20 S DIR(0)="DA^^K:X'?4N X"
21 S X=YR D ^%DT D:+Y D^DIQ S DIR("B")=Y,DIR("?")="This response must be a year i.e. 1990"
22 I TYP["C" S DIR("A")="Select Calendar Year: " W ! D
23 .D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S POUT=1 Q
24 .S PYR=$G(Y(0)),YR(6)=$E($G(Y),1,3)+1700,%DT="",X=Y D ^%DT S YRST=+Y,%DT="",X="12/31/"_YR(6) D ^%DT S YREND=+Y_".24" K %DT S X1=YRST,X2=-90 D C^%DTC S YRCHK=X
25 I TYP["F" S DIR("A")="Select Fiscal Year: " W ! D
26 .D ^DIR S PYR=$G(Y(0)),YR(6)=$E(Y,1,3)+1700 K DIR I $D(DTOUT)!$D(DUOUT) S POUT=1 Q
27 .S %DT="",X="10/"_(YR(6)-1) D ^%DT S YRST=+Y S %DT="",X="9/30/"_YR(6) D ^%DT S YREND=+Y_".24" K %DT S X1=YRST,X2=-90 D C^%DTC S YRCHK=X
28 I TYP["S" K DIR D
29 .W ! S X=DT D ^%DT D:+Y D^DIQ S DIR("B")=Y,DIR(0)="DA^"_$S($D(PRSECAL):DT,1:"")_"::ET",DIR("A")="Start With DATE: ",DIR("?")="^S %DT(0)=$S($D(PRSECAL):DT,1:-DT) D HELP^%DTC"
30 .I DATSEL["^N+^" S DIR(0)="DA^:"_DT_":ET",DIR("?")="^S %DT(0)=-DT D HELP^%DTC"
31 .D ^DIR K %DT(0),DIR I $D(DTOUT)!$D(DUOUT)!(U[X) S POUT=1 Q
32 .S YRST=+Y,X=DT,%DT="T" D ^%DT D:+Y D^DIQ S YRST(1)=$E(YRST,4,5)_"/"_$E(YRST,6,7)_"/"_$E(YRST,2,3) W ! S DIR("B")=Y,DIR("A")=" Go to DATE: "
33 .S DIR(0)="DA^"_+YRST_"::ET",DIR("?")="^D HELP^%DTC"
34 .I DATSEL["^N+^" S DIR(0)="DA^"_+YRST_":"_DT_":ET",DIR("?")="^S %DT(0)=-DT D HELP^%DTC"
35 .D ^DIR K %DT(0),DIR I $D(DTOUT)!$D(DUOUT)!(U[X) S POUT=1 Q
36 .S X1=YRST,X2=+90 D C^%DTC S YRCHK=X
37 .S YREND=+Y_$S(+Y#1:"",1:".24"),YREND(1)=$E(YREND,4,5)_"/"_$E(YREND,6,7)_"/"_$E(YREND,2,3)
38 K DATSEL,YR Q
39EN2 ; INPUT XFORM: FREQUENCY FIELD IN 452.1
40 S X=$S(X="1M":.08,X="3M":.25,X="6M":.5,X="1Y":1,X="2Y":2,X="3Y":3,X="1T":0,1:"")
41 Q
42EN3 ; OUTPUT XFORM: FREQUENCY FIELD IN 452.1
43 S Y=$S(Y=.08:"1M",Y=.25:"3M",Y=.5:"6M",Y=1:"1Y",Y=2:"2Y",Y=3:"3Y",Y=0:"1T",1:"")
44 Q
45DEV ;
46 S %ZIS="QM" D ^%ZIS K %ZIS K:POP IO("Q") I POP S (POUT,NQT)=1 G Q7
47 I IO'=IO(0),$E(IOST)="P",'$D(IO("Q")),'$D(IO("S")) W !,$C(7),"THIS REPORT MUST BE QUEUED TO A PRINTER",! G DEV
48 I $D(PRSE132),IOM<132 D ^%ZISC W !,$C(7)," ** THIS REPORT MUST BE SENT TO A 132 COLUMN DEVICE **",! K IO("Q"),IO("C") G DEV
49 F X="A*","B*","C*","D*","E*","F*","G*","H*","I*","J*","K*","L*","M*","N*","O*","P*","Q*","R*","S*","T*","U*","V*","W*","X*","Y*","Z*","%H" S ZTSAVE(X)=""
50 S NQ=0 I $D(IO("Q")) K IO("Q"),IO("C") S NQ=1,ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL D ^%ZTLOAD S NQ=0 S:'$D(ZTSK) POP=1
51Q7 K ZTRTN,ZTSAVE
52 Q
53EN3A ; CLASS DATE
54 W ! S X=U,NSP(1)=0,%DT("A")="Start With CLASS DATE (Press return for all dates): ",%DT="AE",X=U D ^%DT K %DT
55 I X="" S NSP(1)=1 Q
56 I Y'>0!(X=U) S POUT=1 Q
57 S NSPC(1)=Y
58 W ! S X=U,NSPC(2)=0,%DT("A")="Go To CLASS DATE (Press return for all dates until present date): ",%DT="AE",X=U D ^%DT K %DT
59 I X="" S X="T" D ^%DT S NSPC(2)=Y Q
60 I Y'>0!(X=U) S POUT=1 Q
61 S NSPC(2)=Y
62 Q
63LAYGO(SER) ; LAYGO NODE IN 452.8 DETERMINE IF
64 ; ENTRY CAN BE ADDED. RETURNS 1 IF IT CAN ADD
65 S:'(+Y>0) SER=2 N DUP S DUP=0 S:'$D(SER)#2 SER=""
66 I SER="" W !,"CANNOT ADD THIS ENTRY, USE OPTIONS PROVIDED BY PACKAGE."
67 E I $D(^PRSE(452.8,"AA",SER,X)) W !,"CANNOT ADD THIS ENTRY AS IT WOULD CREATE A DUPLICATE."
68 E S DUP=1
69 Q DUP
70DICS(FOUND) ; SCREEN 452.1
71 N VA200DA,VA450DA,SSN,PRSX
72 S PRSX=0,PRSX(0)=$G(^PRSE(452.1,+Y,0)),SSN=$P($G(^VA(200,DUZ,1)),U,9),VA200DA=DUZ,VA450DA=$O(^PRSPC("SSN",SSN,0))
73 I $G(REGSW)=1,$$EN2^PRSEUTL2($G(Y)) D
74 .I $S(DUZ(0)["@":0,+$$EN4^PRSEUTL3($G(DUZ)):0,1:1) I $P($G(PRSX(0)),U,7)="M",$G(PRSESLF),'$D(^PRSPC(+VA450DA,6,"B",+Y)) Q
75 .I $S(PRSETYP="A":1,1:$P(PRSX(0),U,7)=PRSETYP),($P(PRSX(0),U,8)=PRSESER!($P(PRSX(0),U,9)=0!(DUZ(0)["@"!(+$$EN4^PRSEUTL3($G(DUZ)))))) S (PRSX,FOUND)=1
76 .Q
77 I 'FOUND,$$LASTDA(+Y) D MSG20^PRSEMSG W ! K PRSEW
78 Q PRSX
79LASTDA(DA) ; DETERMINE IF DATA IS LAST ENTRY IN 452.1
80 N X,Y,LAST S LAST=0
81 S X=$P($G(^PRSE(452.1,DA,0)),U),Y=$O(^PRSE(452.1,"B",X))
82 I Y="" S Y=$O(^PRSE(452.1,"B",X,DA)) I Y="" S LAST=1
83 Q LAST
84DICS1(FOUND) ; SCREEN 4 LOOKUP IN 452.1
85 N PRSX S PRSX=0
86 I '$G(REGSW)=1,$$EN3^PRSEUTL2($G(Y)),$P(^PRSE(452.1,+Y,0),U,7)=PRSETYP,($P(^(0),U,8)=PRSESER!($P(^(0),U,9)=0!(DUZ(0)["@"!(+$$EN4^PRSEUTL3($G(DUZ)))))) S (PRSX,FOUND)=1
87 I 'FOUND,$$LASTDA(+Y) D MSG20^PRSEMSG W ! K PRSEW
88 Q PRSX
89CLOSE ; CLOSE DEVICE
90 I '$G(POUT) D ENDPG^PRSEUTL
91 D ^%ZISC
92 I $D(ZTQUEUED) S ZTREQ="@"
93 Q
94ENDPG ; HANDLE EOP
95 I $E(IOST)'="C" Q
96 K DIR S DIR(0)="E" D ^DIR K DIR S POUT=$S(+Y'>0:1,1:0)
97 Q
Note: See TracBrowser for help on using the repository browser.