PRC5B1 ;WISC/PLT-PRC5B continue ; 07/07/94 2:47 PM
V ;;5.0;IFCAP;;4/21/95
QUIT ;invalid entry
;
ALD ;called by PRC5B
N PRCA,PRCB,PRCC
D EN^DDIOL("POST INITIAL: Move name (.01) to ald (5) for file 420.3"_" at "_$$NOW^PRC5A)
S PRCA=0 F S PRCA=$O(^PRCD(420.3,PRCA)) Q:'PRCA S PRCB=^(PRCA,0) D:$P(PRCB,"^",7)=""&($P(PRCB,"^",6)="")
. S PRCC=$P(PRCB,"^")
. D EDIT^PRC0B(.X,"420.3;;"_PRCA,"5///^S X="""_PRCC_"""")
. QUIT
D EN^DDIOL("POST INITIAL: Move name (.01) to ald (5) for file 420.3 DONE"_" at "_$$NOW^PRC5A)
QUIT
;
FND ;add fund code to file 420.3
N PRCRI,PRCA,PRCB,PRCC,PRCSTRI
D EN^DDIOL("POST INITIAL: Process FMS FND-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","FND",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(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)="" FNDED(PRCRI(420.92),PRCRI(420.923))
. D ED(PRCRI(420.92),2)
D EN^DDIOL("POST INITIAL: Process FMS FND-DOCUMENT done!"_" at "_$$NOW^PRC5A)
QUIT
;
FNDED(PRCA,PRCB) ;start convert
N PRCRI,PRCAPP,PRCFUND,PRCFUNDD,PRCYB,PRCYE,A
S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCAPP=$P(A,"~",2),PRCFUND=$P(A,"~",5)
S PRCYB=+$$YEAR^PRC0C($P(A,"~",3)),PRCYE=+$$YEAR^PRC0C($S($P(A,"~",4):$P(A,"~",4),1:PRCYB)),PRCFUNDD=$P(A,"~",6)
Q:PRCAPP=""!(PRCFUND="")!'PRCYB!'PRCYE
;add/edit fund file 420.14
S PRCRI(420.14)=$O(^PRCD(420.14,"UNQ",PRCFUND,PRCYB,PRCYE,"")) D QUIT:'PRCRI(420.14)
. I PRCRI(420.14) D EDIT^PRC0B(.X,"420.14;;"_PRCRI(420.14),"1///^S X="""_PRCFUNDD_"""") I 1
. E S (PRCUQ,PRCK01,PRCK2,PRCK3)="" D
.. S X=PRCFUND,X("DR")="1////"_PRCFUNDD_";2///^S X="""_PRCYB_""";3///^S X="""_PRCYE_""";5////"_PRCSTRI
.. D ADD^PRC0B1(.X,.Y,"420.14;^PRCD(420.14,")
.. S:Y>0 PRCRI(420.14)=+Y
.. Q
. Q
S PRCRI(420.3)=0 F S PRCRI(420.3)=$O(^PRCD(420.3,"B",PRCFUND,PRCRI(420.3))) Q:'PRCRI(420.3) Q:$P($G(^PRCD(420.3,PRCRI(420.3),0)),"^",6)=""
I 'PRCRI(420.3) D QUIT:'PRCRI(420.3)
. S X=PRCFUND,X("DR")="2////"_PRCAPP_";4////"_$TR(PRCAPP,"_"," ")
. D ADD^PRC0B1(.X,.Y,"420.3;^PRCD(420.3,")
. S:Y>0 PRCRI(420.3)=+Y
D ED1(PRCA,PRCB) ;edit convert field
QUIT
;
PCL ;set-up program dic (called from prc5a)
N PRCRI,PRCA,PRCB,PRCC,PRCSTRI
D EN^DDIOL("POST INITIAL: Process FMS PCL-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","PCL",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(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)="" PCLED(PRCRI(420.92),PRCRI(420.923))
. D ED(PRCRI(420.92),2)
D EN^DDIOL("POST INITIAL: Process FMS PCL-DOCUMENT done!"_" at "_$$NOW^PRC5A)
QUIT
;
PCLED(PRCA,PRCB) ;set-up program dic
N PRCRI,PRCPGM,PRCPGMD,A
S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCPGM=$P(A,"~",3),PRCPGMD=$P(A,"~",4)
Q:PRCPGM=""
S PRCRI(420.13)=$O(^PRCD(420.13,"B",PRCPGM,""))
I PRCRI(420.13)="" D QUIT:'PRCRI(420.13)
. N X,Y
. S X=PRCPGM,X("DR")="1////"_PRCPGMD_";2////"_PRCSTRI
. D ADD^PRC0B1(.X,.Y,"420.13;^PRCD(420.13,")
. S:Y>0 PRCRI(420.13)=+Y
. QUIT
D ED1(PRCA,PRCB) ;edit convert field
QUIT
;
PAC ;set-up fcp/prj dic (called by prc5a)
G PAC^PRC5B3
QUIT
;
CPF ;fill-in fms fields in file 420 (fcp file) (called from prc5a)
G CPF^PRC5B2
;
QUIT
;
ED(PRCA,PRCB) ;edit convert start/end time,PRCA=RI, PRCB=1 if start, 2 if end
S PRCB=$S(PRCB=1:2.6,1:2.7)
D EDIT^PRC0B(.X,"420.92;;"_PRCA,PRCB_"///^S X=""N""")
QUIT
;
ED1(PRCA,PRCB) ;edit converted y/n
N A
S A="420.92;^PRCU(420.92,;"_PRCA
S A=A_"~"_"420.923;^PRCU(420.92,"_PRCA_",1,;"_PRCB
D EDIT^PRC0B(.X,A,"2////Y")
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC5B1 4023 printed Sep 23, 2025@19:35:53 Page 2
PRC5B1 ;WISC/PLT-PRC5B continue ; 07/07/94 2:47 PM
V ;;5.0;IFCAP;;4/21/95
+1 ;invalid entry
QUIT
+2 ;
ALD ;called by PRC5B
+1 NEW PRCA,PRCB,PRCC
+2 DO EN^DDIOL("POST INITIAL: Move name (.01) to ald (5) for file 420.3"_" at "_$$NOW^PRC5A)
+3 SET PRCA=0
FOR
SET PRCA=$ORDER(^PRCD(420.3,PRCA))
if 'PRCA
QUIT
SET PRCB=^(PRCA,0)
if $PIECE(PRCB,"^",7)=""&($PIECE(PRCB,"^",6)="")
Begin DoDot:1
+4 SET PRCC=$PIECE(PRCB,"^")
+5 DO EDIT^PRC0B(.X,"420.3;;"_PRCA,"5///^S X="""_PRCC_"""")
+6 QUIT
End DoDot:1
+7 DO EN^DDIOL("POST INITIAL: Move name (.01) to ald (5) for file 420.3 DONE"_" at "_$$NOW^PRC5A)
+8 QUIT
+9 ;
FND ;add fund code to file 420.3
+1 NEW PRCRI,PRCA,PRCB,PRCC,PRCSTRI
+2 DO EN^DDIOL("POST INITIAL: Process FMS FND-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","FND",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(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 FNDED(PRCRI(420.92),PRCRI(420.923))
+8 DO ED(PRCRI(420.92),2)
End DoDot:1
+9 DO EN^DDIOL("POST INITIAL: Process FMS FND-DOCUMENT done!"_" at "_$$NOW^PRC5A)
+10 QUIT
+11 ;
FNDED(PRCA,PRCB) ;start convert
+1 NEW PRCRI,PRCAPP,PRCFUND,PRCFUNDD,PRCYB,PRCYE,A
+2 SET A=^PRCU(420.92,PRCA,1,PRCB,1)
SET PRCAPP=$PIECE(A,"~",2)
SET PRCFUND=$PIECE(A,"~",5)
+3 SET PRCYB=+$$YEAR^PRC0C($PIECE(A,"~",3))
SET PRCYE=+$$YEAR^PRC0C($SELECT($PIECE(A,"~",4):$PIECE(A,"~",4),1:PRCYB))
SET PRCFUNDD=$PIECE(A,"~",6)
+4 if PRCAPP=""!(PRCFUND="")!'PRCYB!'PRCYE
QUIT
+5 ;add/edit fund file 420.14
+6 SET PRCRI(420.14)=$ORDER(^PRCD(420.14,"UNQ",PRCFUND,PRCYB,PRCYE,""))
Begin DoDot:1
+7 IF PRCRI(420.14)
DO EDIT^PRC0B(.X,"420.14;;"_PRCRI(420.14),"1///^S X="""_PRCFUNDD_"""")
IF 1
+8 IF '$TEST
SET (PRCUQ,PRCK01,PRCK2,PRCK3)=""
Begin DoDot:2
+9 SET X=PRCFUND
SET X("DR")="1////"_PRCFUNDD_";2///^S X="""_PRCYB_""";3///^S X="""_PRCYE_""";5////"_PRCSTRI
+10 DO ADD^PRC0B1(.X,.Y,"420.14;^PRCD(420.14,")
+11 if Y>0
SET PRCRI(420.14)=+Y
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
if 'PRCRI(420.14)
QUIT
+14 SET PRCRI(420.3)=0
FOR
SET PRCRI(420.3)=$ORDER(^PRCD(420.3,"B",PRCFUND,PRCRI(420.3)))
if 'PRCRI(420.3)
QUIT
if $PIECE($GET(^PRCD(420.3,PRCRI(420.3),0)),"^",6)=""
QUIT
+15 IF 'PRCRI(420.3)
Begin DoDot:1
+16 SET X=PRCFUND
SET X("DR")="2////"_PRCAPP_";4////"_$TRANSLATE(PRCAPP,"_"," ")
+17 DO ADD^PRC0B1(.X,.Y,"420.3;^PRCD(420.3,")
+18 if Y>0
SET PRCRI(420.3)=+Y
End DoDot:1
if 'PRCRI(420.3)
QUIT
+19 ;edit convert field
DO ED1(PRCA,PRCB)
+20 QUIT
+21 ;
PCL ;set-up program dic (called from prc5a)
+1 NEW PRCRI,PRCA,PRCB,PRCC,PRCSTRI
+2 DO EN^DDIOL("POST INITIAL: Process FMS PCL-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","PCL",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(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 PCLED(PRCRI(420.92),PRCRI(420.923))
+8 DO ED(PRCRI(420.92),2)
End DoDot:1
+9 DO EN^DDIOL("POST INITIAL: Process FMS PCL-DOCUMENT done!"_" at "_$$NOW^PRC5A)
+10 QUIT
+11 ;
PCLED(PRCA,PRCB) ;set-up program dic
+1 NEW PRCRI,PRCPGM,PRCPGMD,A
+2 SET A=^PRCU(420.92,PRCA,1,PRCB,1)
SET PRCPGM=$PIECE(A,"~",3)
SET PRCPGMD=$PIECE(A,"~",4)
+3 if PRCPGM=""
QUIT
+4 SET PRCRI(420.13)=$ORDER(^PRCD(420.13,"B",PRCPGM,""))
+5 IF PRCRI(420.13)=""
Begin DoDot:1
+6 NEW X,Y
+7 SET X=PRCPGM
SET X("DR")="1////"_PRCPGMD_";2////"_PRCSTRI
+8 DO ADD^PRC0B1(.X,.Y,"420.13;^PRCD(420.13,")
+9 if Y>0
SET PRCRI(420.13)=+Y
+10 QUIT
End DoDot:1
if 'PRCRI(420.13)
QUIT
+11 ;edit convert field
DO ED1(PRCA,PRCB)
+12 QUIT
+13 ;
PAC ;set-up fcp/prj dic (called by prc5a)
+1 GOTO PAC^PRC5B3
+2 QUIT
+3 ;
CPF ;fill-in fms fields in file 420 (fcp file) (called from prc5a)
+1 GOTO CPF^PRC5B2
+2 ;
+3 QUIT
+4 ;
ED(PRCA,PRCB) ;edit convert start/end time,PRCA=RI, PRCB=1 if start, 2 if end
+1 SET PRCB=$SELECT(PRCB=1:2.6,1:2.7)
+2 DO EDIT^PRC0B(.X,"420.92;;"_PRCA,PRCB_"///^S X=""N""")
+3 QUIT
+4 ;
ED1(PRCA,PRCB) ;edit converted y/n
+1 NEW A
+2 SET A="420.92;^PRCU(420.92,;"_PRCA
+3 SET A=A_"~"_"420.923;^PRCU(420.92,"_PRCA_",1,;"_PRCB
+4 DO EDIT^PRC0B(.X,A,"2////Y")
+5 QUIT
+6 ;
