PRCFSITE ;WISC/CTB/CLH/DL-RETURNS PRC* VARIABLES ; 1/29/98 1315
V ;;5.1;IFCAP;**139**;Oct 20, 2000;Build 16
;Per VHA Directive 2004-038, this routine should not be modified.
DIVFY ;CHECK FOR STATION AND FY
D DUZ G:'% Q
I $D(PRC("FY")),PRC("FY")'?2N K PRC("FY")
I '$D(DT) D NOW^%DTC S DT=X K %,%H,%I,X
W ! I '$D(^PRC(411,0)) W "SITE PARAMETERS HAVE NOT YET BEEN ESTABLISHED, NO FURTHER PROCESSING CAN OCCUR",$C(7) G Q
S U="^",B=^PRC(411,0) I +$P(B,U,4)<1 W !,"NO ENTRIES FOUND IN SITE PARAMETER FILE",$C(7) G Q
I $D(%F) S PRCF("X")=%F
S %=1 K PRC("SP") I '$D(PRCF("X")) S PRCF("X")="AFS"
S:$G(^VA(200,+PRC("PER"),400))]"" PRC("SP")=1
I $P(B,U,4)>1 S PRC("MDIV")="" S:PRCF("X")["B" PRC("MDIV")=""
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)))
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=""
K PRC("FU") I PRCF("X")["A",'$G(PRC("SP")) D AFU^PRCFSI1 G:$G(PRC("FU")) Q
I '$D(PRC("MDIV")) S PRC("SITE")=$O(^PRC(411,0))
SI 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
I PRCF("X")["A",'$G(PRC("SP")) D AFU1^PRCFSI1 G:$G(PRC("FU")) Q
FY 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
S:'$D(X) X="" I X="" S X=PRC("FY")
E S PRC("FY")=X
QTR G:PRCF("X")'["Q" SE1 W !,"Select FISCAL QUARTER: "_$S($D(PRC("QTR")):PRC("QTR")_"// ",1:"") R X:$S($D(DTIME):DTIME,1:50)
G:'$T!(X["^") Q I $L(X)>1!("1234"'[X) W !,$C(7),"Enter a number between 1 and 4 ONLY." G QTR
I X]"" S PRC("QTR")=X
SE1 S X="" S:$D(PRC("SITE")) PRC("PARAM")=^PRC(411,PRC("SITE"),0)
ISMS I $D(PRCFASYS),$D(PRC("SITE")) S:$$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 PRCFASYS=PRCFASYS_"ISM"
I PRCF("X")["B" S PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY"),PRCB("LAST")=100000-($O(^PRCF(421,"AD",PRCF("SIFY"),0)))
OUT S %=1 K %DT,DIC,PRC("SP"),PRC("MDIV"),PRC("L"),PRC("I"),PRCF("X"),%F,A,B,X,Y Q
FYQ ;RETURNS FY AND QTR GIVEN IN FILEMANAGER DATE IN 'X'
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
Q K PRC,PRCF("X"),PRCB,%DT,DIC,%F,A,B,X,Y S %=0 Q
HELP1 W !,"ENTER LAST TWO DIGITS OF FISCAL YEAR, OR <CR> TO ACCEPT PROMPT" Q
A 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
DUZ K PRCFDEL,PRC("PER") S %=1 I $D(DUZ)#2,+DUZ>0 S PRC("PER")=+DUZ
I '$D(PRC("PER")) S %=0 W !,$C(7),"YOU ARE NOT IN THE 'NEW PERSON' FILE. CONTACT YOUR SITE MANAGER",! Q
K X S X=$S('$D(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
I $P(X,"^",2)="" D A
S $P(PRC("PER"),"^",2,4)=$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_$S($D(^VA(200,+PRC("PER"),.13)):$P(^(.13),"^",2),1:"")
Q
INIT ;PRIMARY INIT POINT FOR PRC OPTIONS
D DUZ Q:'% I $D(DUZ(0)),$D(DT),$D(DTIME),+DT>0,+DTIME>0 Q
D DT^DICRW Q
EX ;EXIT LINE FOR MENUMANAGER
K P
NA S X="<No action taken>" D MSG^PRCFQ S X="" Q
PRIMARY ;INPUT TRANSFORM FOR FILE 411 FIELD 21 "PRIMARY STATION"
N PRCFX,PRCFY,%A,%B,PRCFZ,N S PRCFX=X S PRCFY=$O(^PRC(411,"AC",1,0))
I $S('PRCFY:1,PRCFY=DA:1,1:0) Q
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
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
;CLEAN UP CURRENT ENTRIES
F N=0:0 S N=$O(^PRC(411,"AC","Y",0)) Q:'N K ^(N) S $P(^PRC(411,N,0),"^",2)=""
S X=" <Primary Station Changed>*" D MSG^PRCFQ S X="Y" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFSITE 3993 printed Dec 13, 2024@02:04:25 Page 2
PRCFSITE ;WISC/CTB/CLH/DL-RETURNS PRC* VARIABLES ; 1/29/98 1315
V ;;5.1;IFCAP;**139**;Oct 20, 2000;Build 16
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
DIVFY ;CHECK FOR STATION AND FY
+1 DO DUZ
if '%
GOTO Q
+2 IF $DATA(PRC("FY"))
IF PRC("FY")'?2N
KILL PRC("FY")
+3 IF '$DATA(DT)
DO NOW^%DTC
SET DT=X
KILL %,%H,%I,X
+4 WRITE !
IF '$DATA(^PRC(411,0))
WRITE "SITE PARAMETERS HAVE NOT YET BEEN ESTABLISHED, NO FURTHER PROCESSING CAN OCCUR",$CHAR(7)
GOTO Q
+5 SET U="^"
SET B=^PRC(411,0)
IF +$PIECE(B,U,4)<1
WRITE !,"NO ENTRIES FOUND IN SITE PARAMETER FILE",$CHAR(7)
GOTO Q
+6 IF $DATA(%F)
SET PRCF("X")=%F
+7 SET %=1
KILL PRC("SP")
IF '$DATA(PRCF("X"))
SET PRCF("X")="AFS"
+8 if $GET(^VA(200,+PRC("PER"),400))]""
SET PRC("SP")=1
+9 IF $PIECE(B,U,4)>1
SET PRC("MDIV")=""
if PRCF("X")["B"
SET PRC("MDIV")=""
+10 IF '$DATA(PRC("SITE"))
IF PRCF("X")["S"!(PRCF("X")["B")
SET PRC("SITE")=$SELECT($ORDER(^PRC(411,"AC","Y",0)):$ORDER(^PRC(411,"AC","Y",0)),1:$ORDER(^PRC(411,0)))
+11 IF '$DATA(PRC("FY"))
SET %DT=""
SET X="T"
DO ^%DT
SET A=$EXTRACT(Y,2,3)
SET B=$EXTRACT(Y,4,5)
SET PRC("FY")=$EXTRACT(100+$SELECT(+B>9:A+1,1:A),2,3)
SET PRC("QTR")=$SELECT(B<4:2,B<7:3,B<10:4,1:1)
SET X=""
+12 KILL PRC("FU")
IF PRCF("X")["A"
IF '$GET(PRC("SP"))
DO AFU^PRCFSI1
if $GET(PRC("FU"))
GOTO Q
+13 IF '$DATA(PRC("MDIV"))
SET PRC("SITE")=$ORDER(^PRC(411,0))
SI IF $DATA(PRC("MDIV"))
IF PRCF("X")["S"!(PRCF("X")["B")
WRITE !
SET DIC("A")="Select STATION NUMBER ('^' TO EXIT): "
SET DIC("B")=PRC("SITE")
SET DIC=411
SET DIC(0)="AEQMZ"
SET DIC("S")="I +Y<1000000"
DO ^DIC
KILL DIC
if +Y<0
GOTO Q
SET PRC("SITE")=+Y
+1 IF PRCF("X")["A"
IF '$GET(PRC("SP"))
DO AFU1^PRCFSI1
if $GET(PRC("FU"))
GOTO Q
FY KILL X
IF PRCF("X")["F"!(PRCF("X")["B")
WRITE !,"Select FISCAL YEAR ('^' to EXIT): ",PRC("FY"),"// "
READ X:$SELECT($DATA(DTIME):DTIME,1:60)
if X["^"
GOTO Q
IF (X["?")!(X'?2N&(X'=""))
WRITE $CHAR(7)
DO HELP1
GOTO FY
+1 if '$DATA(X)
SET X=""
IF X=""
SET X=PRC("FY")
+2 IF '$TEST
SET PRC("FY")=X
QTR if PRCF("X")'["Q"
GOTO SE1
WRITE !,"Select FISCAL QUARTER: "_$SELECT($DATA(PRC("QTR")):PRC("QTR")_"// ",1:"")
READ X:$SELECT($DATA(DTIME):DTIME,1:50)
+1 if '$TEST!(X["^")
GOTO Q
IF $LENGTH(X)>1!("1234"'[X)
WRITE !,$CHAR(7),"Enter a number between 1 and 4 ONLY."
GOTO QTR
+2 IF X]""
SET PRC("QTR")=X
SE1 SET X=""
if $DATA(PRC("SITE"))
SET PRC("PARAM")=^PRC(411,PRC("SITE"),0)
ISMS IF $DATA(PRCFASYS)
IF $DATA(PRC("SITE"))
if $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2
SET PRCFASYS=PRCFASYS_"ISM"
+1 IF PRCF("X")["B"
SET PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY")
SET PRCB("LAST")=100000-($ORDER(^PRCF(421,"AD",PRCF("SIFY"),0)))
OUT SET %=1
KILL %DT,DIC,PRC("SP"),PRC("MDIV"),PRC("L"),PRC("I"),PRCF("X"),%F,A,B,X,Y
QUIT
FYQ ;RETURNS FY AND QTR GIVEN IN FILEMANAGER DATE IN 'X'
+1 if '$DATA(X)
GOTO Q
if X=""!($EXTRACT(X,1,7)'?7N)!(+$EXTRACT(X,1,7)'=$EXTRACT(X,1,7))
GOTO Q
SET Y=$EXTRACT(X,2,3)
SET Y(1)=$EXTRACT(X,4,5)
SET PRC("FY")=$EXTRACT(100+$SELECT(+Y(1)>9:Y+1,1:Y),2,3)
SET PRC("QTR")=$SELECT(Y(1)<4:2,Y(1)<7:3,Y(1)<10:4,1:1)
KILL Y
SET %=1
QUIT
Q KILL PRC,PRCF("X"),PRCB,%DT,DIC,%F,A,B,X,Y
SET %=0
QUIT
HELP1 WRITE !,"ENTER LAST TWO DIGITS OF FISCAL YEAR, OR <CR> TO ACCEPT PROMPT"
QUIT
A SET %X=$PIECE(^VA(200,+PRC("PER"),0),"^")
SET %X=$PIECE(%X,",",2)_" "_$PIECE(%X,",")_$PIECE(%X,",",3)
SET $PIECE(^VA(200,+PRC("PER"),20),"^",2)=%X
SET X=%X
KILL %X
QUIT
DUZ KILL PRCFDEL,PRC("PER")
SET %=1
IF $DATA(DUZ)#2
IF +DUZ>0
SET PRC("PER")=+DUZ
+1 IF '$DATA(PRC("PER"))
SET %=0
WRITE !,$CHAR(7),"YOU ARE NOT IN THE 'NEW PERSON' FILE. CONTACT YOUR SITE MANAGER",!
QUIT
+2 KILL X
SET X=$SELECT('$DATA(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
+3 IF $PIECE(X,"^",2)=""
DO A
+4 SET $PIECE(PRC("PER"),"^",2,4)=$PIECE(X,"^",2)_"^"_$PIECE(X,"^",3)_"^"_$SELECT($DATA(^VA(200,+PRC("PER"),.13)):$PIECE(^(.13),"^",2),1:"")
+5 QUIT
INIT ;PRIMARY INIT POINT FOR PRC OPTIONS
+1 DO DUZ
if '%
QUIT
IF $DATA(DUZ(0))
IF $DATA(DT)
IF $DATA(DTIME)
IF +DT>0
IF +DTIME>0
QUIT
+2 DO DT^DICRW
QUIT
EX ;EXIT LINE FOR MENUMANAGER
+1 KILL P
NA SET X="<No action taken>"
DO MSG^PRCFQ
SET X=""
QUIT
PRIMARY ;INPUT TRANSFORM FOR FILE 411 FIELD 21 "PRIMARY STATION"
+1 NEW PRCFX,PRCFY,%A,%B,PRCFZ,N
SET PRCFX=X
SET PRCFY=$ORDER(^PRC(411,"AC",1,0))
+2 IF $SELECT('PRCFY:1,PRCFY=DA:1,1:0)
QUIT
+3 SET PRCFZ=$PIECE(^PRC(411,PRCFY,0),"^",9)
SET %A="Station number "_PRCFZ_" has already been designated as 'PRIMARY'"
SET %A(1)="OK to REPLACE"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
DO NA
QUIT
+4 SET %A="Are you sure you want to make STATION "_$PIECE(^PRC(411,DA,0),"^",9)_" as 'PRIMARY'"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
DO NA
QUIT
+5 ;CLEAN UP CURRENT ENTRIES
+6 FOR N=0:0
SET N=$ORDER(^PRC(411,"AC","Y",0))
if 'N
QUIT
KILL ^(N)
SET $PIECE(^PRC(411,N,0),"^",2)=""
+7 SET X=" <Primary Station Changed>*"
DO MSG^PRCFQ
SET X="Y"
QUIT
