PRCSUT31 ;WISC/CTB/ISC6/LJP/WISC/CLH-TRANSACTION UTILITY PROGRAM ;4/30/92 9:19 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;RETRIEVE NEXT SEQUENCE NUMBER
EN1 G:'$D(X) OUT1 G:'$D(PRCS("TYPE")) OUT1 G:'X OUT1 I $O(^PRC(442,"B",X,0))'>0 S (X,Y)="" G OUT
S T(1)=$O(^DD(410.1,"B",PRCS("TYPE"),0)) G:'T(1)!('$D(^DD(410.1,+T(1),0))) OUT1 S T(1)=$P(^(0),U,4),NODE(1)=+T(1),PIECE(1)=$P(T(1),";",2)
S DIC="^PRCS(410.1," I $D(^PRCS(410.1,"B",X)) S N="",N=$O(^PRCS(410.1,"B",X,N)),DA=N
I '$D(^PRCS(410.1,"B",X)) S DLAYGO=410.1,DIC="^PRCS(410.1,",DIC(0)="FLXZ" D ^DIC K DLAYGO G:Y<0 OUT1 S DA=+Y,X=$P(Y,U,2)
L +^PRCS(410.1,DA,0):15 G:$T=0 OUT
S Z=X,T=$P(^PRCS(410.1,DA,NODE(1)),"^",PIECE(1))+1 S:T'>$P(^(0),U,2) T=$P(^(0),U,2)+1 S:T<1 T=1
T S T="000"_T,T=$E(T,$L(T)-3,$L(T))
S X=X_"-"_T I $D(^PRC(424,"B",X))!$D(^PRCS(410,"B",X))!$D(^PRC(442,"B",X)) S T=+T+1,X=Z G T
S $P(^PRCS(410.1,DA,NODE(1)),U,PIECE(1))=+T,$P(^(0),U,2)=+T,$P(^(0),U,3)=DT S Y=T L -^PRCS(410.1,DA,0)
OUT K DA,DIC,N,NODE,PIECE,PRCS("TYPE"),PRCSL,T,Z Q
OUT1 S X="",Y=-1 D OUT Q
EXIT K %,DA,DIC,DIE,DR,I,L,N,PRCS,PRCSAPP,PRCSIP,PRCSDIC,PRC("FY"),PRCSL,PRCSNW,PRC("QTR"),T,T0,T1,T2,T3,T4,X,X1,Z Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSUT31 1230 printed Dec 13, 2024@02:19:11 Page 2
PRCSUT31 ;WISC/CTB/ISC6/LJP/WISC/CLH-TRANSACTION UTILITY PROGRAM ;4/30/92 9:19 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;RETRIEVE NEXT SEQUENCE NUMBER
EN1 if '$DATA(X)
GOTO OUT1
if '$DATA(PRCS("TYPE"))
GOTO OUT1
if 'X
GOTO OUT1
IF $ORDER(^PRC(442,"B",X,0))'>0
SET (X,Y)=""
GOTO OUT
+1 SET T(1)=$ORDER(^DD(410.1,"B",PRCS("TYPE"),0))
if 'T(1)!('$DATA(^DD(410.1,+T(1),0)))
GOTO OUT1
SET T(1)=$PIECE(^(0),U,4)
SET NODE(1)=+T(1)
SET PIECE(1)=$PIECE(T(1),";",2)
+2 SET DIC="^PRCS(410.1,"
IF $DATA(^PRCS(410.1,"B",X))
SET N=""
SET N=$ORDER(^PRCS(410.1,"B",X,N))
SET DA=N
+3 IF '$DATA(^PRCS(410.1,"B",X))
SET DLAYGO=410.1
SET DIC="^PRCS(410.1,"
SET DIC(0)="FLXZ"
DO ^DIC
KILL DLAYGO
if Y<0
GOTO OUT1
SET DA=+Y
SET X=$PIECE(Y,U,2)
+4 LOCK +^PRCS(410.1,DA,0):15
if $TEST=0
GOTO OUT
+5 SET Z=X
SET T=$PIECE(^PRCS(410.1,DA,NODE(1)),"^",PIECE(1))+1
if T'>$PIECE(^(0),U,2)
SET T=$PIECE(^(0),U,2)+1
if T<1
SET T=1
T SET T="000"_T
SET T=$EXTRACT(T,$LENGTH(T)-3,$LENGTH(T))
+1 SET X=X_"-"_T
IF $DATA(^PRC(424,"B",X))!$DATA(^PRCS(410,"B",X))!$DATA(^PRC(442,"B",X))
SET T=+T+1
SET X=Z
GOTO T
+2 SET $PIECE(^PRCS(410.1,DA,NODE(1)),U,PIECE(1))=+T
SET $PIECE(^(0),U,2)=+T
SET $PIECE(^(0),U,3)=DT
SET Y=T
LOCK -^PRCS(410.1,DA,0)
OUT KILL DA,DIC,N,NODE,PIECE,PRCS("TYPE"),PRCSL,T,Z
QUIT
OUT1 SET X=""
SET Y=-1
DO OUT
QUIT
EXIT KILL %,DA,DIC,DIE,DR,I,L,N,PRCS,PRCSAPP,PRCSIP,PRCSDIC,PRC("FY"),PRCSL,PRCSNW,PRC("QTR"),T,T0,T1,T2,T3,T4,X,X1,Z
QUIT
