- 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 Jan 18, 2025@03:20:21 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