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 Apr 09, 2024@21:18:20 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 ;
