- 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 Feb 18, 2025@23:45:31 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