PRCSUT2 ;WISC/SAW/CTB/DXH - TRANSACTION UTILITY ;5/20/13 16:22
V ;;5.1;IFCAP;**13,135,148,150,174**;Oct 20, 2000;Build 23
;;Per VHA Directive 2004-038, this routine should not be modified.
; assigns a permanent transaction number to an existing transaction
; if the existing transaction is temporary, it is converted to
; permanent.
; if the existing transaction is permanent, a new ien is created and
; populated with info from the existing transaction, then canceled.
; The original transaction is updated with the new transaction number.
ANTN ;
N ODA,PNW,TX1,T1,T2,T3,T4,T5,PRCSY,PRCSDIC,PRCSAPP,PRCECMS,PRCOLDI
ANTN1 D EN3^PRCSUT ; ask site, CP
G W5:'$D(PRC("SITE"))
G EXIT:Y<0
W !!,"Select the existing transaction number to be replaced",!
S DIC="^PRCS(410,",DIC(0)="AEFMQ"
S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
D ^PRCSDIC G:Y<0 EXIT
S (ODA,DA,T1)=+Y,PRCSDIC=DIC
L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3)
I $T=0 W !,"File being accessed...please try later" G ANTN1
D REVIEW
S T2=^PRCS(410,DA,0) ; node 0 string of txn to be replaced
S T5=$P(T2,"^",10) ; substation
S T4=$P(T2,"^",2) ; txn type of transaction to be replaced
S T2=$P(T2,"^") ; txn number to be replaced
S T3=$P(^PRCS(410,DA,3),"^") ; control point of txn to be replaced
S PRCECMS=$P($G(^PRCS(410,DA,1)),U,8),PRCOLDI=DA
K DA,DIC,Y
W !!,"Enter the information for the new transaction number",!
D EN^PRCSUT3 ; ask SITE, FY, QRTR, CP for new txn
G:'$D(PRC("QTR"))!('$D(PRC("CP"))) EXIT
S TX1=X
I $P($G(^PRCS(410,T1,0)),"^",4)=1,$$Q1358^PRCEN(PRC("SITE"),PRC("CP"),T4,T1) G EXIT
D IP^PRCSUT ; set up prcsip
S PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)
I PRC("CP")'=T3,PRCSAPP["_" D PRCFY G EXIT:PRCSAPP["_"
S X=TX1
D EN1^PRCSUT3 ; generate new name for txn and put in X
G:'X EXIT
S TX1=X,(DIC,DIE)="^PRCS(410,"
CK G:'+T2 CK1 ; don't set up new ien for temp txns (txns with non-numeric names)
K DA
S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ"
D ^DIC
K DLAYGO
G:Y'>0 EXIT
S DA=+Y
L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3) ; Lock new ien
I $T=0 W !," Cannot create new number now...please try again later" G EXIT
; clean up txn x-refs for old & new ien's (nodes 'B','B2','B3','AE')
K ^PRCS(410,"B",TX1,DA),^PRCS(410,"B2",$P(TX1,"-",5),DA),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),DA),^PRCS(410,"AE",$P(TX1,"-",1,4),DA)
; kill x-refs to old ien
N RBQTDT,DSH,RBOLD
S RBQTDT=$P($G(^PRCS(410,T1,0)),"^",11),DSH="-" D:RBQTDT>0
. S RBOLD=RBQTDT_DSH_$P(T2,"-")_DSH_$P(T2,"-",4)_DSH_$P(T2,"-",2)_DSH_$P(T2,"-",5)
. K ^PRCS(410,"RB",RBOLD,T1)
K RBQTDT,DSH,RBOLD
K ^PRCS(410,"B",T2,T1),^PRCS(410,"B2",$P(T2,"-",5),T1),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),T1),^PRCS(410,"AE",$P(T2,"-",1,4),T1)
; set old txn name into new ien
S $P(^PRCS(410,DA,0),"^")=T2
; set x-refs of old txn values to new ien
S (^PRCS(410,"B",T2,DA),^PRCS(410,"B2",$P(T2,"-",5),DA),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),DA),^PRCS(410,"AE",$P(T2,"-",1,4),DA))=""
CK1 ; set new txn name into old (original) ien
S $P(^PRCS(410,T1,0),"^")=TX1
; set x-refs of new txn values to old ien
S (^PRCS(410,"B",TX1,T1),^PRCS(410,"B2",$P(TX1,"-",5),T1),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),T1),^PRCS(410,"AE",$P(TX1,"-",1,4),T1))=""
; delete old txn from temp txn x-ref & remove temp txn flag
K ^PRCS(410,"K",+T3,ODA) S $P(^PRCS(410,ODA,6),"^",4)=""
S PRC("OCP")=$P(^PRCS(410,ODA,3),U)
; If the old transaction had eCMS identifiers, remove them from the old
; entry which has been assigned the new transaction number.
I PRCECMS>0 D
. N PRCX S PRCX=$$XECMSIDS^PRCHJR03(PRCOLDI)
; if old txn name is non-numeric (temp txn), force new site & CP into record at old ien
;PRC*5.1*150 add x-ref kill for old txn non-numeric name
I '+T2 S DA=ODA,DIE="^PRCS(410,",DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP") D ^DIE D G EN
. K ^PRCS(410,"B",T2,ODA)
; else: cancel txn at old ien; force old site & CP info into new ien
;(Shortened comment and added cancel flag with patch 182
S DIE="^PRCS(410,",DR=".5///"_+T2_";S X=X;15///"_T3
S DR=DR_";60///Transaction "_T2_" replaced by trans. "_TX1
S DR=DR_";450///C" ;put cancel flag in Running Bal status
D ^DIE
S DR="104////^S X=DUZ" D ^DIE K DR
I T5'="" S $P(^PRCS(410,DA,0),U,10)=T5 ; save substation in new ien
S $P(^PRCS(410,DA,0),U,2)="CA" ; cancel txn at new ien
D ERS410^PRC0G(DA_"^C")
D W5^PRCSEB ; kill flags & x-refs indicating cancel txn is ready to approve
L -^PRCS(410,DA) ; release new ien
W !,"Old transaction "_T2_" is now cancelled.",!
I $D(^PRC(443,ODA,0)) S DA=ODA,DIK="^PRC(443," D ^DIK K DA,DIK
EN W !!,"Transaction '"_T2_"' has been replaced by "_TX1,!
S PNW=ODA,PNW(1)=TX1
N A,B
S A=TX1 D RBQTR ; returns B for DR string (RB Qrtr date)
I $E(B,$L(B))=";" S B=$E(B,1,$L(B)-1) ; remove trailing semi-colon
S DA=PNW,DR=B_$S(+T2:";1///"_T4,1:"")_$S(PRC("SITE")'=+T2:";S X=X;.5///"_PRC("SITE"),1:"")_$S(PRC("CP")'=T3:";S X=X;15///"_PRC("CP"),1:"")_$S($D(PRCSIP):";4////"_PRCSIP,1:"")
S DR=DR_$S($P($G(^PRCS(410,DA,0)),"^",4)=1:";40////^S X=DUZ",1:"")
D ^DIE
S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
S PRCSAPP=$P(PRC("ACC"),"^",11)
S $P(^PRCS(410,DA,3),"^")=PRC("CP")
S $P(^PRCS(410,DA,3),"^",2)=PRCSAPP
S $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3)
S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
N MYY S MYY="" D EN2B^PRCSUT3 ; save substation & process with status of entered
D K^PRCSUT1 ; kill 'F', 'F1', x-refs
K T1(1)
S (DA,PRCS,PRCSY)=PNW
I $P(^PRCS(410,DA,0),"^",4)=1 D G ANTN:%=1,EXIT
. S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
. W !,"Use the 1358 edit option ",$S(AA<0:"",1:"if you wish "),"to edit this request.",!! D EXIT,W3
; restore values associated with new txn (use new name)
S PRC("SITE")=$P(PNW(1),"-"),PRC("FY")=$P(PNW(1),"-",2),PRC("QTR")=$P(PNW(1),"-",3),PRC("CP")=$P(PNW(1),"-",4),PRCSQ=1
S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
I AA<0 W !,"Use the Edit a 2237 option to edit this request.",!! D EXIT,W3 G ANTN:%=1,EXIT
E D W1 ; ask 'edit this request?'
I %=2 D W6^PRCSEB G EN1 ; if no, may ask if ready for authorization
D:%=1 EDTD1^PRCSEB0 D:'$D(PRCSQ)&(T4="O") W6^PRCSEB
EN1 K PRCSQ
L -^PRCS(410,ODA)
D W3 I %=1 D EXIT W !! G ANTN1
G EXIT
;
PRCFY S A=PRCSAPP I A["_/_" D FY2 G KILL
I A["_" S PRCSAPP=$P(A,"_",1)_$E(PRC("FY"),$L(PRC("FY")))_$P(A,"_",2)
KILL K %DT,A,B,RES,X
Q
;
FY2 ;TWO YR APP
I '$D(PRC("FY")) D NOW^%DTC S PRC("FY")=$E(100+$E(X,4)+$E(X,2,3),2,3)
W !!,"Enter first year of this two year appropriation: ",PRC("FY")," // " R RES:DTIME G:RES["^" FY21
I RES["?"!(RES'?.4N) W !,"Enter fiscal year in format '1' '81' or '1981'",!! G FY2
FY21 S:'RES RES=PRC("FY")
S RES=$E(RES,$L(RES)),PRCSAPP=$P(A,"_",1)_RES_"/"_(RES+1#10)_$P(A,"_",3)
Q
;
REVIEW W !!,"Would you like to review this request"
S %=2 D YN^DICN G REVIEW:%=0
Q:%'=1
S (N,PRCSZ)=DA,PRCSF=1
D PRF1^PRCSP1 ; print 2237
S DA=PRCSZ
K X,PRCSF,PRCSZ
Q
;
W1 S %=2 Q:T4'="O"
;*****PRC*5.1*174 start*****
N PRCFTYPE,PRCFAIL
S PRCFTYPE=+$$GET1^DIQ(410,$G(DA)_",",3,"I")
;if a 2237 transaction (Form Type IEN 2,3, or 4)
I $G(PRCFTYPE)>1&($G(PRCFTYPE)<5) D
. ;if 2237 required field check fails, output warning
. ;and force user to edit (S %=1)
. I '$$REQCHECK^PRCHJUTL($G(DA),,1) S (PRCFAIL,%)=1
;if 2237 required field checks fail, force edit and don't prompt user
Q:$G(PRCFAIL)
;*****PRC*5.1*174 end*****
W !!,"Would you like to edit this request"
D YN^DICN G W1:%=0
Q
;
W3 W !!,"Would you like to replace another transaction number"
S %=2 D YN^DICN G W3:%=0
Q
;
W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
EXIT I $D(ODA) L -^PRCS(410,ODA)
D EXIT^PRCSUT31
Q
;
MO ;MO QRTR
I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q
I PRCSQT=1 W !?3,"10 OCT",!?3,"11 NOV",!?3,"12 DEC" Q
I PRCSQT=2 W !?3," 1 JAN",!?3," 2 FEB",!?3," 3 MAR" Q
I PRCSQT=3 W !?3," 4 APR",!?3," 5 MAY",!?3," 6 JUN" Q
I PRCSQT=4 W !?3," 7 JUL",!?3," 8 AUG",!?3," 9 SEP" Q
Q
;
MO1 I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q
S PRCSMO=$S(X<4:2,X>9:1,X>3&(X<7):3,X>6&(X<10):4,1:"")
I PRCSMO="" K PRCSMO
Q
;
RBQTR N C,D S B="",B=$S(B="":$P(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I"))
S C=$$QTRDT^PRC0G($P(A,"-",1)_"^"_$P(A,"-",4)_"^"_B)
S D=$$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),D=$P(D,"^",7)
S B=$S(D<$P(C,"^",3):$P(C,"^",3),$P(C,"^",2)<D:$P(C,"^",2),1:D)
S B="449////"_B_";"
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSUT2 8899 printed Dec 13, 2024@02:19:09 Page 2
PRCSUT2 ;WISC/SAW/CTB/DXH - TRANSACTION UTILITY ;5/20/13 16:22
V ;;5.1;IFCAP;**13,135,148,150,174**;Oct 20, 2000;Build 23
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
+2 ; assigns a permanent transaction number to an existing transaction
+3 ; if the existing transaction is temporary, it is converted to
+4 ; permanent.
+5 ; if the existing transaction is permanent, a new ien is created and
+6 ; populated with info from the existing transaction, then canceled.
+7 ; The original transaction is updated with the new transaction number.
ANTN ;
+1 NEW ODA,PNW,TX1,T1,T2,T3,T4,T5,PRCSY,PRCSDIC,PRCSAPP,PRCECMS,PRCOLDI
ANTN1 ; ask site, CP
DO EN3^PRCSUT
+1 if '$DATA(PRC("SITE"))
GOTO W5
+2 if Y<0
GOTO EXIT
+3 WRITE !!,"Select the existing transaction number to be replaced",!
+4 SET DIC="^PRCS(410,"
SET DIC(0)="AEFMQ"
+5 SET DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+6 DO ^PRCSDIC
if Y<0
GOTO EXIT
+7 SET (ODA,DA,T1)=+Y
SET PRCSDIC=DIC
+8 LOCK +^PRCS(410,DA):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+9 IF $TEST=0
WRITE !,"File being accessed...please try later"
GOTO ANTN1
+10 DO REVIEW
+11 ; node 0 string of txn to be replaced
SET T2=^PRCS(410,DA,0)
+12 ; substation
SET T5=$PIECE(T2,"^",10)
+13 ; txn type of transaction to be replaced
SET T4=$PIECE(T2,"^",2)
+14 ; txn number to be replaced
SET T2=$PIECE(T2,"^")
+15 ; control point of txn to be replaced
SET T3=$PIECE(^PRCS(410,DA,3),"^")
+16 SET PRCECMS=$PIECE($GET(^PRCS(410,DA,1)),U,8)
SET PRCOLDI=DA
+17 KILL DA,DIC,Y
+18 WRITE !!,"Enter the information for the new transaction number",!
+19 ; ask SITE, FY, QRTR, CP for new txn
DO EN^PRCSUT3
+20 if '$DATA(PRC("QTR"))!('$DATA(PRC("CP")))
GOTO EXIT
+21 SET TX1=X
+22 IF $PIECE($GET(^PRCS(410,T1,0)),"^",4)=1
IF $$Q1358^PRCEN(PRC("SITE"),PRC("CP"),T4,T1)
GOTO EXIT
+23 ; set up prcsip
DO IP^PRCSUT
+24 SET PRCSAPP=$PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)
+25 IF PRC("CP")'=T3
IF PRCSAPP["_"
DO PRCFY
if PRCSAPP["_"
GOTO EXIT
+26 SET X=TX1
+27 ; generate new name for txn and put in X
DO EN1^PRCSUT3
+28 if 'X
GOTO EXIT
+29 SET TX1=X
SET (DIC,DIE)="^PRCS(410,"
CK ; don't set up new ien for temp txns (txns with non-numeric names)
if '+T2
GOTO CK1
+1 KILL DA
+2 SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="LXZ"
+3 DO ^DIC
+4 KILL DLAYGO
+5 if Y'>0
GOTO EXIT
+6 SET DA=+Y
+7 ; Lock new ien
LOCK +^PRCS(410,DA):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+8 IF $TEST=0
WRITE !," Cannot create new number now...please try again later"
GOTO EXIT
+9 ; clean up txn x-refs for old & new ien's (nodes 'B','B2','B3','AE')
+10 KILL ^PRCS(410,"B",TX1,DA),^PRCS(410,"B2",$PIECE(TX1,"-",5),DA),^PRCS(410,"B3",$PIECE(TX1,"-",2)_"-"_$PIECE(TX1,"-",5),DA),^PRCS(410,"AE",$PIECE(TX1,"-",1,4),DA)
+11 ; kill x-refs to old ien
+12 NEW RBQTDT,DSH,RBOLD
+13 SET RBQTDT=$PIECE($GET(^PRCS(410,T1,0)),"^",11)
SET DSH="-"
if RBQTDT>0
Begin DoDot:1
+14 SET RBOLD=RBQTDT_DSH_$PIECE(T2,"-")_DSH_$PIECE(T2,"-",4)_DSH_$PIECE(T2,"-",2)_DSH_$PIECE(T2,"-",5)
+15 KILL ^PRCS(410,"RB",RBOLD,T1)
End DoDot:1
+16 KILL RBQTDT,DSH,RBOLD
+17 KILL ^PRCS(410,"B",T2,T1),^PRCS(410,"B2",$PIECE(T2,"-",5),T1),^PRCS(410,"B3",$PIECE(T2,"-",2)_"-"_$PIECE(T2,"-",5),T1),^PRCS(410,"AE",$PIECE(T2,"-",1,4),T1)
+18 ; set old txn name into new ien
+19 SET $PIECE(^PRCS(410,DA,0),"^")=T2
+20 ; set x-refs of old txn values to new ien
+21 SET (^PRCS(410,"B",T2,DA),^PRCS(410,"B2",$PIECE(T2,"-",5),DA),^PRCS(410,"B3",$PIECE(T2,"-",2)_"-"_$PIECE(T2,"-",5),DA),^PRCS(410,"AE",$PIECE(T2,"-",1,4),DA))=""
CK1 ; set new txn name into old (original) ien
+1 SET $PIECE(^PRCS(410,T1,0),"^")=TX1
+2 ; set x-refs of new txn values to old ien
+3 SET (^PRCS(410,"B",TX1,T1),^PRCS(410,"B2",$PIECE(TX1,"-",5),T1),^PRCS(410,"B3",$PIECE(TX1,"-",2)_"-"_$PIECE(TX1,"-",5),T1),^PRCS(410,"AE",$PIECE(TX1,"-",1,4),T1))=""
+4 ; delete old txn from temp txn x-ref & remove temp txn flag
+5 KILL ^PRCS(410,"K",+T3,ODA)
SET $PIECE(^PRCS(410,ODA,6),"^",4)=""
+6 SET PRC("OCP")=$PIECE(^PRCS(410,ODA,3),U)
+7 ; If the old transaction had eCMS identifiers, remove them from the old
+8 ; entry which has been assigned the new transaction number.
+9 IF PRCECMS>0
Begin DoDot:1
+10 NEW PRCX
SET PRCX=$$XECMSIDS^PRCHJR03(PRCOLDI)
End DoDot:1
+11 ; if old txn name is non-numeric (temp txn), force new site & CP into record at old ien
+12 ;PRC*5.1*150 add x-ref kill for old txn non-numeric name
+13 IF '+T2
SET DA=ODA
SET DIE="^PRCS(410,"
SET DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP")
DO ^DIE
Begin DoDot:1
+14 KILL ^PRCS(410,"B",T2,ODA)
End DoDot:1
GOTO EN
+15 ; else: cancel txn at old ien; force old site & CP info into new ien
+16 ;(Shortened comment and added cancel flag with patch 182
+17 SET DIE="^PRCS(410,"
SET DR=".5///"_+T2_";S X=X;15///"_T3
+18 SET DR=DR_";60///Transaction "_T2_" replaced by trans. "_TX1
+19 ;put cancel flag in Running Bal status
SET DR=DR_";450///C"
+20 DO ^DIE
+21 SET DR="104////^S X=DUZ"
DO ^DIE
KILL DR
+22 ; save substation in new ien
IF T5'=""
SET $PIECE(^PRCS(410,DA,0),U,10)=T5
+23 ; cancel txn at new ien
SET $PIECE(^PRCS(410,DA,0),U,2)="CA"
+24 DO ERS410^PRC0G(DA_"^C")
+25 ; kill flags & x-refs indicating cancel txn is ready to approve
DO W5^PRCSEB
+26 ; release new ien
LOCK -^PRCS(410,DA)
+27 WRITE !,"Old transaction "_T2_" is now cancelled.",!
+28 IF $DATA(^PRC(443,ODA,0))
SET DA=ODA
SET DIK="^PRC(443,"
DO ^DIK
KILL DA,DIK
EN WRITE !!,"Transaction '"_T2_"' has been replaced by "_TX1,!
+1 SET PNW=ODA
SET PNW(1)=TX1
+2 NEW A,B
+3 ; returns B for DR string (RB Qrtr date)
SET A=TX1
DO RBQTR
+4 ; remove trailing semi-colon
IF $EXTRACT(B,$LENGTH(B))=";"
SET B=$EXTRACT(B,1,$LENGTH(B)-1)
+5 SET DA=PNW
SET DR=B_$SELECT(+T2:";1///"_T4,1:"")_$SELECT(PRC("SITE")'=+T2:";S X=X;.5///"_PRC("SITE"),1:"")_$SELECT(PRC("CP")'=T3:";S X=X;15///"_PRC("CP"),1:"")_$SELECT($DATA(PRCSIP):";4////"_PRCSIP,1:"")
+6 SET DR=DR_$SELECT($PIECE($GET(^PRCS(410,DA,0)),"^",4)=1:";40////^S X=DUZ",1:"")
+7 DO ^DIE
+8 SET PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+9 SET PRCSAPP=$PIECE(PRC("ACC"),"^",11)
+10 SET $PIECE(^PRCS(410,DA,3),"^")=PRC("CP")
+11 SET $PIECE(^PRCS(410,DA,3),"^",2)=PRCSAPP
+12 SET $PIECE(^PRCS(410,DA,3),"^",12)=$PIECE(PRC("ACC"),"^",3)
+13 SET $PIECE(^PRCS(410,DA,3),"^",11)=$PIECE($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
+14 ; save substation & process with status of entered
NEW MYY
SET MYY=""
DO EN2B^PRCSUT3
+15 ; kill 'F', 'F1', x-refs
DO K^PRCSUT1
+16 KILL T1(1)
+17 SET (DA,PRCS,PRCSY)=PNW
+18 IF $PIECE(^PRCS(410,DA,0),"^",4)=1
Begin DoDot:1
+19 SET AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
+20 WRITE !,"Use the 1358 edit option ",$SELECT(AA<0:"",1:"if you wish "),"to edit this request.",!!
DO EXIT
DO W3
End DoDot:1
if %=1
GOTO ANTN
GOTO EXIT
+21 ; restore values associated with new txn (use new name)
+22 SET PRC("SITE")=$PIECE(PNW(1),"-")
SET PRC("FY")=$PIECE(PNW(1),"-",2)
SET PRC("QTR")=$PIECE(PNW(1),"-",3)
SET PRC("CP")=$PIECE(PNW(1),"-",4)
SET PRCSQ=1
+23 SET AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
+24 IF AA<0
WRITE !,"Use the Edit a 2237 option to edit this request.",!!
DO EXIT
DO W3
if %=1
GOTO ANTN
GOTO EXIT
+25 ; ask 'edit this request?'
IF '$TEST
DO W1
+26 ; if no, may ask if ready for authorization
IF %=2
DO W6^PRCSEB
GOTO EN1
+27 if %=1
DO EDTD1^PRCSEB0
if '$DATA(PRCSQ)&(T4="O")
DO W6^PRCSEB
EN1 KILL PRCSQ
+1 LOCK -^PRCS(410,ODA)
+2 DO W3
IF %=1
DO EXIT
WRITE !!
GOTO ANTN1
+3 GOTO EXIT
+4 ;
PRCFY SET A=PRCSAPP
IF A["_/_"
DO FY2
GOTO KILL
+1 IF A["_"
SET PRCSAPP=$PIECE(A,"_",1)_$EXTRACT(PRC("FY"),$LENGTH(PRC("FY")))_$PIECE(A,"_",2)
KILL KILL %DT,A,B,RES,X
+1 QUIT
+2 ;
FY2 ;TWO YR APP
+1 IF '$DATA(PRC("FY"))
DO NOW^%DTC
SET PRC("FY")=$EXTRACT(100+$EXTRACT(X,4)+$EXTRACT(X,2,3),2,3)
+2 WRITE !!,"Enter first year of this two year appropriation: ",PRC("FY")," // "
READ RES:DTIME
if RES["^"
GOTO FY21
+3 IF RES["?"!(RES'?.4N)
WRITE !,"Enter fiscal year in format '1' '81' or '1981'",!!
GOTO FY2
FY21 if 'RES
SET RES=PRC("FY")
+1 SET RES=$EXTRACT(RES,$LENGTH(RES))
SET PRCSAPP=$PIECE(A,"_",1)_RES_"/"_(RES+1#10)_$PIECE(A,"_",3)
+2 QUIT
+3 ;
REVIEW WRITE !!,"Would you like to review this request"
+1 SET %=2
DO YN^DICN
if %=0
GOTO REVIEW
+2 if %'=1
QUIT
+3 SET (N,PRCSZ)=DA
SET PRCSF=1
+4 ; print 2237
DO PRF1^PRCSP1
+5 SET DA=PRCSZ
+6 KILL X,PRCSF,PRCSZ
+7 QUIT
+8 ;
W1 SET %=2
if T4'="O"
QUIT
+1 ;*****PRC*5.1*174 start*****
+2 NEW PRCFTYPE,PRCFAIL
+3 SET PRCFTYPE=+$$GET1^DIQ(410,$GET(DA)_",",3,"I")
+4 ;if a 2237 transaction (Form Type IEN 2,3, or 4)
+5 IF $GET(PRCFTYPE)>1&($GET(PRCFTYPE)<5)
Begin DoDot:1
+6 ;if 2237 required field check fails, output warning
+7 ;and force user to edit (S %=1)
+8 IF '$$REQCHECK^PRCHJUTL($GET(DA),,1)
SET (PRCFAIL,%)=1
End DoDot:1
+9 ;if 2237 required field checks fail, force edit and don't prompt user
+10 if $GET(PRCFAIL)
QUIT
+11 ;*****PRC*5.1*174 end*****
+12 WRITE !!,"Would you like to edit this request"
+13 DO YN^DICN
if %=0
GOTO W1
+14 QUIT
+15 ;
W3 WRITE !!,"Would you like to replace another transaction number"
+1 SET %=2
DO YN^DICN
if %=0
GOTO W3
+2 QUIT
+3 ;
W5 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
READ X:5
EXIT IF $DATA(ODA)
LOCK -^PRCS(410,ODA)
+1 DO EXIT^PRCSUT31
+2 QUIT
+3 ;
MO ;MO QRTR
+1 IF DA
IF $DATA(^PRCS(410,DA,0))
SET PRCSQT=$PIECE(^(0),"-",3)
IF PRCSQT=""
KILL PRCSQT
QUIT
+2 IF PRCSQT=1
WRITE !?3,"10 OCT",!?3,"11 NOV",!?3,"12 DEC"
QUIT
+3 IF PRCSQT=2
WRITE !?3," 1 JAN",!?3," 2 FEB",!?3," 3 MAR"
QUIT
+4 IF PRCSQT=3
WRITE !?3," 4 APR",!?3," 5 MAY",!?3," 6 JUN"
QUIT
+5 IF PRCSQT=4
WRITE !?3," 7 JUL",!?3," 8 AUG",!?3," 9 SEP"
QUIT
+6 QUIT
+7 ;
MO1 IF DA
IF $DATA(^PRCS(410,DA,0))
SET PRCSQT=$PIECE(^(0),"-",3)
IF PRCSQT=""
KILL PRCSQT
QUIT
+1 SET PRCSMO=$SELECT(X<4:2,X>9:1,X>3&(X<7):3,X>6&(X<10):4,1:"")
+2 IF PRCSMO=""
KILL PRCSMO
+3 QUIT
+4 ;
RBQTR NEW C,D
SET B=""
SET B=$SELECT(B="":$PIECE(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I"))
+1 SET C=$$QTRDT^PRC0G($PIECE(A,"-",1)_"^"_$PIECE(A,"-",4)_"^"_B)
+2 SET D=$$QTRDATE^PRC0D($PIECE(A,"-",2),$PIECE(A,"-",3))
SET D=$PIECE(D,"^",7)
+3 SET B=$SELECT(D<$PIECE(C,"^",3):$PIECE(C,"^",3),$PIECE(C,"^",2)<D:$PIECE(C,"^",2),1:D)
+4 SET B="449////"_B_";"
+5 QUIT
