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

PRCSUT.m

Go to the documentation of this file.
  1. PRCSUT ;WISC/SAW/DGL - CONTROL POINT ACTIVITY UTILITY PROGRAM ;9/14/00 15:49
  1. V ;;5.1;IFCAP;**93,204**;Oct 20, 2000;Build 14
  1. ;Per VHA Directive 6402, this routine should not be modified.
  1. ;
  1. ENF(PRCIPFLG) ;Entry point for Inv. Pt. selection
  1. EN ;STA,FY,QTR,CP W/SCREEN FOR INACTIVE CP
  1. I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
  1. D STA G EX:'SI!(Y<0)
  1. D FY G EX:PRC("FY")="^"
  1. D QT G EX:PRC("QTR")="^"
  1. S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
  1. I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
  1. I '$D(PRCSC) D CPF(PRCIPFLG)
  1. G EX:'SI!(Y<0)
  1. G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
  1. G EN11
  1. ;
  1. EN1F(PRCIPFLG) ; Entry point for Inv. Pt. selection
  1. EN1 ;STA,FY,QTR,CP
  1. I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
  1. D STA G EX:'SI!(Y<0)
  1. D FY G EX:PRC("FY")="^"
  1. D QT G EX:PRC("QTR")="^"
  1. I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
  1. I '$D(PRCSC) D CPF(PRCIPFLG)
  1. G EX:'SI!(Y<0)
  1. G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
  1. EN11 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
  1. S X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ")
  1. G EXIT
  1. ;
  1. EN2 ;STA,FY,QTR
  1. D STA G EX:'SI!(Y<0)
  1. D FY G EX:PRC("FY")="^"
  1. D QT G EX:PRC("QTR")="^"
  1. G EXIT
  1. ;
  1. EN3F(PRCIPFLG) ; Entry point for Inv. Pt. selection
  1. EN3 ;STA,CP
  1. I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
  1. D STA G EX:'SI!(Y<0)
  1. I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
  1. D:'$D(PRCSC) CPF(PRCIPFLG)
  1. G EX:'SI!(Y<0)
  1. G EXIT
  1. ;
  1. EN4 ;STA,FY,QTR,CC
  1. D STA G EX:'SI!(Y<0)
  1. D FY G EX:PRC("FY")="^"
  1. D QT G EX:PRC("QTR")="^"
  1. D CC
  1. G EXIT
  1. ;
  1. EN5 ;STA,FY,QTR,BOC
  1. D STA G EX:'SI!(Y<0)
  1. D FY G EX:PRC("FY")="^"
  1. D QT G EX:PRC("QTR")="^"
  1. D SUB
  1. G EXIT
  1. ;
  1. EN6F(PRCIPFLG) ; Entry point for Inv. Pt. selection
  1. EN6 ;STA,CP,FY
  1. I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
  1. D STA G EX:'SI!(Y<0)
  1. I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
  1. I '$D(PRCSC) D CPF(PRCIPFLG)
  1. G EX:'SI!(Y<0)
  1. D FY G EX:PRC("FY")="^"
  1. G EXIT
  1. ;
  1. ;PRCSST is flag to not ask substation
  1. ;PRCSK is flag to allow selection of any station
  1. STA ;SELECT STATION NUMBER
  1. S N="",Y=0
  1. I $D(PRCSK) S SI=2 ; if privilege flag is set, ask STATION
  1. ; else restrict station selection to user's authorized stations
  1. E F SI=0:1:2 S N=$O(^PRC(420,"A",DUZ,N)) Q:N'>0 S N(1)=N
  1. Q:'SI ; user not allowed to access any station
  1. I SI>1 D
  1. . S DIC="^PRC(420,",DIC(0)="AEMQ",DIC("A")="Select STATION NUMBER: "
  1. . I '$D(PRCSK) S DIC("S")="I $D(^PRC(420,""A"",DUZ,+Y))"
  1. . I $D(PRC("SITE")) S DIC("B")=PRC("SITE")
  1. . S D="B^C"
  1. . D MIX^DIC1 I Y>0 S PRC("SITE")=+Y
  1. I SI=1 S PRC("SITE")=N(1)
  1. I '$D(PRC("SITE")) S PRC("SITE")="",PRC("SST")=""
  1. I PRC("SITE")=""!(Y<0) K DIC,N Q
  1. ; substation
  1. I '$D(PRC("SST"))!'$D(^PRC(411,"UP",+PRC("SITE"))) S PRC("SST")=""
  1. I '$G(PRCSST),$D(^PRC(411,"UP",+PRC("SITE"))) D
  1. . S DIC("B")=PRC("SST")
  1. . S DIC="^PRC(411,",DIC(0)="AEQZ",DIC("A")="Select SUBSTATION: "
  1. . S DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")"
  1. . D ^DIC I Y>0 S PRC("SST")=+Y
  1. K DIC,N
  1. Q
  1. ;
  1. FY ;SELECT FISCAL YEAR
  1. D:'$D(DT) DT^DICRW
  1. S FYT=$E(100+$E(DT,2,3)+$E(DT,4),2,3),PRC("FY")=FYT
  1. W !,"Select FISCAL YEAR: ",FYT,"// " R PRC("FY"):DTIME
  1. S:'$T PRC("FY")=U
  1. S:PRC("FY")="" PRC("FY")=FYT
  1. Q:PRC("FY")="^"
  1. I PRC("FY")'?2N W $C(7),!,"Enter a two digit fiscal year (e.g., 87).",! G FY
  1. Q
  1. ;
  1. QT ;SELECT QUARTER
  1. D:'$D(DT) DT^DICRW
  1. I '$D(QTT) S:$D(PRC("QTR")) QTT=PRC("QTR") I '$D(QTT) S SI=$E(DT,4,5),QTT=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",SI)
  1. W !,"Select QUARTER: ",QTT,"// " R PRC("QTR"):DTIME
  1. S:'$T PRC("QTR")=U
  1. S:PRC("QTR")="" PRC("QTR")=QTT
  1. Q:PRC("QTR")=U
  1. I PRC("QTR")<1!(PRC("QTR")>4)!(PRC("QTR")'?1N) W $C(7),!,"Enter a single digit number from 1 to 4.",! G QT
  1. Q
  1. ;
  1. CPF(PRCIPFLG) ; Entry point for inv. pt. selection
  1. CP ;SELECT CONTROL POINT
  1. N FCPDA
  1. K PRCSIP ; inventory distribution point variable
  1. I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
  1. S FCPDA=$O(^PRC(420,"A",DUZ,PRC("SITE"),0)) Q:'FCPDA ; no fcps
  1. I '$O(^PRC(420,"A",DUZ,PRC("SITE"),FCPDA)) D Q ; access to 1 fcp
  1. . S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,FCPDA,0)),U)
  1. . I PRC("CP"),PRCIPFLG D IP
  1. ; more than one fcp
  1. S DIC="^PRC(420,"_PRC("SITE")_",1,"
  1. S DIC(0)="AEMNQZ",DIC("A")="Select CONTROL POINT: "
  1. I '$D(DIC("S")) S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
  1. I $D(PRC("CP")),PRC("CP"),$D(^PRC(420,PRC("SITE"),1,PRC("CP"))) S DIC("B")=+PRC("CP")
  1. S D="B^C" D MIX^DIC1 S:Y<0 PRC("CP")="^"
  1. I Y>0 S PRC("CP")=$P(Y(0),"^") I PRCIPFLG=1 D IP
  1. K DIC
  1. Q
  1. ;
  1. ;A=station #, B=fiscal year, C=fcp #, PRCA=1 if no user interactive
  1. BBFY(A,B,C,PRCA) ;extrinsic function of beginning budget fiscal year
  1. N D,E,F,X,Y
  1. K PRC("BBFY")
  1. S E=$G(^PRC(420,A,1,+C,5))
  1. I $P(E,"^")]"" S F=$O(^PRCD(420.3,"B",$P(E,"^"),"")) I F I $P(^PRCD(420.3,F,0),"^",8)="Y" S PRC("BBFY")=+$$DATE^PRC0C($P(E,"^",8),"I") QUIT PRC("BBFY")
  1. S B=+$$YEAR^PRC0C(B)
  1. S D=$$APP^PRC0C(A,$E(B,3,4),C)
  1. I $P(D,"^")'["_/_" S PRC("BBFY")=B QUIT PRC("BBFY")
  1. S F=$$BBFY^PRC0D(A,C,'$G(PRCA))
  1. I F="",$G(PRCA)=1 S PRC("BBFY")=B QUIT PRC("BBFY")
  1. I $G(PRCA)=1 S PRC("BBFY")=B-(B-$P(F,"~",2)#$P(F,"~",3)) QUIT PRC("BBFY")
  1. BBFY1 S E="^2:4^K:X'?2N&(X'?4N) X I $G(X)]"""" S X=+$$YEAR^PRC0C(X) K:X-$P(F,""~"",2)#$P(F,""~"",3) X"
  1. S Y(1)="Enter a 2 or 4 digit year."
  1. D FT^PRC0A(.X,.Y,"First Year of the Multi-Appropriation ("_$P(D,"^")_")",E,$S(F="":B,1:B-(B-$P(F,"~",2)#$P(F,"~",3))))
  1. I Y?2.4N S Y=+$$YEAR^PRC0C(Y) I B<Y!(Y+$P(F,"~",3)-1<B) D EN^DDIOL("You must enter a BBFY such that the document's fiscal year is between"),EN^DDIOL("beginning and ending budget fiscal years") G BBFY1
  1. S PRC("BBFY")=$S(Y?4N:Y,1:""),PRCBBMY=1
  1. QUIT PRC("BBFY")
  1. ;
  1. CC ;SELECT COST CENTER
  1. S DIC="^PRCD(420.1,",DIC(0)="AEMNQZ"
  1. D ^DIC Q:Y<0
  1. S PRCS("CC")=$P(Y(0),"^")
  1. Q
  1. ;
  1. SUB ;SELECT BOC
  1. S DIC="^PRCD(420.2,",DIC(0)="AEMNQZ"
  1. D ^DIC Q:Y<0
  1. S PRCS("SUB")=$P(Y(0),"^")
  1. Q
  1. ;
  1. LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
  1. N PRCLOCK
  1. S PRCLOCK=DIC_DA_")" L +(@PRCLOCK):($G(DILOCKTM,15))
  1. S PRCSL=$T
  1. W:$T=0 !!,$C(7),"Sorry, record is being accessed by another user. Please try later."
  1. Q
  1. ;
  1. EX S Y=-1
  1. K PRC("QTR"),PRC("FY"),PRC("BBFY"),SI,PRCBBMY
  1. I $D(PRC("CP")) K:PRC("CP")="ALL"!(PRC("CP")="^") PRC("CP")
  1. EXIT K FYT,SI,PRCSK,QTT,DIC("A")
  1. Q
  1. ;
  1. NSCRNF(PRCIPFLG) ; Entry point for Inv. Pt. selection
  1. NSCRN ;STA,FY,QTR,CP
  1. I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
  1. D STA G EX:'SI!(Y<0)
  1. D FY G EX:PRC("FY")="^"
  1. D QT G EX:PRC("QTR")="^"
  1. S PRCSC=4 D CPF^PRCSUT1(PRCIPFLG)
  1. I '$D(PRCSC) D CPF(PRCIPFLG)
  1. G EX:'SI!(Y<0)
  1. G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
  1. QUIT
  1. ;
  1. IP ; Get Inventory point
  1. Q:'$D(PRC("SITE"))!('$D(PRC("CP")))
  1. N CTR,I
  1. K ^TMP($J,"PRCSUT")
  1. S (CTR,I)=0,PRCSIP=""
  1. F S I=$O(^PRC(420,"AF",PRC("SITE"),+PRC("CP"),I)) Q:'I S CTR=CTR+1,^TMP($J,"PRCSUT",CTR)=I_"^"_$P(^PRCP(445,I,0),"^")
  1. I CTR=0 G IPQ
  1. I CTR=1!$G(PRCRMPR) S PRCSIP=$P(^TMP($J,"PRCSUT",1),"^") G IPQ
  1. F I=1:1:CTR D Q:$D(DIRUT)
  1. . W !,?5,I,") ",$P(^TMP($J,"PRCSUT",I),"^",2)
  1. . I I#(IOSL-2)=0 K DIR S DIR(0)="E" D ^DIR
  1. S DIR(0)="NO^1:"_CTR_":0"
  1. S DIR("A")="Select INVENTORY POINT"
  1. S DIR("?",1)="Enter a number from 1 to "_CTR_" to select the displayed"
  1. S DIR("?")="Inventory Point. This is an optional response."
  1. D ^DIR K DIR
  1. I Y>0 S PRCSIP=$P(^TMP($J,"PRCSUT",Y),"^") W " ",$P(^TMP($J,"PRCSUT",Y),"^",2),!
  1. IPQ K ^TMP($J,"PRCSUT")
  1. Q