source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFSITE.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1PRCFSITE ;WISC/CTB/CLH/DL-RETURNS PRC* VARIABLES ; 1/29/98 1315
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4DIVFY ;CHECK FOR STATION AND FY
5 D DUZ G:'% Q
6 I $D(PRC("FY")),PRC("FY")'?2N K PRC("FY")
7 I '$D(DT) D NOW^%DTC S DT=X K %,%H,%I,X
8 W ! I '$D(^PRC(411,0)) W "SITE PARAMETERS HAVE NOT YET BEEN ESTABLISHED, NO FURTHER PROCESSING CAN OCCUR",$C(7) G Q
9 S U="^",B=^PRC(411,0) I +$P(B,U,4)<1 W !,"NO ENTRIES FOUND IN SITE PARAMETER FILE",$C(7) G Q
10 I $D(%F) S PRCF("X")=%F
11 S %=1 K PRC("SP") I '$D(PRCF("X")) S PRCF("X")="AFS"
12 S:$G(^VA(200,+PRC("PER"),400))]"" PRC("SP")=1
13 I $P(B,U,4)>1 S PRC("MDIV")="" S:PRCF("X")["B" PRC("MDIV")=""
14 I '$D(PRC("SITE")),PRCF("X")["S"!(PRCF("X")["B") S PRC("SITE")=$S($O(^PRC(411,"AC","Y",0)):$O(^PRC(411,"AC","Y",0)),1:$O(^PRC(411,0)))
15 I '$D(PRC("FY")) S %DT="",X="T" D ^%DT S A=$E(Y,2,3),B=$E(Y,4,5),PRC("FY")=$E(100+$S(+B>9:A+1,1:A),2,3),PRC("QTR")=$S(B<4:2,B<7:3,B<10:4,1:1) S X=""
16 K PRC("FU") I PRCF("X")["A",'$G(PRC("SP")) D AFU^PRCFSI1 G:$G(PRC("FU")) Q
17 I '$D(PRC("MDIV")) S PRC("SITE")=$O(^PRC(411,0))
18SI I $D(PRC("MDIV")),PRCF("X")["S"!(PRCF("X")["B") W ! S DIC("A")="Select STATION NUMBER ('^' TO EXIT): ",DIC("B")=PRC("SITE"),DIC=411,DIC(0)="AEQMZ",DIC("S")="I +Y<1000000" D ^DIC K DIC G:+Y<0 Q S PRC("SITE")=+Y
19 I PRCF("X")["A",'$G(PRC("SP")) D AFU1^PRCFSI1 G:$G(PRC("FU")) Q
20FY K X I PRCF("X")["F"!(PRCF("X")["B") W !,"Select FISCAL YEAR ('^' to EXIT): ",PRC("FY"),"// " R X:$S($D(DTIME):DTIME,1:60) G:X["^" Q I (X["?")!(X'?2N&(X'="")) W $C(7) D HELP1 G FY
21 S:'$D(X) X="" I X="" S X=PRC("FY")
22 E S PRC("FY")=X
23QTR G:PRCF("X")'["Q" SE1 W !,"Select FISCAL QUARTER: "_$S($D(PRC("QTR")):PRC("QTR")_"// ",1:"") R X:$S($D(DTIME):DTIME,1:50)
24 G:'$T!(X["^") Q I $L(X)>1!("1234"'[X) W !,$C(7),"Enter a number between 1 and 4 ONLY." G QTR
25 I X]"" S PRC("QTR")=X
26SE1 S X="" S:$D(PRC("SITE")) PRC("PARAM")=^PRC(411,PRC("SITE"),0)
27ISMS I $D(PRCFASYS),$D(PRC("SITE")) S:$$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 PRCFASYS=PRCFASYS_"ISM"
28 I PRCF("X")["B" S PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY"),PRCB("LAST")=10000-($O(^PRCF(421,"AD",PRCF("SIFY"),0)))
29OUT S %=1 K %DT,DIC,PRC("SP"),PRC("MDIV"),PRC("L"),PRC("I"),PRCF("X"),%F,A,B,X,Y Q
30FYQ ;RETURNS FY AND QTR GIVEN IN FILEMANAGER DATE IN 'X'
31 G:'$D(X) Q G:X=""!($E(X,1,7)'?7N)!(+$E(X,1,7)'=$E(X,1,7)) Q S Y=$E(X,2,3),Y(1)=$E(X,4,5),PRC("FY")=$E(100+$S(+Y(1)>9:Y+1,1:Y),2,3),PRC("QTR")=$S(Y(1)<4:2,Y(1)<7:3,Y(1)<10:4,1:1) K Y S %=1 Q
32Q K PRC,PRCF("X"),PRCB,%DT,DIC,%F,A,B,X,Y S %=0 Q
33HELP1 W !,"ENTER LAST TWO DIGITS OF FISCAL YEAR, OR <CR> TO ACCEPT PROMPT" Q
34A S %X=$P(^VA(200,+PRC("PER"),0),"^"),%X=$P(%X,",",2)_" "_$P(%X,",")_$P(%X,",",3),$P(^VA(200,+PRC("PER"),20),"^",2)=%X,X=%X K %X Q
35DUZ K PRCFDEL,PRC("PER") S %=1 I $D(DUZ)#2,+DUZ>0 S PRC("PER")=+DUZ
36 I '$D(PRC("PER")) S %=0 W !,$C(7),"YOU ARE NOT IN THE 'NEW PERSON' FILE. CONTACT YOUR SITE MANAGER",! Q
37 K X S X=$S('$D(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
38 I $P(X,"^",2)="" D A
39 S $P(PRC("PER"),"^",2,4)=$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_$S($D(^VA(200,+PRC("PER"),.13)):$P(^(.13),"^",2),1:"")
40 Q
41INIT ;PRIMARY INIT POINT FOR PRC OPTIONS
42 D DUZ Q:'% I $D(DUZ(0)),$D(DT),$D(DTIME),+DT>0,+DTIME>0 Q
43 D DT^DICRW Q
44EX ;EXIT LINE FOR MENUMANAGER
45 K P
46NA S X="<No action taken>" D MSG^PRCFQ S X="" Q
47PRIMARY ;INPUT TRANSFORM FOR FILE 411 FIELD 21 "PRIMARY STATION"
48 N PRCFX,PRCFY,%A,%B,PRCFZ,N S PRCFX=X S PRCFY=$O(^PRC(411,"AC",1,0))
49 I $S('PRCFY:1,PRCFY=DA:1,1:0) Q
50 S PRCFZ=$P(^PRC(411,PRCFY,0),"^",9),%A="Station number "_PRCFZ_" has already been designated as 'PRIMARY'",%A(1)="OK to REPLACE",%B="",%=2 D ^PRCFYN I %'=1 D NA Q
51 S %A="Are you sure you want to make STATION "_$P(^PRC(411,DA,0),"^",9)_" as 'PRIMARY'",%B="",%=2 D ^PRCFYN I %'=1 D NA Q
52 ;CLEAN UP CURRENT ENTRIES
53 F N=0:0 S N=$O(^PRC(411,"AC","Y",0)) Q:'N K ^(N) S $P(^PRC(411,N,0),"^",2)=""
54 S X=" <Primary Station Changed>*" D MSG^PRCFQ S X="Y" Q
Note: See TracBrowser for help on using the repository browser.