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