Routine: PRC5B3

PRC5B3 ;WISC/PLT-PRC5B continue ; 10/14/94  9:47 AM

V ;;5.0;IFCAP;;4/21/95

 QUIT  ;invalid entry

PAC ;set-up fcp/prj dic (called by prc5b)

 N PRCRI,PRCA,PRCB,PRCC,PRCSTRI

 D EN^DDIOL("POST INITIAL: Process FMS PAC-DOCUMENT"_" at "_$$NOW^PRC5A)

 S PRCSTRI=$O(^PRCD(420.1999,"AC","A",""))

 S PRCRI(420.92)=0 F  S PRCRI(420.92)=$O(^PRCU(420.92,"B","PAC",PRCRI(420.92))) Q:'PRCRI(420.92)  S PRCA=^PRCU(420.92,PRCRI(420.92),0) D:$P(PRCA,"^",4)]""&($P(PRCA,"^",6)="")

 . D ED^PRC5B1(PRCRI(420.92),1)

 . S PRCRI(420.923)=0

 . F  S PRCRI(420.923)=$O(^PRCU(420.92,PRCRI(420.92),1,PRCRI(420.923))) Q:'PRCRI(420.923)  D:$P(^(PRCRI(420.923),0),"^",2)="" PACED(PRCRI(420.92),PRCRI(420.923))

 . D ED^PRC5B1(PRCRI(420.92),2)

 D EN^DDIOL("POST INITIAL: Process FMS PAC-DOCUMENT done!"_" at "_$$NOW^PRC5A)

 QUIT

PACED(PRCA,PRCB) ;set-up fcp/prj dic (station related)

 N PRCRI,PRCSITE,PRCACC,PRCACCD,A

 S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCSITE=$P(A,"~",3),PRCACC=$P(A,"~",4),PRCACCD=$P(A,"~",5)

 Q:PRCSITE=""!(PRCACC="")

 Q:'$D(^PRC(411,+PRCSITE))

 S PRCRI(420.131)=$O(^PRCD(420.131,"B",PRCACC,""))

 I PRCRI(420.131)="" D  QUIT:PRCRI(420.131)<1

 . N X,Y

 . S X=PRCACC,X("DR")="1////"_PRCACCD_";2////"_PRCSTRI

 . D ADD^PRC0B1(.X,.Y,"420.131;^PRCD(420.131,")

 . S:Y PRCRI(420.131)=+Y

 . QUIT

 D ED1^PRC5B1(PRCA,PRCB) ;edit convert field

 QUIT

CC ;deactivate the cost cent 6-digit codes without ending '00'

 N PRCRI,PRCA

 D EN^DDIOL("POST INITIAL: DEACTIVATE SUBCOSTCENT STARTS at "_$$NOW^PRC5A)

 S PRCRI(420.1)=0 F  S PRCRI(420.1)=$O(^PRCD(420.1,PRCRI(420.1))) Q:'PRCRI(420.1)  S A=^(PRCRI(420.1),0) D

 . S PRCA=$P(A," ") QUIT:$E(PRCA,5,6)<1

 . D EDIT^PRC0B(.X,"420.1;;"_PRCRI(420.1),".5////1")

 . QUIT

 D EN^DDIOL("POST INITIAL: DEACTIVATE SUBCOSTCENT ENDS at "_$$NOW^PRC5A)

 QUIT

SUB ;add entry to file 420.137 (called from prc5b)

 N PRCRI,PRCA,PRCB,PRCC,PRCSTRI

 D EN^DDIOL("POST INITIAL: Process FMS SUB-DOCUMENT at "_$$NOW^PRC5A)

 S PRCSTRI=$O(^PRCD(420.1999,"AC","A",""))

 S PRCRI(420.92)=0 F  S PRCRI(420.92)=$O(^PRCU(420.92,"B","SUB",PRCRI(420.92))) Q:'PRCRI(420.92)  S PRCA=^PRCU(420.92,PRCRI(420.92),0) D:$P(PRCA,"^",4)]""&($P(PRCA,"^",6)="")

 . D ED^PRC5B1(PRCRI(420.92),1)

 . S PRCRI(420.923)=0

 . F  S PRCRI(420.923)=$O(^PRCU(420.92,PRCRI(420.92),1,PRCRI(420.923))) Q:'PRCRI(420.923)  D:$P(^(PRCRI(420.923),0),"^",2)="" SUBED(PRCRI(420.92),PRCRI(420.923))

 . D ED^PRC5B1(PRCRI(420.92),2)

 D EN^DDIOL("POST INITIAL: Process FMS SUB-DOCUMENT done!"_" at "_$$NOW^PRC5A)

 QUIT

