PRCBSUT ;WISC@ALTOONA/CTB/SAW-GET STATION INFO ;8/25/00 16:18
V ;;5.1;IFCAP;**97**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;STATION,FY,QUARTER,CONTROL POINT
D ^PRCFSITE G:'% EX D QT G:PRC("QTR")="^" EX D CP G:Y<0 EX
S %=1,Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_C1,X=$P(Z,"-",1,2)_"-"_C1 G EXIT
QT ;SELECT QUARTER
D:'$D(DT) DT^DICRW I '$D(PRCSQTT) S:$D(PRC("QTR")) PRCSQTT=PRC("QTR") I '$D(PRCSQTT) S PRCSI=$E(DT,4,5),PRCSQTT=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",PRCSI)
W !,"Select QUARTER: ",PRCSQTT,"// " R PRC("QTR"):DTIME S:'$T PRC("QTR")=U S:PRC("QTR")=U %=0 S:PRC("QTR")="" PRC("QTR")=PRCSQTT Q:PRC("QTR")="^" I PRC("QTR")<1!(PRC("QTR")>4)!(PRC("QTR")'?1N) W $C(7) G QT
Q
CP ;SELECT CONTROL POINT
S DIC="^PRC(420,"_PRC("SITE")_",1,",DIC(0)="AEMNQZ",DIC("S")="I $D(^(2))",DIC("A")="Select CONTROL POINT: "
I $D(PRCSK) S DIC("S")=$P(DIC("S"),",1",1)_"!($P(^PRC(420,PRC(""SITE""),1,+Y,0),""^"",9)=""Y"")"
S:$D(PRC("CP")) DIC("B")=PRC("CP") S D="B^C"
D MIX^DIC1 K DIC G:Y<0 EXIT I Y>0 S C=$P(Y(0),"^",1),C1=$P(Y(0)," ",1),PRC("CP")=+Y
S C=$P(^PRC(420,PRC("SITE"),1,PRC("CP"),0),"^",1),C1=$P(C," ",1)
K DIC,N Q
EX S Y=-1,%=0 K PRC("QTR"),PRC("FY"),PRCSI I $D(PRC("CP")) K:PRC("CP")="ALL"!(PRC("CP")="^") PRC("CP")
EXIT K PRCSFYT,PRCSI,PRCSK,PRCSQTT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBSUT 1332 printed Dec 13, 2024@02:00:54 Page 2
PRCBSUT ;WISC@ALTOONA/CTB/SAW-GET STATION INFO ;8/25/00 16:18
V ;;5.1;IFCAP;**97**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ;STATION,FY,QUARTER,CONTROL POINT
+1 DO ^PRCFSITE
if '%
GOTO EX
DO QT
if PRC("QTR")="^"
GOTO EX
DO CP
if Y<0
GOTO EX
+2 SET %=1
SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_C1
SET X=$PIECE(Z,"-",1,2)_"-"_C1
GOTO EXIT
QT ;SELECT QUARTER
+1 if '$DATA(DT)
DO DT^DICRW
IF '$DATA(PRCSQTT)
if $DATA(PRC("QTR"))
SET PRCSQTT=PRC("QTR")
IF '$DATA(PRCSQTT)
SET PRCSI=$EXTRACT(DT,4,5)
SET PRCSQTT=$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",PRCSI)
+2 WRITE !,"Select QUARTER: ",PRCSQTT,"// "
READ PRC("QTR"):DTIME
if '$TEST
SET PRC("QTR")=U
if PRC("QTR")=U
SET %=0
if PRC("QTR")=""
SET PRC("QTR")=PRCSQTT
if PRC("QTR")="^"
QUIT
IF PRC("QTR")<1!(PRC("QTR")>4)!(PRC("QTR")'?1N)
WRITE $CHAR(7)
GOTO QT
+3 QUIT
CP ;SELECT CONTROL POINT
+1 SET DIC="^PRC(420,"_PRC("SITE")_",1,"
SET DIC(0)="AEMNQZ"
SET DIC("S")="I $D(^(2))"
SET DIC("A")="Select CONTROL POINT: "
+2 IF $DATA(PRCSK)
SET DIC("S")=$PIECE(DIC("S"),",1",1)_"!($P(^PRC(420,PRC(""SITE""),1,+Y,0),""^"",9)=""Y"")"
+3 if $DATA(PRC("CP"))
SET DIC("B")=PRC("CP")
SET D="B^C"
+4 DO MIX^DIC1
KILL DIC
if Y<0
GOTO EXIT
IF Y>0
SET C=$PIECE(Y(0),"^",1)
SET C1=$PIECE(Y(0)," ",1)
SET PRC("CP")=+Y
+5 SET C=$PIECE(^PRC(420,PRC("SITE"),1,PRC("CP"),0),"^",1)
SET C1=$PIECE(C," ",1)
+6 KILL DIC,N
QUIT
EX SET Y=-1
SET %=0
KILL PRC("QTR"),PRC("FY"),PRCSI
IF $DATA(PRC("CP"))
if PRC("CP")="ALL"!(PRC("CP")="^")
KILL PRC("CP")
EXIT KILL PRCSFYT,PRCSI,PRCSK,PRCSQTT
QUIT
