- 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 Jan 18, 2025@03:01:25 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