Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCB1A3

PRCB1A3.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 6402, this routine should not be modified.
  1. Q ;invalid entry
  1. ;
  1. ;PRC*5.1*188 Removed exception check for FUND=0160, CC=824300
  1. ;
  1. EN1 ; entry point for CONTROL POINT LISTING W/COST CENTERS
  1. N L,DIC,FLDS,BY,DHD
  1. S L=0,DIC="^PRC(420,",FLDS="[PRCB CTRLPT]",BY=".01,1,1"
  1. ;S DIS(0)="I $P(^PRC(420,D0,1,D1,0),""^"",19)'=1"
  1. S DHD="CONTROL POINT LISTING W/ COST CENTERS PRINTED BY: "_$$USER^PRCPUREP(DUZ)
  1. D EN1^DIP
  1. Q
  1. ;
  1. EN2 ; entry point for CONTROL POINT LISTING W/COST CENTER EXCEPTIONS
  1. N STN,CP,CC,ACC,ACT,FUND,CPNAME,I,PAGE,LNCT,TODAY,EXC,CNT,RECORD
  1. N CP1,CP2,FUND1,L,LN,LN1,SCREEN,DEV,ABORT,FLG,STN1,%ZIS,ZTDESC
  1. N ZTRTN,ZTSAVE,X,Y,PAGE1
  1. D NOW^%DTC S Y=% D DD^%DT S TODAY=Y KILL ^XTMP($J)
  1. S (STN,CP,CC,ACC,ACT,FUND)=0,DEV=$J
  1. F S STN=$O(^PRC(420,STN)) Q:'STN D
  1. . S CP=0 F S CP=$O(^PRC(420,STN,1,CP)) Q:'CP!(CP=9999) D
  1. . . S RECORD=$G(^PRC(420,STN,1,CP,0)) I RECORD="" Q
  1. . . S FUND=$P(RECORD,"^",2) I 'FUND Q
  1. . . S FUND=$P($G(^PRCD(420.3,FUND,0)),"^")
  1. . . I (".0160.0162.0152.")'[("."_$E(FUND,1,4)_".") Q
  1. . . S CPNAME=$P(RECORD,"^") ; format, nnn(n) xxxxx xxxx
  1. . . S ACT=$P(RECORD,"^",19) ; 1=inactive
  1. . . S ACC=$P($G(^PRC(420,STN,1,CP,5)),"^",3) ; pointer to ^PRCD(420.131,
  1. . . S:'ACC ACC="NONE" D
  1. . . . S:ACC'="NONE" ACC=$P($G(^PRCD(420.131,ACC,0)),"^")
  1. . . . Q
  1. . . S (CC,I)=0 F S CC=$O(^PRC(420,STN,1,CP,2,CC)) Q:'CC D
  1. . . . D PROCESS
  1. . . . I 'EXC Q
  1. . . . S I=$G(I)+1
  1. . . . S ^XTMP($J,"PRCCPE",STN,FUND,CP,I)=ACT_"^"_CPNAME_"^"_CC_"^"_ACC
  1. . . . Q
  1. . . Q
  1. . Q
  1. ;
  1. S %ZIS="Q"
  1. D ^%ZIS Q:POP
  1. I $D(IO("Q")) D Q
  1. . S ZTRTN="QUEUE^PRCB1A3"
  1. . S ZTDESC="CONTROL POINT LISTING W/EXCEPTIONS"
  1. . S ZTSAVE("TODAY")=""
  1. . S ZTSAVE("DUZ")=""
  1. . S ZTSAVE("DEV")=""
  1. . D ^%ZTLOAD
  1. . D HOME^%ZIS
  1. . KILL ZTST,IO("Q")
  1. ;
  1. QUEUE U IO
  1. S (ABORT,PAGE,PAGE1,SCREEN)=0,LN1=45
  1. I $E(IOST,1,2)="C-" S SCREEN=1
  1. I SCREEN S LN1=17
  1. D HDR
  1. I SCREEN,IOSL>24 S PAGE1=1
  1. ;
  1. S (STN,STN1,CP,CC,ACC,ACT,FUND,FLG)=0
  1. S (CP1,CP2,FUND1)=""
  1. F S STN=$O(^XTMP(DEV,"PRCCPE",STN)) Q:'STN Q:ABORT D
  1. . S FUND=0
  1. . F S FUND=$O(^XTMP(DEV,"PRCCPE",STN,FUND)) Q:'FUND Q:ABORT D
  1. . . S CP=0
  1. . . F S CP=$O(^XTMP(DEV,"PRCCPE",STN,FUND,CP)) Q:'CP Q:ABORT D
  1. . . . S CNT=0
  1. . . . F S CNT=$O(^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT)) Q:'CNT Q:ABORT D
  1. . . . . S RECORD=^XTMP(DEV,"PRCCPE",STN,FUND,CP,CNT)
  1. . . . . S STATUS=$P(RECORD,U)
  1. . . . . I STATUS=0 S STATUS="(ACTIVE)"
  1. . . . . I STATUS=1 S STATUS="(INACTIVE)"
  1. . . . . S CP1=$E($P(RECORD,U,2),1,20)
  1. . . . . S CC=$P(RECORD,U,3)
  1. . . . . S CC=$G(^PRCD(420.1,CC,0))
  1. . . . . S CC=$E($P(CC,U),1,45)
  1. . . . . S ACC=$P(RECORD,U,4)
  1. . . . . I STN'=STN1 S FUND1=FUND W !!,STN,?6,FUND S LN=LN+1
  1. . . . . I FUND'=FUND1 S CP2=CP1 W !!,?7,FUND,!,?9,CP1," ",STATUS S LN=LN+1
  1. . . . . I CP1'=CP2 W !!,?9,CP1," ",STATUS S LN=LN+1
  1. . . . . W !,?13,CC,?60,ACC S LN=LN+1
  1. . . . . I STN'=STN1 S STN1=STN
  1. . . . . I FUND'=FUND1 S FUND1=FUND
  1. . . . . I CP1'=CP2 S CP2=CP1
  1. . . . . I LN>LN1 D HDR:'PAGE1 Q:ABORT
  1. ;
  1. I 'ABORT W !!,"<End of Report>" R:SCREEN X:100
  1. D ^%ZISC
  1. Q
  1. ;
  1. ;--------------------------------------------------------------------
  1. PROCESS ; determine if exception exists
  1. S EXC=0
  1. ;
  1. I $E(FUND,1,4)="0160" D
  1. . I CC<820100 S EXC=1
  1. . I CC>836400,CC<860100 S EXC=1
  1. . I CC>860300,CC<875000 S EXC=1
  1. . I CC>875200,CC<895900 S EXC=1
  1. . I CC>895900,CC<899100 S EXC=1
  1. . I CC>899600 S EXC=1
  1. . Q
  1. ;
  1. I $E(FUND,1,4)="0152" D
  1. . I CC<800100 S EXC=1
  1. . I CC>808300,CC<840100 S EXC=1
  1. . I CC>847000,CC<860500 S EXC=1
  1. . I CC>861700,CC<864900 S EXC=1
  1. . I CC>866000,CC<895000 S EXC=1
  1. . I CC>895900 S EXC=1
  1. . I CC=863100 S EXC=0
  1. . Q
  1. ;
  1. I $E(FUND,1,4)="0162" D
  1. . I CC<850100 S EXC=1
  1. . I CC>857500,CC<860400 S EXC=1
  1. . I CC>860400,CC<862100 S EXC=1
  1. . I CC>862300 S EXC=1
  1. . I CC=824300 S EXC=0
  1. . Q
  1. ;
  1. Q
  1. ;
  1. ;--------------------------------------------------------------
  1. HDR ;PRINT THE HEADER
  1. I SCREEN,PAGE R !!,"Hit <RETURN> to continue, '^' to Exit ",X:100
  1. ;
  1. I SCREEN,X["^" S ABORT=1 Q
  1. ;
  1. S PAGE=$G(PAGE)+1
  1. W #
  1. W "CONTROL POINT LISTING W/EXCEPTIONS "
  1. W "PRINTED BY: "_$$USER^PRCPUREP(DUZ)
  1. W !," "_TODAY
  1. W " PAGE ",PAGE
  1. W !!,"STA# FUND"
  1. W !," CONTROL POINT ACC"
  1. W !," COST CENTER"
  1. W ! F L=1:1:80 W "-"
  1. S LN=8
  1. Q