- PRCSEB ;SF-ISC/LJP/SAW/DXH/DAP - CPA EDITS CON'T ; 3/15/21@2:24pm
- V ;;5.1;IFCAP;**81,174,184,196,204,209,223**;Oct 20, 2000;Build 16
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ;PRC*5.1*184 Check for error message indicating no 2237 seq nos.
- ; remaining to be used out of the max 9999 available
- ; for FCP FY-FQ.
- ;
- ;PRC*5.1*196 Check to move Date Required to Committed Date (MOP= 2,3 or 4)
- ; to insure a later date is used for FMS document. Also
- ; added date check called from templates PRCSENR&NR1,
- ; PRCSEN2237B & PRCSENPR to insure dates are in same
- ; FY/FQ defined.
- ;
- ;PRC*5.1*223 Use DIE set to save IP in file 410, field #4 in lieu of
- ; direct set that did not create the file index 'AO for field.
- ;
- ENRB ;ENTER CP CLERK REQUEST FROM OPTION PRCSENRB
- K PRCBBMY
- D ENF^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0)
- S MSG="" D EN1^PRCSUT3 Q:'X I MSG'="" W !!,MSG,! S DIR(0)="EAO",DIR("A")="Press <Enter> to exit processing..." D ^DIR K DIR,MSG Q ;PRC*5.1*184
- K MSG ;PRC*5.1*184
- S PRCSX1=X D EN2^PRCSUT3 Q:'$D(PRCSX1) S X=PRCSX1,T1=DA D W L +^PRCS(410,DA):15 G ENRB:$T=0 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS2=1
- ;
- ;*81 Check site parameter to see if issue books should be allowed
- D CKPRM
- W !!,PRCVY,!!
- TYPE ;
- S PRCDAA=DA,DIC="^PRCS(410.5,",DIC(0)="AEQZ",DIC("A")="FORM TYPE: ",DIC("S")=PRCVX D ^DIC S TYPE=+Y,DA=PRCDAA
- I TYPE<2 W "?? EXIT NOT ALLOWED" G TYPE
- K PRCVX,PRCVY,PRCSIPT,PRCPPRIV ;PRC*5.1*223
- S $P(^PRCS(410,DA,0),"^",4)=TYPE ;PRC*5.1*223
- I $G(PRCSIP) D ;PRC*5.1*223
- . S PRCSIPT=$P(^PRCP(445,PRCSIP,0),U),PRCPPRIV=1 ;PRC*5.1*223
- . S DIE="^PRCS(410,",DR="4///^S X=PRCSIPT" D ^DIE ;PRC*5.1*223
- . K PRCSIPT
- S (DIE,DIC)="^PRCS(410,",X=TYPE
- ;NOTE THAT THE FOLLOWING LINE OVERWRITES THE USER'S SELECTION OF FORM
- ;TYPE IF THE FUND CONTROL POINT IS NOT 'AUTOMATED'
- S:'$D(PRCS2)&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
- S PRCSTYP=X ;PRC*5.1*196
- S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]"
- EN1 K DTOUT,DUOUT,PRCSIPT,Y S PRCSDAA=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=PRCSDAA L -^PRCS(410,DA) G EXIT ;PRC*5.1*223
- S DA=PRCSDAA D RL^PRCSUT1
- COMDT I PRCSTYP>1,PRCSTYP<5,$P($G(^PRCS(410,DA,4)),U,2)="" D ;PRC*5.1*196, PRC*5.1*204 protect global with $G
- . S PRCOMDT=$S($P(^PRCS(410,DA,1),U,4)'=DT:$P(^PRCS(410,DA,1),U,4),1:DT)
- . S DR="21///^S X=PRCOMDT",DIE="^PRCS(410," D ^DIE
- . S DR=$G(PRCSDR) ;reset DR to template value, PRC*5.1*204
- D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1
- K PRCSERR
- I PRCSDR="[PRCSENCOD]" D W7^PRCSEB0 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB
- S:$P($G(^PRCS(410,DA,7)),"^")="" $P(^PRCS(410,DA,7),"^")=DUZ
- D:PRCSDR'="[PRCSENCOD]" W1 I $D(PRCS2),+^PRCS(410,DA,0) D W6
- S DA=PRCSDAA L -^PRCS(410,DA) D W3 G EXIT:%'=1 W !! K PRCS,PRCS2
- G ENRB
- W W !!,"This transaction is assigned transaction number: ",X Q
- W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q
- W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
- W3 W !!,"Would you like to enter another request" S %=1 D YN^DICN G W3:%=0 Q
- W5 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)="" K ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA) Q
- W51 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)=1,(^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA))="" Q
- W6 N JUMP,SKIPRNT,OK,TEST,TEST1,CURQTR,CURQTR1
- W61 ;
- N REPORT2 I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 S REPORT2=1 D T1^PRCSAPP1
- ;*****PRC*5.1*174 start*****
- ;if Level of Access is not Control Point Official DO block
- I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 D Q
- . N PRCFTYPE S PRCFTYPE=+$$GET1^DIQ(410,$G(DA)_",",3,"I") ;Form Type
- . S %=1
- . ;if request is a 2237 (Form Type IEN 2,3, or 4)
- . I $G(PRCFTYPE)>1&($G(PRCFTYPE)<5) D
- . . ;don't allow approval of 2237 if Requesting Service OR any line item description is missing
- . . I '$$REQCHECK^PRCHJUTL($G(DA),,1) S %=2
- . I $G(%)'=2 S %=1 W !,"Is this request ready for approval" D YN^DICN
- . D:%=1 W51
- . D:%=0 W61
- . D:%=2 W5
- ;*****PRC*5.1*174 end******
- S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4),PRC("FY")=$P(PRCSN,"-",2),PRC("QTR")=$P(PRCSN,"-",3)
- S (CURQTR,CURQTR1)=PRC("QTR"),(JUMP,TEST,TEST1,OK)=0
- D T1^PRCSAPP1 I OK=1 S SKIPRNT=1 D FINAL^PRCSAPP2
- Q
- ;*81 Site Parameter Check
- CKPRM I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The form types 1358, Issue Book, and NO FORM are no longer used within this option."
- I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The form types 1358 and NO FORM are no longer used within this option"
- Q
- ;
- CHKREQ ;Check Date to insure it is within the FY/FQ range during option entry for 'NEW 2237' ;PRC*5.1*196
- N PRCDT,PRCDT1,PRCTAPPR
- S PRCTAPPR=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,+PRC("FY"),2)),"^",9) ;PRC*5.1*209 use appropriation code from node 4, check both X and x
- I $D(PRCBBMY) S PRCCKERR=0 Q
- S PRCDTT=1700+$E(DT,1,3)
- I '$D(PRC("BBFY"))!(+$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",12)>0)!(PRCTAPPR["X")!(PRCTAPPR["x") S PRC("BBFY")=PRC("FY")+2000
- S PRCCKERR=0,PRCDT=(PRC("BBFY")-$S(PRC("QTR")=1:1701,1:1700))_$P("10:01:04:07",":",PRC("QTR"))_"01",PRCDT1=(PRC("BBFY")-1700)_"0930"
- I PRCSTDT<PRCDT!(PRCSTDT>PRCDT1) D
- . S PRCCKERR=1
- . W !!," ** Date must be specified for time **",!," ** period covered by fiscal year ",PRC("BBFY")," **",!
- Q
- EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSERR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z,PRCOMDT,PRCCKERR,PRCSTYP Q ;PRC*5.1*196
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSEB 6149 printed Feb 18, 2025@23:43:51 Page 2
- PRCSEB ;SF-ISC/LJP/SAW/DXH/DAP - CPA EDITS CON'T ; 3/15/21@2:24pm
- V ;;5.1;IFCAP;**81,174,184,196,204,209,223**;Oct 20, 2000;Build 16
- +1 ;Per VA Directive 6402, this routine should not be modified.
- +2 ;
- +3 ;PRC*5.1*184 Check for error message indicating no 2237 seq nos.
- +4 ; remaining to be used out of the max 9999 available
- +5 ; for FCP FY-FQ.
- +6 ;
- +7 ;PRC*5.1*196 Check to move Date Required to Committed Date (MOP= 2,3 or 4)
- +8 ; to insure a later date is used for FMS document. Also
- +9 ; added date check called from templates PRCSENR&NR1,
- +10 ; PRCSEN2237B & PRCSENPR to insure dates are in same
- +11 ; FY/FQ defined.
- +12 ;
- +13 ;PRC*5.1*223 Use DIE set to save IP in file 410, field #4 in lieu of
- +14 ; direct set that did not create the file index 'AO for field.
- +15 ;
- ENRB ;ENTER CP CLERK REQUEST FROM OPTION PRCSENRB
- +1 KILL PRCBBMY
- +2 DO ENF^PRCSUT(1)
- if '$DATA(PRC("SITE"))
- GOTO W2
- if '$DATA(PRC("QTR"))!(Y<0)
- GOTO EXIT
- +3 ;PRC*5.1*184
- SET MSG=""
- DO EN1^PRCSUT3
- if 'X
- QUIT
- IF MSG'=""
- WRITE !!,MSG,!
- SET DIR(0)="EAO"
- SET DIR("A")="Press <Enter> to exit processing..."
- DO ^DIR
- KILL DIR,MSG
- QUIT
- +4 ;PRC*5.1*184
- KILL MSG
- +5 SET PRCSX1=X
- DO EN2^PRCSUT3
- if '$DATA(PRCSX1)
- QUIT
- SET X=PRCSX1
- SET T1=DA
- DO W
- LOCK +^PRCS(410,DA):15
- if $TEST=0
- GOTO ENRB
- IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
- if $PIECE(^(0),"^",11)="Y"
- SET PRCS2=1
- +6 ;
- +7 ;*81 Check site parameter to see if issue books should be allowed
- +8 DO CKPRM
- +9 WRITE !!,PRCVY,!!
- TYPE ;
- +1 SET PRCDAA=DA
- SET DIC="^PRCS(410.5,"
- SET DIC(0)="AEQZ"
- SET DIC("A")="FORM TYPE: "
- SET DIC("S")=PRCVX
- DO ^DIC
- SET TYPE=+Y
- SET DA=PRCDAA
- +2 IF TYPE<2
- WRITE "?? EXIT NOT ALLOWED"
- GOTO TYPE
- +3 ;PRC*5.1*223
- KILL PRCVX,PRCVY,PRCSIPT,PRCPPRIV
- +4 ;PRC*5.1*223
- SET $PIECE(^PRCS(410,DA,0),"^",4)=TYPE
- +5 ;PRC*5.1*223
- IF $GET(PRCSIP)
- Begin DoDot:1
- +6 ;PRC*5.1*223
- SET PRCSIPT=$PIECE(^PRCP(445,PRCSIP,0),U)
- SET PRCPPRIV=1
- +7 ;PRC*5.1*223
- SET DIE="^PRCS(410,"
- SET DR="4///^S X=PRCSIPT"
- DO ^DIE
- +8 KILL PRCSIPT
- End DoDot:1
- +9 SET (DIE,DIC)="^PRCS(410,"
- SET X=TYPE
- +10 ;NOTE THAT THE FOLLOWING LINE OVERWRITES THE USER'S SELECTION OF FORM
- +11 ;TYPE IF THE FUND CONTROL POINT IS NOT 'AUTOMATED'
- +12 if '$DATA(PRCS2)&(X>2)
- SET $PIECE(^PRCS(410,DA,0),"^",4)=2
- SET X=2
- +13 ;PRC*5.1*196
- SET PRCSTYP=X
- +14 SET (PRCSDR,DR)="["_$SELECT(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]"
- EN1 ;PRC*5.1*223
- KILL DTOUT,DUOUT,PRCSIPT,Y
- SET PRCSDAA=DA
- DO ^DIE
- IF $DATA(Y)!($DATA(DTOUT))
- SET DA=PRCSDAA
- LOCK -^PRCS(410,DA)
- GOTO EXIT
- +1 SET DA=PRCSDAA
- DO RL^PRCSUT1
- COMDT ;PRC*5.1*196, PRC*5.1*204 protect global with $G
- IF PRCSTYP>1
- IF PRCSTYP<5
- IF $PIECE($GET(^PRCS(410,DA,4)),U,2)=""
- Begin DoDot:1
- +1 SET PRCOMDT=$SELECT($PIECE(^PRCS(410,DA,1),U,4)'=DT:$PIECE(^PRCS(410,DA,1),U,4),1:DT)
- +2 SET DR="21///^S X=PRCOMDT"
- SET DIE="^PRCS(410,"
- DO ^DIE
- +3 ;reset DR to template value, PRC*5.1*204
- SET DR=$GET(PRCSDR)
- End DoDot:1
- +4 DO ^PRCSCK
- IF $DATA(PRCSERR)
- IF PRCSERR
- GOTO EN1
- +5 KILL PRCSERR
- +6 IF PRCSDR="[PRCSENCOD]"
- DO W7^PRCSEB0
- if $DATA(PRCSOB)
- DO ENOD1^PRCSEB1
- KILL PRCSOB
- +7 if $PIECE($GET(^PRCS(410,DA,7)),"^")=""
- SET $PIECE(^PRCS(410,DA,7),"^")=DUZ
- +8 if PRCSDR'="[PRCSENCOD]"
- DO W1
- IF $DATA(PRCS2)
- IF +^PRCS(410,DA,0)
- DO W6
- +9 SET DA=PRCSDAA
- LOCK -^PRCS(410,DA)
- DO W3
- if %'=1
- GOTO EXIT
- WRITE !!
- KILL PRCS,PRCS2
- +10 GOTO ENRB
- W WRITE !!,"This transaction is assigned transaction number: ",X
- QUIT
- W1 WRITE !!,"Would you like to review this request"
- SET %=2
- DO YN^DICN
- if %=0
- GOTO W1
- if %'=1
- QUIT
- SET (N,PRCSZ)=DA
- SET PRCSF=1
- DO PRF1^PRCSP1
- SET DA=PRCSZ
- KILL X,PRCSF,PRCSZ
- QUIT
- W2 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
- READ X:5
- GOTO EXIT
- W3 WRITE !!,"Would you like to enter another request"
- SET %=1
- DO YN^DICN
- if %=0
- GOTO W3
- QUIT
- W5 if '$DATA(^PRCS(410,DA,11))
- SET ^(11)=""
- SET $PIECE(^(11),U,3)=""
- KILL ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
- QUIT
- W51 if '$DATA(^PRCS(410,DA,11))
- SET ^(11)=""
- SET $PIECE(^(11),U,3)=1
- SET (^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA))=""
- QUIT
- W6 NEW JUMP,SKIPRNT,OK,TEST,TEST1,CURQTR,CURQTR1
- W61 ;
- +1 NEW REPORT2
- IF $PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1
- SET REPORT2=1
- DO T1^PRCSAPP1
- +2 ;*****PRC*5.1*174 start*****
- +3 ;if Level of Access is not Control Point Official DO block
- +4 IF $PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1
- Begin DoDot:1
- +5 ;Form Type
- NEW PRCFTYPE
- SET PRCFTYPE=+$$GET1^DIQ(410,$GET(DA)_",",3,"I")
- +6 SET %=1
- +7 ;if request is a 2237 (Form Type IEN 2,3, or 4)
- +8 IF $GET(PRCFTYPE)>1&($GET(PRCFTYPE)<5)
- Begin DoDot:2
- +9 ;don't allow approval of 2237 if Requesting Service OR any line item description is missing
- +10 IF '$$REQCHECK^PRCHJUTL($GET(DA),,1)
- SET %=2
- End DoDot:2
- +11 IF $GET(%)'=2
- SET %=1
- WRITE !,"Is this request ready for approval"
- DO YN^DICN
- +12 if %=1
- DO W51
- +13 if %=0
- DO W61
- +14 if %=2
- DO W5
- End DoDot:1
- QUIT
- +15 ;*****PRC*5.1*174 end******
- +16 SET PRCSN=^PRCS(410,DA,0)
- SET PRCHQ=$PIECE(PRCSN,"^",4)
- SET PRC("FY")=$PIECE(PRCSN,"-",2)
- SET PRC("QTR")=$PIECE(PRCSN,"-",3)
- +17 SET (CURQTR,CURQTR1)=PRC("QTR")
- SET (JUMP,TEST,TEST1,OK)=0
- +18 DO T1^PRCSAPP1
- IF OK=1
- SET SKIPRNT=1
- DO FINAL^PRCSAPP2
- +19 QUIT
- +20 ;*81 Site Parameter Check
- CKPRM IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
- SET PRCVX="I Y>1&(Y<5)"
- SET PRCVY="The form types 1358, Issue Book, and NO FORM are no longer used within this option."
- +1 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
- SET PRCVX="I Y>1"
- SET PRCVY="The form types 1358 and NO FORM are no longer used within this option"
- +2 QUIT
- +3 ;
- CHKREQ ;Check Date to insure it is within the FY/FQ range during option entry for 'NEW 2237' ;PRC*5.1*196
- +1 NEW PRCDT,PRCDT1,PRCTAPPR
- +2 ;PRC*5.1*209 use appropriation code from node 4, check both X and x
- SET PRCTAPPR=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,+PRC("FY"),2)),"^",9)
- +3 IF $DATA(PRCBBMY)
- SET PRCCKERR=0
- QUIT
- +4 SET PRCDTT=1700+$EXTRACT(DT,1,3)
- +5 IF '$DATA(PRC("BBFY"))!(+$PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",12)>0)!(PRCTAPPR["X")!(PRCTAPPR["x")
- SET PRC("BBFY")=PRC("FY")+2000
- +6 SET PRCCKERR=0
- SET PRCDT=(PRC("BBFY")-$SELECT(PRC("QTR")=1:1701,1:1700))_$PIECE("10:01:04:07",":",PRC("QTR"))_"01"
- SET PRCDT1=(PRC("BBFY")-1700)_"0930"
- +7 IF PRCSTDT<PRCDT!(PRCSTDT>PRCDT1)
- Begin DoDot:1
- +8 SET PRCCKERR=1
- +9 WRITE !!," ** Date must be specified for time **",!," ** period covered by fiscal year ",PRC("BBFY")," **",!
- End DoDot:1
- +10 QUIT
- EXIT ;PRC*5.1*196
- KILL %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSERR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z,PRCOMDT,PRCCKERR,PRCSTYP
- QUIT