PRCSUT3 ;WISC/SAW/PLT/BGJ-TRANSACTION UTILITY PROGRAM ; 21 Apr 93 10:18 AM
V ;;5.1;IFCAP;**115,123,149,150,180,191**;Oct 20, 2000;Build 4
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
;kill (DIK) since DIK call does not handle descending file logic
;
;PRC*5.1*180 RGB 10/22/12 Added switch coming from IFCAP 1358
;processing to insure new entry check uses file 424, not file 410.
;
;PRC*5.1*191 RGB 6/12/14 Added check to file 424 new entry check
; that the user is alerted when there are
; only approx 100 entries left so they can
; finalize obligation for liquidation which
; needs extra file 424 entries available.
; Also added check for next sequence number
; for 1358 in 410.1 being 9999, reset to
; 9998 so don't hit the 10000 barrier with
; with original node seq plus 1.
;
EN ;CREATE NEW TRANSACTION NUMBER
D EN1^PRCSUT K DA,DIC G W5:'$D(PRC("SITE")) Q
EN1 G:'$D(X) OUT1 S NODE=0,PIECE=2 I $D(PRCS("TYPE")) G:'X OUT1 S T(1)=$O(^DD(410.1,"B",PRCS("TYPE"),0)) G:'T(1)!('$D(^DD(410.1,+T(1),0))) OUT1
S DIC="^PRCS(410.1,",MSG="",ZERSW=0
;I $D(^PRCS(410.1,"B",X)) S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N L +^PRCS410.1,N):15 G:$T=0 OUT1 S T=$P(^PRCS(410.1,N,NODE),"^",PIECE)+1 S:T<1 T=1 L -^PRCS(410.1,N))
I $D(^PRCS(410.1,"B",X)) S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N S T=$P(^PRCS(410.1,N,NODE),"^",PIECE)+1 S:T>9999&(X'["FC") T=9999 S:T<1 T=1 ;PRC*5.1*191
I '$D(^PRCS(410.1,"B",X)) S T=1,DLAYGO=410.1,DIC="^PRCS(410.1,",DIC(0)="FLXZ" D ^DIC K DLAYGO G:Y<0 W4 S DA=+Y
S HDA=DA
T S T="000"_T,T=$E(T,$L(T)-3,$L(T))
T1 I $D(REP),$G(PRCE424)'=1 S X=X_"-"_T I $D(^PRCS(410,"B",X)) S T=+T+1,X=$P(X,"-",1,4) G:T>9999 CANCK G T ;PRC*5.1*180
I '$D(REP),'$D(PRCS("TYPE")),$G(PRCE424)'=1 S X=Z,X=X_"-"_T I $D(^PRCS(410,"B",X)) S T=+T+1 G:T>9999 CANCK G T ;PRC*5.1*180
I ('$D(REP)&$D(PRCS("TYPE")))!($G(PRCE424)=1) S Z=X,X=X_"-"_T I $D(^PRC(424,"B",X)) S T=+T+1,X=Z G:T>9999 CER424 G T ;PRC*5.1*180, PRC*5.1*191
I ('$D(REP)&$D(PRCS("TYPE")))!($G(PRCE424)=1),T>9900 G CER424 ;PRC*5.1*191
TEX S DA=HDA L +^PRCS(410.1,DA):15 S $P(^PRCS(410.1,DA,NODE),U,PIECE)=+T,$P(^(0),U,3)=DT L -^PRCS(410.1,DA)
OUT K DA,DIC,N,NODE,PIECE,PRCS("TYPE"),PRCSL,T,Z,HDA Q
OUT1 S X="",Y=-1 D OUT Q
EN2 ;add record in file 410
S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO G:Y<0 W4
EN2A S DA=+Y S:'$D(T(2)) T(2)=""
S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
S PRCSAPP=$P(PRC("ACC"),"^",11)
S ^PRCS(410,DA,0)=$P(^PRCS(410,DA,0),U)_"^^"_T(2)_"^^"_PRC("SITE"),^PRCS(410,DA,3)=PRC("CP")_"^"_PRCSAPP,$P(^(3),"^",12)=$P(PRC("ACC"),"^",3)
S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
S ^PRCS(410,"AN",$E(PRC("CP"),1,30),DA)=""
D ERS410^PRC0G(DA_"^E")
S:T(2)'="" ^PRCS(410,"H",$E(T(2),1,30),DA)=DUZ,$P(^PRCS(410,DA,11),"^",2)=DUZ,^PRCS(410,"K",+$P(PRC("CP")," "),DA)="",$P(^PRCS(410,DA,6),"^",4)=+$P(PRC("CP")," ") K PRCSAPP
EN2B S:$D(PRC("SST")) $P(^PRCS(410,DA,0),"^",10)=PRC("SST")
D:$D(MYY) ERS410^PRC0G(DA_"^E") Q
EN3 ;INPUT TRANSFORM FOR REORDERING 410 FILE ENTRIES
;Add mod (PRC*149) to insure that the next ien used is not below 20,000,000.
;Start back at closest ien to last realistic ien using for loop check to look for last used ien when next ien is below 20,000,000.
Q:'$D(X) I $D(^PRCS(410,"B",X)) Q
N PRCSIEN
L +^PRCS(410,0):$S($G(DILOCKTM)>10:DILOCKTM,1:10) I '$T W $C(7),"ANOTHER USER IS EDITING FILE 410 CONTROL NODE! Please retry in a minute." K X Q
S PRCSIEN=$P(^PRCS(410,0),"^",3)-1
I PRCSIEN<20000000!(PRCSIEN>97999999) D S:PRCSIEN=20000000 PRCSIEN=97999999
. F I=90000000:-10000000:20000000 I $O(^PRCS(410,I))-I>1000 S PRCSIEN=$O(^PRCS(410,I)) Q
F PRCSIEN=PRCSIEN:-1 I '$D(^PRCS(410,PRCSIEN)) L +^PRCS(410,PRCSIEN):$S($D(DILOCKTM):DILOCKTM,1:3) Q:$T
L -^PRCS(410,0)
I PRCSIEN'>0 K X
E S DINUM=PRCSIEN
L -^PRCS(410,PRCSIEN)
Q
CANCK ;Look for cancelled activity when all seq used
I ZERSW=0 S ZERSW=1,T=1 G T
CK0 S ZZH=Z,ZHOLD=Z
CK1 S ZZH=$O(^PRCS(410,"B",ZZH)),IEN410=0 G CER:ZZH](Z_"-9999")
CK2 S IEN410=$O(^PRCS(410,"B",ZZH,IEN410)) G CK1:IEN410=""
I $P($G(^PRCS(410,IEN410,0)),U,2)'="CA" G CK2
S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150
S DA=IEN410,DIK="^PRCS(410," D ^DIK
S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150
S T=$P(ZZH,"-",5)
CKQ S Z=ZHOLD K DA,DIK,ZZH,ZHOLD,IEN410
G T1
CER S MSG="No open sequence number found for "_Z_" for transaction"
I $G(PRCRMPR)=1 S X="#"
K DA,DIK,ZZH,IEN410
G OUT1
CER424 ;424 AVAILABLE SLOT CHECK ;PRC*5.1*191 CHECK FOR AVAILABLE 424 ENTRIES FOR 1358
S PRCX1=$P(X,"-",1,2)_"-",PRCTT=0,PRCX3=0
F PRCI=1:1:9999 S PRCX2=PRCX1_$E("0000",1,4-$L(PRCI))_PRCI S:$D(^PRC(424,"B",PRCX2)) PRCTT=PRCTT+1 I '$D(^PRC(424,"B",PRCX2)),'PRCX3 S PRCX3=PRCI
K PRCX1,PRCX2,PRCI
I PRCTT=9999,'PRCX3 W ! S MSG="<<NO>> open sequence number available for "_Z_" for transaction entry" K PRCTT,PRCX3 G OUT1
I PRCTT>9900 D
. I 9998-PRCTT>0 D
.. W !!,"** You have ",9998-PRCTT," remaining and are dangerously close to"
.. W !,"** running out of Authorization entries in file 424."
.. W !,"** Authorizations and Liquidation REQUIRE available entries so you"
.. W !,"** should be considering closing this obligation very soon as ONLY"
.. W !,"** 9999 entries are allowed.",!
. I 9998-PRCTT=0 D
.. W !!,"** You have ZERO remaining and this is the last Authorization"
.. W !,"** you will be able to enter for this 1358 (max 9999 entries). You"
.. W !,"** will NO LONGER be able to liquidate any outstanding Authorizations."
.. W !,"** You MUST close this 1358 and open a new 1358 to cover further activity.",!
I ((PRCTT=9999)!(T>9999)),PRCX3 S T=PRCX3-1 K PRCTT,PRCX3 G T
K PRCTT,PRCX3
G TEX
W1 S %=2 Q:T4'="O" W !!,"Would you like to edit this request" D YN^DICN G W1:%=0 Q
W4 W !!,"Another user is accessing this file... Try later.",$C(7) R:$E(IOST,1,2)="C-" X:5 G EXIT
W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
EXIT K %,DA,DIC,DIE,DR,I,L,N,PRCS,PRCSAPP,PRCSDIC,PRC("FY"),PRCSL,PRCSY,PRC("QTR"),T,T1,T2,T3,T4,X,X1,Z,ZERSW Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSUT3 6471 printed Oct 16, 2024@18:19:54 Page 2
PRCSUT3 ;WISC/SAW/PLT/BGJ-TRANSACTION UTILITY PROGRAM ; 21 Apr 93 10:18 AM
V ;;5.1;IFCAP;**115,123,149,150,180,191**;Oct 20, 2000;Build 4
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
+4 ;kill (DIK) since DIK call does not handle descending file logic
+5 ;
+6 ;PRC*5.1*180 RGB 10/22/12 Added switch coming from IFCAP 1358
+7 ;processing to insure new entry check uses file 424, not file 410.
+8 ;
+9 ;PRC*5.1*191 RGB 6/12/14 Added check to file 424 new entry check
+10 ; that the user is alerted when there are
+11 ; only approx 100 entries left so they can
+12 ; finalize obligation for liquidation which
+13 ; needs extra file 424 entries available.
+14 ; Also added check for next sequence number
+15 ; for 1358 in 410.1 being 9999, reset to
+16 ; 9998 so don't hit the 10000 barrier with
+17 ; with original node seq plus 1.
+18 ;
EN ;CREATE NEW TRANSACTION NUMBER
+1 DO EN1^PRCSUT
KILL DA,DIC
if '$DATA(PRC("SITE"))
GOTO W5
QUIT
EN1 if '$DATA(X)
GOTO OUT1
SET NODE=0
SET PIECE=2
IF $DATA(PRCS("TYPE"))
if 'X
GOTO OUT1
SET T(1)=$ORDER(^DD(410.1,"B",PRCS("TYPE"),0))
if 'T(1)!('$DATA(^DD(410.1,+T(1),0)))
GOTO OUT1
+1 SET DIC="^PRCS(410.1,"
SET MSG=""
SET ZERSW=0
+2 ;I $D(^PRCS(410.1,"B",X)) S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N L +^PRCS410.1,N):15 G:$T=0 OUT1 S T=$P(^PRCS(410.1,N,NODE),"^",PIECE)+1 S:T<1 T=1 L -^PRCS(410.1,N))
+3 ;PRC*5.1*191
IF $DATA(^PRCS(410.1,"B",X))
SET N=""
SET N=$ORDER(^PRCS(410.1,"B",X,N))
SET DA=N
SET T=$PIECE(^PRCS(410.1,N,NODE),"^",PIECE)+1
if T>9999&(X'["FC")
SET T=9999
if T<1
SET T=1
+4 IF '$DATA(^PRCS(410.1,"B",X))
SET T=1
SET DLAYGO=410.1
SET DIC="^PRCS(410.1,"
SET DIC(0)="FLXZ"
DO ^DIC
KILL DLAYGO
if Y<0
GOTO W4
SET DA=+Y
+5 SET HDA=DA
T SET T="000"_T
SET T=$EXTRACT(T,$LENGTH(T)-3,$LENGTH(T))
T1 ;PRC*5.1*180
IF $DATA(REP)
IF $GET(PRCE424)'=1
SET X=X_"-"_T
IF $DATA(^PRCS(410,"B",X))
SET T=+T+1
SET X=$PIECE(X,"-",1,4)
if T>9999
GOTO CANCK
GOTO T
+1 ;PRC*5.1*180
IF '$DATA(REP)
IF '$DATA(PRCS("TYPE"))
IF $GET(PRCE424)'=1
SET X=Z
SET X=X_"-"_T
IF $DATA(^PRCS(410,"B",X))
SET T=+T+1
if T>9999
GOTO CANCK
GOTO T
+2 ;PRC*5.1*180, PRC*5.1*191
IF ('$DATA(REP)&$DATA(PRCS("TYPE")))!($GET(PRCE424)=1)
SET Z=X
SET X=X_"-"_T
IF $DATA(^PRC(424,"B",X))
SET T=+T+1
SET X=Z
if T>9999
GOTO CER424
GOTO T
+3 ;PRC*5.1*191
IF ('$DATA(REP)&$DATA(PRCS("TYPE")))!($GET(PRCE424)=1)
IF T>9900
GOTO CER424
TEX SET DA=HDA
LOCK +^PRCS(410.1,DA):15
SET $PIECE(^PRCS(410.1,DA,NODE),U,PIECE)=+T
SET $PIECE(^(0),U,3)=DT
LOCK -^PRCS(410.1,DA)
OUT KILL DA,DIC,N,NODE,PIECE,PRCS("TYPE"),PRCSL,T,Z,HDA
QUIT
OUT1 SET X=""
SET Y=-1
DO OUT
QUIT
EN2 ;add record in file 410
+1 SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="LXZ"
DO ^DIC
KILL DLAYGO
if Y<0
GOTO W4
EN2A SET DA=+Y
if '$DATA(T(2))
SET T(2)=""
+1 SET PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+2 SET PRCSAPP=$PIECE(PRC("ACC"),"^",11)
+3 SET ^PRCS(410,DA,0)=$PIECE(^PRCS(410,DA,0),U)_"^^"_T(2)_"^^"_PRC("SITE")
SET ^PRCS(410,DA,3)=PRC("CP")_"^"_PRCSAPP
SET $PIECE(^(3),"^",12)=$PIECE(PRC("ACC"),"^",3)
+4 SET $PIECE(^PRCS(410,DA,3),"^",11)=$PIECE($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
+5 SET ^PRCS(410,"AN",$EXTRACT(PRC("CP"),1,30),DA)=""
+6 DO ERS410^PRC0G(DA_"^E")
+7 if T(2)'=""
SET ^PRCS(410,"H",$EXTRACT(T(2),1,30),DA)=DUZ
SET $PIECE(^PRCS(410,DA,11),"^",2)=DUZ
SET ^PRCS(410,"K",+$PIECE(PRC("CP")," "),DA)=""
SET $PIECE(^PRCS(410,DA,6),"^",4)=+$PIECE(PRC("CP")," ")
KILL PRCSAPP
EN2B if $DATA(PRC("SST"))
SET $PIECE(^PRCS(410,DA,0),"^",10)=PRC("SST")
+1 if $DATA(MYY)
DO ERS410^PRC0G(DA_"^E")
QUIT
EN3 ;INPUT TRANSFORM FOR REORDERING 410 FILE ENTRIES
+1 ;Add mod (PRC*149) to insure that the next ien used is not below 20,000,000.
+2 ;Start back at closest ien to last realistic ien using for loop check to look for last used ien when next ien is below 20,000,000.
+3 if '$DATA(X)
QUIT
IF $DATA(^PRCS(410,"B",X))
QUIT
+4 NEW PRCSIEN
+5 LOCK +^PRCS(410,0):$SELECT($GET(DILOCKTM)>10:DILOCKTM,1:10)
IF '$TEST
WRITE $CHAR(7),"ANOTHER USER IS EDITING FILE 410 CONTROL NODE! Please retry in a minute."
KILL X
QUIT
+6 SET PRCSIEN=$PIECE(^PRCS(410,0),"^",3)-1
+7 IF PRCSIEN<20000000!(PRCSIEN>97999999)
Begin DoDot:1
+8 FOR I=90000000:-10000000:20000000
IF $ORDER(^PRCS(410,I))-I>1000
SET PRCSIEN=$ORDER(^PRCS(410,I))
QUIT
End DoDot:1
if PRCSIEN=20000000
SET PRCSIEN=97999999
+9 FOR PRCSIEN=PRCSIEN:-1
IF '$DATA(^PRCS(410,PRCSIEN))
LOCK +^PRCS(410,PRCSIEN):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if $TEST
QUIT
+10 LOCK -^PRCS(410,0)
+11 IF PRCSIEN'>0
KILL X
+12 IF '$TEST
SET DINUM=PRCSIEN
+13 LOCK -^PRCS(410,PRCSIEN)
+14 QUIT
CANCK ;Look for cancelled activity when all seq used
+1 IF ZERSW=0
SET ZERSW=1
SET T=1
GOTO T
CK0 SET ZZH=Z
SET ZHOLD=Z
CK1 SET ZZH=$ORDER(^PRCS(410,"B",ZZH))
SET IEN410=0
if ZZH](Z_"-9999")
GOTO CER
CK2 SET IEN410=$ORDER(^PRCS(410,"B",ZZH,IEN410))
if IEN410=""
GOTO CK1
+1 IF $PIECE($GET(^PRCS(410,IEN410,0)),U,2)'="CA"
GOTO CK2
+2 ;PRC*5.1*150
SET PRCIENCT=$PIECE(^PRCS(410,0),"^",3)+1
+3 SET DA=IEN410
SET DIK="^PRCS(410,"
DO ^DIK
+4 ;PRC*5.1*150
SET $PIECE(^PRCS(410,0),"^",3)=PRCIENCT
KILL PRCIENCT
+5 SET T=$PIECE(ZZH,"-",5)
CKQ SET Z=ZHOLD
KILL DA,DIK,ZZH,ZHOLD,IEN410
+1 GOTO T1
CER SET MSG="No open sequence number found for "_Z_" for transaction"
+1 IF $GET(PRCRMPR)=1
SET X="#"
+2 KILL DA,DIK,ZZH,IEN410
+3 GOTO OUT1
CER424 ;424 AVAILABLE SLOT CHECK ;PRC*5.1*191 CHECK FOR AVAILABLE 424 ENTRIES FOR 1358
+1 SET PRCX1=$PIECE(X,"-",1,2)_"-"
SET PRCTT=0
SET PRCX3=0
+2 FOR PRCI=1:1:9999
SET PRCX2=PRCX1_$EXTRACT("0000",1,4-$LENGTH(PRCI))_PRCI
if $DATA(^PRC(424,"B",PRCX2))
SET PRCTT=PRCTT+1
IF '$DATA(^PRC(424,"B",PRCX2))
IF 'PRCX3
SET PRCX3=PRCI
+3 KILL PRCX1,PRCX2,PRCI
+4 IF PRCTT=9999
IF 'PRCX3
WRITE !
SET MSG="<<NO>> open sequence number available for "_Z_" for transaction entry"
KILL PRCTT,PRCX3
GOTO OUT1
+5 IF PRCTT>9900
Begin DoDot:1
+6 IF 9998-PRCTT>0
Begin DoDot:2
+7 WRITE !!,"** You have ",9998-PRCTT," remaining and are dangerously close to"
+8 WRITE !,"** running out of Authorization entries in file 424."
+9 WRITE !,"** Authorizations and Liquidation REQUIRE available entries so you"
+10 WRITE !,"** should be considering closing this obligation very soon as ONLY"
+11 WRITE !,"** 9999 entries are allowed.",!
End DoDot:2
+12 IF 9998-PRCTT=0
Begin DoDot:2
+13 WRITE !!,"** You have ZERO remaining and this is the last Authorization"
+14 WRITE !,"** you will be able to enter for this 1358 (max 9999 entries). You"
+15 WRITE !,"** will NO LONGER be able to liquidate any outstanding Authorizations."
+16 WRITE !,"** You MUST close this 1358 and open a new 1358 to cover further activity.",!
End DoDot:2
End DoDot:1
+17 IF ((PRCTT=9999)!(T>9999))
IF PRCX3
SET T=PRCX3-1
KILL PRCTT,PRCX3
GOTO T
+18 KILL PRCTT,PRCX3
+19 GOTO TEX
W1 SET %=2
if T4'="O"
QUIT
WRITE !!,"Would you like to edit this request"
DO YN^DICN
if %=0
GOTO W1
QUIT
W4 WRITE !!,"Another user is accessing this file... Try later.",$CHAR(7)
if $EXTRACT(IOST,1,2)="C-"
READ X:5
GOTO EXIT
W5 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
READ X:5
EXIT KILL %,DA,DIC,DIE,DR,I,L,N,PRCS,PRCSAPP,PRCSDIC,PRC("FY"),PRCSL,PRCSY,PRC("QTR"),T,T1,T2,T3,T4,X,X1,Z,ZERSW
QUIT