SUBED(PRCA,PRCB) ;set -up sub-obj dic

 N PRCRI,PRCSUB,PRCSUBD,A

 S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCSUB=$P(A,"~",3)_$P(A,"~",4),PRCSUBD=$P(A,"~",5)

 QUIT:PRCSUB=""

 S PRCRI(420.137)=$O(^PRCD(420.137,"B",PRCSUB,""))

 I PRCRI(420.137)="" D  QUIT:PRCRI(420.137)<1

 . N X,Y

 . S X=PRCSUB,X("DR")="1////"_PRCSUBD_";2////"_PRCSTRI

 . D ADD^PRC0B1(.X,.Y,"420.137;^PRCD(420.137,")

 . S:Y PRCRI(420.137)=+Y

 . QUIT

 D ED1^PRC5B1(PRCA,PRCB) ;edit convert field

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC5B3   3011     printed  Mar 13, 2025@21:04:40                                                                                                                                                                                                      Page 2

PRC5B3    ;WISC/PLT-PRC5B continue ; 10/14/94  9:47 AM

V         ;;5.0;IFCAP;;4/21/95

 +1       ;invalid entry

           QUIT

 +2       ;

PAC       ;set-up fcp/prj dic (called by prc5b)

 +1        NEW PRCRI,PRCA,PRCB,PRCC,PRCSTRI

 +2        DO EN^DDIOL("POST INITIAL: Process FMS PAC-DOCUMENT"_" at "_$$NOW^PRC5A)

 +3        SET PRCSTRI=$ORDER(^PRCD(420.1999,"AC","A",""))

 +4        SET PRCRI(420.92)=0

FOR

               SET PRCRI(420.92)=$ORDER(^PRCU(420.92,"B","PAC",PRCRI(420.92)))

               if 'PRCRI(420.92)

                   QUIT

               SET PRCA=^PRCU(420.92,PRCRI(420.92),0)

               if $PIECE(PRCA,"^",4)]""&($PIECE(PRCA,"^",6)="")

                   Begin DoDot:1

 +5                    DO ED^PRC5B1(PRCRI(420.92),1)

 +6                    SET PRCRI(420.923)=0

 +7                    FOR

                           SET PRCRI(420.923)=$ORDER(^PRCU(420.92,PRCRI(420.92),1,PRCRI(420.923)))

                           if 'PRCRI(420.923)

                               QUIT

                           if $PIECE(^(PRCRI(420.923),0),"^",2)=""

                               DO PACED(PRCRI(420.92),PRCRI(420.923))

 +8                    DO ED^PRC5B1(PRCRI(420.92),2)

                   End DoDot:1

 +9        DO EN^DDIOL("POST INITIAL: Process FMS PAC-DOCUMENT done!"_" at "_$$NOW^PRC5A)

 +10       QUIT

 +11      ;

PACED(PRCA,PRCB) ;set-up fcp/prj dic (station related)

 +1        NEW PRCRI,PRCSITE,PRCACC,PRCACCD,A

 +2        SET A=^PRCU(420.92,PRCA,1,PRCB,1)

           SET PRCSITE=$PIECE(A,"~",3)

           SET PRCACC=$PIECE(A,"~",4)

           SET PRCACCD=$PIECE(A,"~",5)

 +3        if PRCSITE=""!(PRCACC="")

               QUIT

 +4        if '$DATA(^PRC(411,+PRCSITE))

               QUIT

 +5        SET PRCRI(420.131)=$ORDER(^PRCD(420.131,"B",PRCACC,""))

 +6        IF PRCRI(420.131)=""

               Begin DoDot:1

 +7                NEW X,Y

 +8                SET X=PRCACC

                   SET X("DR")="1////"_PRCACCD_";2////"_PRCSTRI

 +9                DO ADD^PRC0B1(.X,.Y,"420.131;^PRCD(420.131,")

 +10               if Y

                       SET PRCRI(420.131)=+Y

 +11               QUIT

               End DoDot:1

               if PRCRI(420.131)<1

                   QUIT

 +12      ;edit convert field

           DO ED1^PRC5B1(PRCA,PRCB)

 +13       QUIT

 +14      ;

 +15      ;

