PRCB1A3 ;WIOFO/DWA - CONTROL POINT LISTING W/COST CENTERS ;3/3/04 03:04 AM
;;5.1;IFCAP;**76,74,188**;Oct 20, 2000;Build 1
;Per VHA Directive 6402, this routine should not be modified.
Q ;invalid entry
;
;PRC*5.1*188 Removed exception check for FUND=0160, CC=824300
;
EN1 ; entry point for CONTROL POINT LISTING W/COST CENTERS
N L,DIC,FLDS,BY,DHD
S L=0,DIC="^PRC(420,",FLDS="[PRCB CTRLPT]",BY=".01,1,1"
;S DIS(0)="I $P(^PRC(420,D0,1,D1,0),""^"",19)'=1"
S DHD="CONTROL POINT LISTING W/ COST CENTERS PRINTED BY: "_$$USER^PRCPUREP(DUZ)
D EN1^DIP
Q
;
EN2 ; entry point for CONTROL POINT LISTING W/COST CENTER EXCEPTIONS
N STN,CP,CC,ACC,ACT,FUND,CPNAME,I,PAGE,LNCT,TODAY,EXC,CNT,RECORD
N CP1,CP2,FUND1,L,LN,LN1,SCREEN,DEV,ABORT,FLG,STN1,%ZIS,ZTDESC
N ZTRTN,ZTSAVE,X,Y,PAGE1
D NOW^%DTC S Y=% D DD^%DT S TODAY=Y KILL ^XTMP($J)
S (STN,CP,CC,ACC,ACT,FUND)=0,DEV=$J
F S STN=$O(^PRC(420,STN)) Q:'STN D
. S CP=0 F S CP=$O(^PRC(420,STN,1,CP)) Q:'CP!(CP=9999) D
. . S RECORD=$G(^PRC(420,STN,1,CP,0)) I RECORD="" Q
. . S FUND=$P(RECORD,"^",2) I 'FUND Q
. . S FUND=$P($G(^PRCD(420.3,FUND,0)),"^")
. . I (".0160.0162.0152.")'[("."_$E(FUND,1,4)_".") Q
. . S CPNAME=$P(RECORD,"^") ; format, nnn(n) xxxxx xxxx
. . S ACT=$P(RECORD,"^",19) ; 1=inactive
. . S ACC=$P($G(^PRC(420,STN,1,CP,5)),"^",3) ; pointer to ^PRCD(420.131,
. . S:'ACC ACC="NONE" D
. . . S:ACC'="NONE" ACC=$P($G(^PRCD(420.131,ACC,0)),"^")
. . . Q
. . S (CC,I)=0 F S CC=$O(^PRC(420,STN,1,CP,2,CC)) Q:'CC D
. . . D PROCESS
. . . I 'EXC Q
. . . S I=$G(I)+1
. . . S ^XTMP($J,"PRCCPE",STN,FUND,CP,I)=ACT_"^"_CPNAME_"^"_CC_"^"_ACC
. . . Q
. . Q
. Q
;
S %ZIS="Q"
D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="QUEUE^PRCB1A3"
. S ZTDESC="CONTROL POINT LISTING W/EXCEPTIONS"
. S ZTSAVE("TODAY")=""
. S ZTSAVE("DUZ")=""
. S ZTSAVE("DEV")=""
. D ^%ZTLOAD
. D HOME^%ZIS
. KILL ZTST,IO("Q")
;
QUEUE U IO
S (ABORT,PAGE,PAGE1,SCREEN)=0,LN1=45
I $E(IOST,1,2)="C-" S SCREEN=1
I SCREEN S LN1=17
D HDR
I SCREEN,IOSL>24 S PAGE1=1
;
S (STN,STN1,CP,CC,ACC,ACT,FUND,FLG)=0
S (CP1,CP2,FUND1)=""
F S STN=$O(^XTMP(DEV,"PRCCPE",STN)) Q:'STN Q:ABORT D
. S FUND=0
. F S FUND=$O(^XTMP(DEV,"PRCCPE",STN,FUND)) Q:'FUND Q:ABORT D
. . S CP=0
. . F S CP=$O(^XTMP(DEV,"PRCCPE",STN,FUND,CP)) Q:'CP Q:ABORT D
. . . S CNT=0
. . . F S CNT=$O(^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT)) Q:'CNT Q:ABORT D
. . . . S RECORD=^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT)
. . . . S STATUS=$P(RECORD,U)
. . . . I STATUS=0 S STATUS="(ACTIVE)"
. . . . I STATUS=1 S STATUS="(INACTIVE)"
. . . . S CP1=$E($P(RECORD,U,2),1,20)
. . . . S CC=$P(RECORD,U,3)
. . . . S CC=$G(^PRCD(420.1,CC,0))
. . . . S CC=$E($P(CC,U),1,45)
. . . . S ACC=$P(RECORD,U,4)
. . . . I STN'=STN1 S FUND1=FUND W !!,STN,?6,FUND S LN=LN+1
. . . . I FUND'=FUND1 S CP2=CP1 W !!,?7,FUND,!,?9,CP1," ",STATUS S LN=LN+1
. . . . I CP1'=CP2 W !!,?9,CP1," ",STATUS S LN=LN+1
. . . . W !,?13,CC,?60,ACC S LN=LN+1
. . . . I STN'=STN1 S STN1=STN
. . . . I FUND'=FUND1 S FUND1=FUND
. . . . I CP1'=CP2 S CP2=CP1
. . . . I LN>LN1 D HDR:'PAGE1 Q:ABORT
;
I 'ABORT W !!,"<End of Report>" R:SCREEN X:100
D ^%ZISC
Q
;
;--------------------------------------------------------------------
PROCESS ; determine if exception exists
S EXC=0
;
I $E(FUND,1,4)="0160" D
. I CC<820100 S EXC=1
. I CC>836400,CC<860100 S EXC=1
. I CC>860300,CC<875000 S EXC=1
. I CC>875200,CC<895900 S EXC=1
. I CC>895900,CC<899100 S EXC=1
. I CC>899600 S EXC=1
. Q
;
I $E(FUND,1,4)="0152" D
. I CC<800100 S EXC=1
. I CC>808300,CC<840100 S EXC=1
. I CC>847000,CC<860500 S EXC=1
. I CC>861700,CC<864900 S EXC=1
. I CC>866000,CC<895000 S EXC=1
. I CC>895900 S EXC=1
. I CC=863100 S EXC=0
. Q
;
I $E(FUND,1,4)="0162" D
. I CC<850100 S EXC=1
. I CC>857500,CC<860400 S EXC=1
. I CC>860400,CC<862100 S EXC=1
. I CC>862300 S EXC=1
. I CC=824300 S EXC=0
. Q
;
Q
;
;--------------------------------------------------------------
HDR ;PRINT THE HEADER
I SCREEN,PAGE R !!,"Hit <RETURN> to continue, '^' to Exit ",X:100
;
I SCREEN,X["^" S ABORT=1 Q
;
S PAGE=$G(PAGE)+1
W #
W "CONTROL POINT LISTING W/EXCEPTIONS "
W "PRINTED BY: "_$$USER^PRCPUREP(DUZ)
W !," "_TODAY
W " PAGE ",PAGE
W !!,"STA# FUND"
W !," CONTROL POINT ACC"
W !," COST CENTER"
W ! F L=1:1:80 W "-"
S LN=8
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1A3 4610 printed Oct 16, 2024@18:00:59 Page 2
PRCB1A3 ;WIOFO/DWA - CONTROL POINT LISTING W/COST CENTERS ;3/3/04 03:04 AM
+1 ;;5.1;IFCAP;**76,74,188**;Oct 20, 2000;Build 1
+2 ;Per VHA Directive 6402, this routine should not be modified.
+3 ;invalid entry
QUIT
+4 ;
+5 ;PRC*5.1*188 Removed exception check for FUND=0160, CC=824300
+6 ;
EN1 ; entry point for CONTROL POINT LISTING W/COST CENTERS
+1 NEW L,DIC,FLDS,BY,DHD
+2 SET L=0
SET DIC="^PRC(420,"
SET FLDS="[PRCB CTRLPT]"
SET BY=".01,1,1"
+3 ;S DIS(0)="I $P(^PRC(420,D0,1,D1,0),""^"",19)'=1"
+4 SET DHD="CONTROL POINT LISTING W/ COST CENTERS PRINTED BY: "_$$USER^PRCPUREP(DUZ)
+5 DO EN1^DIP
+6 QUIT
+7 ;
EN2 ; entry point for CONTROL POINT LISTING W/COST CENTER EXCEPTIONS
+1 NEW STN,CP,CC,ACC,ACT,FUND,CPNAME,I,PAGE,LNCT,TODAY,EXC,CNT,RECORD
+2 NEW CP1,CP2,FUND1,L,LN,LN1,SCREEN,DEV,ABORT,FLG,STN1,%ZIS,ZTDESC
+3 NEW ZTRTN,ZTSAVE,X,Y,PAGE1
+4 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TODAY=Y
KILL ^XTMP($JOB)
+5 SET (STN,CP,CC,ACC,ACT,FUND)=0
SET DEV=$JOB
+6 FOR
SET STN=$ORDER(^PRC(420,STN))
if 'STN
QUIT
Begin DoDot:1
+7 SET CP=0
FOR
SET CP=$ORDER(^PRC(420,STN,1,CP))
if 'CP!(CP=9999)
QUIT
Begin DoDot:2
+8 SET RECORD=$GET(^PRC(420,STN,1,CP,0))
IF RECORD=""
QUIT
+9 SET FUND=$PIECE(RECORD,"^",2)
IF 'FUND
QUIT
+10 SET FUND=$PIECE($GET(^PRCD(420.3,FUND,0)),"^")
+11 IF (".0160.0162.0152.")'[("."_$EXTRACT(FUND,1,4)_".")
QUIT
+12 ; format, nnn(n) xxxxx xxxx
SET CPNAME=$PIECE(RECORD,"^")
+13 ; 1=inactive
SET ACT=$PIECE(RECORD,"^",19)
+14 ; pointer to ^PRCD(420.131,
SET ACC=$PIECE($GET(^PRC(420,STN,1,CP,5)),"^",3)
+15 if 'ACC
SET ACC="NONE"
Begin DoDot:3
+16 if ACC'="NONE"
SET ACC=$PIECE($GET(^PRCD(420.131,ACC,0)),"^")
+17 QUIT
End DoDot:3
+18 SET (CC,I)=0
FOR
SET CC=$ORDER(^PRC(420,STN,1,CP,2,CC))
if 'CC
QUIT
Begin DoDot:3
+19 DO PROCESS
+20 IF 'EXC
QUIT
+21 SET I=$GET(I)+1
+22 SET ^XTMP($JOB,"PRCCPE",STN,FUND,CP,I)=ACT_"^"_CPNAME_"^"_CC_"^"_ACC
+23 QUIT
End DoDot:3
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 ;
+27 SET %ZIS="Q"
+28 DO ^%ZIS
if POP
QUIT
+29 IF $DATA(IO("Q"))
Begin DoDot:1
+30 SET ZTRTN="QUEUE^PRCB1A3"
+31 SET ZTDESC="CONTROL POINT LISTING W/EXCEPTIONS"
+32 SET ZTSAVE("TODAY")=""
+33 SET ZTSAVE("DUZ")=""
+34 SET ZTSAVE("DEV")=""
+35 DO ^%ZTLOAD
+36 DO HOME^%ZIS
+37 KILL ZTST,IO("Q")
End DoDot:1
QUIT
+38 ;
QUEUE USE IO
+1 SET (ABORT,PAGE,PAGE1,SCREEN)=0
SET LN1=45
+2 IF $EXTRACT(IOST,1,2)="C-"
SET SCREEN=1
+3 IF SCREEN
SET LN1=17
+4 DO HDR
+5 IF SCREEN
IF IOSL>24
SET PAGE1=1
+6 ;
+7 SET (STN,STN1,CP,CC,ACC,ACT,FUND,FLG)=0
+8 SET (CP1,CP2,FUND1)=""
+9 FOR
SET STN=$ORDER(^XTMP(DEV,"PRCCPE",STN))
if 'STN
QUIT
if ABORT
QUIT
Begin DoDot:1
+10 SET FUND=0
+11 FOR
SET FUND=$ORDER(^XTMP(DEV,"PRCCPE",STN,FUND))
if 'FUND
QUIT
if ABORT
QUIT
Begin DoDot:2
+12 SET CP=0
+13 FOR
SET CP=$ORDER(^XTMP(DEV,"PRCCPE",STN,FUND,CP))
if 'CP
QUIT
if ABORT
QUIT
Begin DoDot:3
+14 SET CNT=0
+15 FOR
SET CNT=$ORDER(^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT))
if 'CNT
QUIT
if ABORT
QUIT
Begin DoDot:4
+16 SET RECORD=^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT)
+17 SET STATUS=$PIECE(RECORD,U)
+18 IF STATUS=0
SET STATUS="(ACTIVE)"
+19 IF STATUS=1
SET STATUS="(INACTIVE)"
+20 SET CP1=$EXTRACT($PIECE(RECORD,U,2),1,20)
+21 SET CC=$PIECE(RECORD,U,3)
+22 SET CC=$GET(^PRCD(420.1,CC,0))
+23 SET CC=$EXTRACT($PIECE(CC,U),1,45)
+24 SET ACC=$PIECE(RECORD,U,4)
+25 IF STN'=STN1
SET FUND1=FUND
WRITE !!,STN,?6,FUND
SET LN=LN+1
+26 IF FUND'=FUND1
SET CP2=CP1
WRITE !!,?7,FUND,!,?9,CP1," ",STATUS
SET LN=LN+1
+27 IF CP1'=CP2
WRITE !!,?9,CP1," ",STATUS
SET LN=LN+1
+28 WRITE !,?13,CC,?60,ACC
SET LN=LN+1
+29 IF STN'=STN1
SET STN1=STN
+30 IF FUND'=FUND1
SET FUND1=FUND
+31 IF CP1'=CP2
SET CP2=CP1
+32 IF LN>LN1
if 'PAGE1
DO HDR
if ABORT
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 IF 'ABORT
WRITE !!,"<End of Report>"
if SCREEN
READ X:100
+35 DO ^%ZISC
+36 QUIT
+37 ;
+38 ;--------------------------------------------------------------------
PROCESS ; determine if exception exists
+1 SET EXC=0
+2 ;
+3 IF $EXTRACT(FUND,1,4)="0160"
Begin DoDot:1
+4 IF CC<820100
SET EXC=1
+5 IF CC>836400
IF CC<860100
SET EXC=1
+6 IF CC>860300
IF CC<875000
SET EXC=1
+7 IF CC>875200
IF CC<895900
SET EXC=1
+8 IF CC>895900
IF CC<899100
SET EXC=1
+9 IF CC>899600
SET EXC=1
+10 QUIT
End DoDot:1
+11 ;
+12 IF $EXTRACT(FUND,1,4)="0152"
Begin DoDot:1
+13 IF CC<800100
SET EXC=1
+14 IF CC>808300
IF CC<840100
SET EXC=1
+15 IF CC>847000
IF CC<860500
SET EXC=1
+16 IF CC>861700
IF CC<864900
SET EXC=1
+17 IF CC>866000
IF CC<895000
SET EXC=1
+18 IF CC>895900
SET EXC=1
+19 IF CC=863100
SET EXC=0
+20 QUIT
End DoDot:1
+21 ;
+22 IF $EXTRACT(FUND,1,4)="0162"
Begin DoDot:1
+23 IF CC<850100
SET EXC=1
+24 IF CC>857500
IF CC<860400
SET EXC=1
+25 IF CC>860400
IF CC<862100
SET EXC=1
+26 IF CC>862300
SET EXC=1
+27 IF CC=824300
SET EXC=0
+28 QUIT
End DoDot:1
+29 ;
+30 QUIT
+31 ;
+32 ;--------------------------------------------------------------
HDR ;PRINT THE HEADER
+1 IF SCREEN
IF PAGE
READ !!,"Hit <RETURN> to continue, '^' to Exit ",X:100
+2 ;
+3 IF SCREEN
IF X["^"
SET ABORT=1
QUIT
+4 ;
+5 SET PAGE=$GET(PAGE)+1
+6 WRITE #
+7 WRITE "CONTROL POINT LISTING W/EXCEPTIONS "
+8 WRITE "PRINTED BY: "_$$USER^PRCPUREP(DUZ)
+9 WRITE !," "_TODAY
+10 WRITE " PAGE ",PAGE
+11 WRITE !!,"STA# FUND"
+12 WRITE !," CONTROL POINT ACC"
+13 WRITE !," COST CENTER"
+14 WRITE !
FOR L=1:1:80
WRITE "-"
+15 SET LN=8
+16 QUIT
