PRCSUT31.m

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 ---PRCSUT31   1230     printed  Apr 09, 2024@21:13:48                                                                                                                                                                                                    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