PRC5B2 ;WISC/PLT-PRC5B1 continue ;7/30/94 03:07
V ;;5.0;IFCAP;;4/21/95
QUIT ;invalid entry
;
CPF ;fill-in fms fields in file 420 (fcp file) (called from prc5a)
N PRCRI,PRCA,PRCB,PRCC
D EN^DDIOL("POST INITIAL: Process FMS CPF-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","CPF",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)="" CPFED(PRCRI(420.92),PRCRI(420.923))
. D ED^PRC5B1(PRCRI(420.92),2)
D EN^DDIOL("POST INITIAL: Process FMS CPF-DOCUMENT done!"_" at "_$$NOW^PRC5A)
QUIT
;
CPFED(PRCA,PRCB) ;start conver fcp
N PRCRI,PRCBY,PRCAO,PRCALD,PRCPGM,PRCFCP,PRCOB,PRCJOB,PRCSCP,PRCFUND
N PRC,PRCDD,PRCDR,PRCDI,PRCPR,PRCAED,PRCQT,PRCU S PRCU="^"
N PRCK,PRCLOCK,PRCNO,PRCST,PRCUNQ
N DA,A,B,X,Y
N PRCUQ,PRCK1,PRCK26,PRCK28,PRCK29,PRCK25,PRCK25D5,PRCK27
N PRCF,PRCFA,PRCFUND,PRCBBFY,PRCRQ
S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCSCP=""
S PRCALD=$P(A,"~",2),PRCBY=$P(A,"~",3),PRCYEAR=+$$YEAR^PRC0C(PRCBY)
S PRCFUND=$P(A,"~",5)
S PRCRI(420)=+$P(A,"~",7),PRCAO=$P(A,"~",6),PRCPGM=$P(A,"~",8),PRCFCP=$P(A,"~",9)
S PRCOB=$P(A,"~",10),PRCJOB=$P(A,"~",11),PRCRI(420.01)=$P(A,"~",12)
QUIT:'PRCRI(420)!(PRCRI(420.01)="")
QUIT:'$D(^PRC(420,PRCRI(420),0))
I PRCRI(420.01)="GPFS" S PRCSCP=1 D
. S PRCRI(420.01)=$O(^PRC(420,PRCRI(420),1,"C","GPFS FMS CONVERSION",""))
. QUIT:PRCRI(420.01)
. F B=9998:-1:1 QUIT:'$D(^PRC(420,PRCRI(420),1,B))
. QUIT:B=1
. S PRCDI="420;^PRC(420,;"_PRCRI(420)_";1~420.01;^PRC(420,"_PRCRI(420)_",1,"
. S X=$E(10000+B,2,999)_" GPFS FMS CONVERSION"
. D ADD^PRC0B1(.X,.Y,PRCDI,+X)
. S PRCRI(420.01)=+Y
. QUIT
QUIT:'PRCRI(420.01)
S PRCRI(420.01)=+PRCRI(420.01)
QUIT:'$D(^PRC(420,PRCRI(420),1,PRCRI(420.01)))
I PRCAO]"" S PRCAO=$O(^PRCD(420.15,"B",PRCAO,"")) QUIT:'PRCAO
I PRCPGM]"" S PRCPGM=$O(^PRCD(420.13,"B",PRCPGM,"")) QUIT:'PRCPGM
I PRCFCP]"" S PRCFCP=$O(^PRCD(420.131,"B",PRCFCP,"")) QUIT:'PRCFCP
I PRCOB]"" S PRCOB=$O(^PRCD(420.132,"B",PRCOB,"")) QUIT:'PRCOB
I PRCJOB]"" S PRCJOB=$O(^PRCD(420.133,"B",PRCJOB,"")) QUIT:'PRCJOB
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)=""
QUIT:'PRCRI(420.3)
S PRCDI="420;^PRC(420,;"_PRCRI(420)_"~420.01;^PRC(420,"_PRCRI(420)_",1,;"_PRCRI(420.01)
S PRCDD=420.01
D KEY1^PRCB1A,REQ1^PRCB1A1
S X="1////"_PRCRI(420.3)_";25.2///^S X="_PRCBY_";25.5////"_PRCAO_";26////"_PRCPGM_";27////"_PRCFCP_";28////"_PRCOB_";29////"_PRCJOB
S:PRCSCP=1 X(1,420.01,1)="4////Y;12////Y;13////"_PRCSCP_";14////0"
D EDIT^PRC0B(.X,PRCDI,"") K X
;add entry in file 420d141
S B=$$ACC^PRC0C(PRCRI(420),PRCRI(420.01)_"^"_PRCBY_"^"_PRCYEAR)
S A=$$FMSACC^PRC0D(PRCRI(420),B)
I '$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0) S X=$$A420D141^PRC0F(A,PRCRI(420.01))
D ED1^PRC5B1(PRCA,PRCB) ;edit convert field
QUIT
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC5B2 3169 printed Dec 13, 2024@01:59:50 Page 2
PRC5B2 ;WISC/PLT-PRC5B1 continue ;7/30/94 03:07
V ;;5.0;IFCAP;;4/21/95
+1 ;invalid entry
QUIT
+2 ;
CPF ;fill-in fms fields in file 420 (fcp file) (called from prc5a)
+1 NEW PRCRI,PRCA,PRCB,PRCC
+2 DO EN^DDIOL("POST INITIAL: Process FMS CPF-DOCUMENT"_" at "_$$NOW^PRC5A)
+3 SET PRCSTRI=$ORDER(^PRCD(420.1999,"AC","A",""))
+4 SET PRCRI(420.92)=0
+5 FOR
SET PRCRI(420.92)=$ORDER(^PRCU(420.92,"B","CPF",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
+6 DO ED^PRC5B1(PRCRI(420.92),1)
+7 SET PRCRI(420.923)=0
+8 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 CPFED(PRCRI(420.92),PRCRI(420.923))
+9 DO ED^PRC5B1(PRCRI(420.92),2)
End DoDot:1
+10 DO EN^DDIOL("POST INITIAL: Process FMS CPF-DOCUMENT done!"_" at "_$$NOW^PRC5A)
+11 QUIT
+12 ;
CPFED(PRCA,PRCB) ;start conver fcp
+1 NEW PRCRI,PRCBY,PRCAO,PRCALD,PRCPGM,PRCFCP,PRCOB,PRCJOB,PRCSCP,PRCFUND
+2 NEW PRC,PRCDD,PRCDR,PRCDI,PRCPR,PRCAED,PRCQT,PRCU
SET PRCU="^"
+3 NEW PRCK,PRCLOCK,PRCNO,PRCST,PRCUNQ
+4 NEW DA,A,B,X,Y
+5 NEW PRCUQ,PRCK1,PRCK26,PRCK28,PRCK29,PRCK25,PRCK25D5,PRCK27
+6 NEW PRCF,PRCFA,PRCFUND,PRCBBFY,PRCRQ
+7 SET A=^PRCU(420.92,PRCA,1,PRCB,1)
SET PRCSCP=""
+8 SET PRCALD=$PIECE(A,"~",2)
SET PRCBY=$PIECE(A,"~",3)
SET PRCYEAR=+$$YEAR^PRC0C(PRCBY)
+9 SET PRCFUND=$PIECE(A,"~",5)
+10 SET PRCRI(420)=+$PIECE(A,"~",7)
SET PRCAO=$PIECE(A,"~",6)
SET PRCPGM=$PIECE(A,"~",8)
SET PRCFCP=$PIECE(A,"~",9)
+11 SET PRCOB=$PIECE(A,"~",10)
SET PRCJOB=$PIECE(A,"~",11)
SET PRCRI(420.01)=$PIECE(A,"~",12)
+12 if 'PRCRI(420)!(PRCRI(420.01)="")
QUIT
+13 if '$DATA(^PRC(420,PRCRI(420),0))
QUIT
+14 IF PRCRI(420.01)="GPFS"
SET PRCSCP=1
Begin DoDot:1
+15 SET PRCRI(420.01)=$ORDER(^PRC(420,PRCRI(420),1,"C","GPFS FMS CONVERSION",""))
+16 if PRCRI(420.01)
QUIT
+17 FOR B=9998:-1:1
if '$DATA(^PRC(420,PRCRI(420),1,B))
QUIT
+18 if B=1
QUIT
+19 SET PRCDI="420;^PRC(420,;"_PRCRI(420)_";1~420.01;^PRC(420,"_PRCRI(420)_",1,"
+20 SET X=$EXTRACT(10000+B,2,999)_" GPFS FMS CONVERSION"
+21 DO ADD^PRC0B1(.X,.Y,PRCDI,+X)
+22 SET PRCRI(420.01)=+Y
+23 QUIT
End DoDot:1
+24 if 'PRCRI(420.01)
QUIT
+25 SET PRCRI(420.01)=+PRCRI(420.01)
+26 if '$DATA(^PRC(420,PRCRI(420),1,PRCRI(420.01)))
QUIT
+27 IF PRCAO]""
SET PRCAO=$ORDER(^PRCD(420.15,"B",PRCAO,""))
if 'PRCAO
QUIT
+28 IF PRCPGM]""
SET PRCPGM=$ORDER(^PRCD(420.13,"B",PRCPGM,""))
if 'PRCPGM
QUIT
+29 IF PRCFCP]""
SET PRCFCP=$ORDER(^PRCD(420.131,"B",PRCFCP,""))
if 'PRCFCP
QUIT
+30 IF PRCOB]""
SET PRCOB=$ORDER(^PRCD(420.132,"B",PRCOB,""))
if 'PRCOB
QUIT
+31 IF PRCJOB]""
SET PRCJOB=$ORDER(^PRCD(420.133,"B",PRCJOB,""))
if 'PRCJOB
QUIT
+32 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
+33 if 'PRCRI(420.3)
QUIT
+34 SET PRCDI="420;^PRC(420,;"_PRCRI(420)_"~420.01;^PRC(420,"_PRCRI(420)_",1,;"_PRCRI(420.01)
+35 SET PRCDD=420.01
+36 DO KEY1^PRCB1A
DO REQ1^PRCB1A1
+37 SET X="1////"_PRCRI(420.3)_";25.2///^S X="_PRCBY_";25.5////"_PRCAO_";26////"_PRCPGM_";27////"_PRCFCP_";28////"_PRCOB_";29////"_PRCJOB
+38 if PRCSCP=1
SET X(1,420.01,1)="4////Y;12////Y;13////"_PRCSCP_";14////0"
+39 DO EDIT^PRC0B(.X,PRCDI,"")
KILL X
+40 ;add entry in file 420d141
+41 SET B=$$ACC^PRC0C(PRCRI(420),PRCRI(420.01)_"^"_PRCBY_"^"_PRCYEAR)
+42 SET A=$$FMSACC^PRC0D(PRCRI(420),B)
+43 IF '$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
SET X=$$A420D141^PRC0F(A,PRCRI(420.01))
+44 ;edit convert field
DO ED1^PRC5B1(PRCA,PRCB)
+45 QUIT
+46 ;
+47 ;