CC        ;deactivate the cost cent 6-digit codes without ending '00'

 +1        NEW PRCRI,PRCA

 +2        DO EN^DDIOL("POST INITIAL: DEACTIVATE SUBCOSTCENT STARTS at "_$$NOW^PRC5A)

 +3        SET PRCRI(420.1)=0

FOR

               SET PRCRI(420.1)=$ORDER(^PRCD(420.1,PRCRI(420.1)))

               if 'PRCRI(420.1)

                   QUIT

               SET A=^(PRCRI(420.1),0)

               Begin DoDot:1

 +4                SET PRCA=$PIECE(A," ")

                   if $EXTRACT(PRCA,5,6)<1

                       QUIT

 +5                DO EDIT^PRC0B(.X,"420.1;;"_PRCRI(420.1),".5////1")

 +6                QUIT

               End DoDot:1

 +7        DO EN^DDIOL("POST INITIAL: DEACTIVATE SUBCOSTCENT ENDS at "_$$NOW^PRC5A)

 +8        QUIT

 +9       ;

SUB       ;add entry to file 420.137 (called from prc5b)

 +1        NEW PRCRI,PRCA,PRCB,PRCC,PRCSTRI

 +2        DO EN^DDIOL("POST INITIAL: Process FMS SUB-DOCUMENT at "_$$NOW^PRC5A)

 +3        SET PRCSTRI=$ORDER(^PRCD(420.1999,"AC","A",""))

 +4        SET PRCRI(420.92)=0

FOR

               SET PRCRI(420.92)=$ORDER(^PRCU(420.92,"B","SUB",PRCRI(420.92)))

               if 'PRCRI(420.92)

                   QUIT

               SET PRCA=^PRCU(420.92,PRCRI(420.92),0)

               if $PIECE(PRCA,"^",4)]""&($PIECE(PRCA,"^",6)="")

                   Begin DoDot:1

 +5                    DO ED^PRC5B1(PRCRI(420.92),1)

 +6                    SET PRCRI(420.923)=0

 +7                    FOR

                           SET PRCRI(420.923)=$ORDER(^PRCU(420.92,PRCRI(420.92),1,PRCRI(420.923)))

                           if 'PRCRI(420.923)

                               QUIT

                           if $PIECE(^(PRCRI(420.923),0),"^",2)=""

                               DO SUBED(PRCRI(420.92),PRCRI(420.923))

 +8                    DO ED^PRC5B1(PRCRI(420.92),2)

                   End DoDot:1

 +9        DO EN^DDIOL("POST INITIAL: Process FMS SUB-DOCUMENT done!"_" at "_$$NOW^PRC5A)

 +10       QUIT

 +11      ;

SUBED(PRCA,PRCB) ;set -up sub-obj dic

 +1        NEW PRCRI,PRCSUB,PRCSUBD,A

 +2        SET A=^PRCU(420.92,PRCA,1,PRCB,1)

           SET PRCSUB=$PIECE(A,"~",3)_$PIECE(A,"~",4)

           SET PRCSUBD=$PIECE(A,"~",5)

 +3        if PRCSUB=""

               QUIT

 +4        SET PRCRI(420.137)=$ORDER(^PRCD(420.137,"B",PRCSUB,""))

 +5        IF PRCRI(420.137)=""

               Begin DoDot:1

 +6                NEW X,Y

 +7                SET X=PRCSUB

                   SET X("DR")="1////"_PRCSUBD_";2////"_PRCSTRI

 +8                DO ADD^PRC0B1(.X,.Y,"420.137;^PRCD(420.137,")

 +9                if Y

                       SET PRCRI(420.137)=+Y

 +10               QUIT

               End DoDot:1

               if PRCRI(420.137)<1

                   QUIT

 +11      ;edit convert field

           DO ED1^PRC5B1(PRCA,PRCB)

 +12       QUIT

 +13      ;

PRC5B3.m