source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRC5B2.m@ 1420

Last change on this file since 1420 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.0 KB
Line 
1PRC5B2 ;WISC/PLT-PRC5B1 continue ;7/30/94 03:07
2V ;;5.0;IFCAP;;4/21/95
3 QUIT ;invalid entry
4 ;
5CPF ;fill-in fms fields in file 420 (fcp file) (called from prc5a)
6 N PRCRI,PRCA,PRCB,PRCC
7 D EN^DDIOL("POST INITIAL: Process FMS CPF-DOCUMENT"_" at "_$$NOW^PRC5A)
8 S PRCSTRI=$O(^PRCD(420.1999,"AC","A",""))
9 S PRCRI(420.92)=0
10 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)="")
11 . D ED^PRC5B1(PRCRI(420.92),1)
12 . S PRCRI(420.923)=0
13 . 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))
14 . D ED^PRC5B1(PRCRI(420.92),2)
15 D EN^DDIOL("POST INITIAL: Process FMS CPF-DOCUMENT done!"_" at "_$$NOW^PRC5A)
16 QUIT
17 ;
18CPFED(PRCA,PRCB) ;start conver fcp
19 N PRCRI,PRCBY,PRCAO,PRCALD,PRCPGM,PRCFCP,PRCOB,PRCJOB,PRCSCP,PRCFUND
20 N PRC,PRCDD,PRCDR,PRCDI,PRCPR,PRCAED,PRCQT,PRCU S PRCU="^"
21 N PRCK,PRCLOCK,PRCNO,PRCST,PRCUNQ
22 N DA,A,B,X,Y
23 N PRCUQ,PRCK1,PRCK26,PRCK28,PRCK29,PRCK25,PRCK25D5,PRCK27
24 N PRCF,PRCFA,PRCFUND,PRCBBFY,PRCRQ
25 S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCSCP=""
26 S PRCALD=$P(A,"~",2),PRCBY=$P(A,"~",3),PRCYEAR=+$$YEAR^PRC0C(PRCBY)
27 S PRCFUND=$P(A,"~",5)
28 S PRCRI(420)=+$P(A,"~",7),PRCAO=$P(A,"~",6),PRCPGM=$P(A,"~",8),PRCFCP=$P(A,"~",9)
29 S PRCOB=$P(A,"~",10),PRCJOB=$P(A,"~",11),PRCRI(420.01)=$P(A,"~",12)
30 QUIT:'PRCRI(420)!(PRCRI(420.01)="")
31 QUIT:'$D(^PRC(420,PRCRI(420),0))
32 I PRCRI(420.01)="GPFS" S PRCSCP=1 D
33 . S PRCRI(420.01)=$O(^PRC(420,PRCRI(420),1,"C","GPFS FMS CONVERSION",""))
34 . QUIT:PRCRI(420.01)
35 . F B=9998:-1:1 QUIT:'$D(^PRC(420,PRCRI(420),1,B))
36 . QUIT:B=1
37 . S PRCDI="420;^PRC(420,;"_PRCRI(420)_";1~420.01;^PRC(420,"_PRCRI(420)_",1,"
38 . S X=$E(10000+B,2,999)_" GPFS FMS CONVERSION"
39 . D ADD^PRC0B1(.X,.Y,PRCDI,+X)
40 . S PRCRI(420.01)=+Y
41 . QUIT
42 QUIT:'PRCRI(420.01)
43 S PRCRI(420.01)=+PRCRI(420.01)
44 QUIT:'$D(^PRC(420,PRCRI(420),1,PRCRI(420.01)))
45 I PRCAO]"" S PRCAO=$O(^PRCD(420.15,"B",PRCAO,"")) QUIT:'PRCAO
46 I PRCPGM]"" S PRCPGM=$O(^PRCD(420.13,"B",PRCPGM,"")) QUIT:'PRCPGM
47 I PRCFCP]"" S PRCFCP=$O(^PRCD(420.131,"B",PRCFCP,"")) QUIT:'PRCFCP
48 I PRCOB]"" S PRCOB=$O(^PRCD(420.132,"B",PRCOB,"")) QUIT:'PRCOB
49 I PRCJOB]"" S PRCJOB=$O(^PRCD(420.133,"B",PRCJOB,"")) QUIT:'PRCJOB
50 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)=""
51 QUIT:'PRCRI(420.3)
52 S PRCDI="420;^PRC(420,;"_PRCRI(420)_"~420.01;^PRC(420,"_PRCRI(420)_",1,;"_PRCRI(420.01)
53 S PRCDD=420.01
54 D KEY1^PRCB1A,REQ1^PRCB1A1
55 S X="1////"_PRCRI(420.3)_";25.2///^S X="_PRCBY_";25.5////"_PRCAO_";26////"_PRCPGM_";27////"_PRCFCP_";28////"_PRCOB_";29////"_PRCJOB
56 S:PRCSCP=1 X(1,420.01,1)="4////Y;12////Y;13////"_PRCSCP_";14////0"
57 D EDIT^PRC0B(.X,PRCDI,"") K X
58 ;add entry in file 420d141
59 S B=$$ACC^PRC0C(PRCRI(420),PRCRI(420.01)_"^"_PRCBY_"^"_PRCYEAR)
60 S A=$$FMSACC^PRC0D(PRCRI(420),B)
61 I '$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0) S X=$$A420D141^PRC0F(A,PRCRI(420.01))
62 D ED1^PRC5B1(PRCA,PRCB) ;edit convert field
63 QUIT
64 ;
65 ;
Note: See TracBrowser for help on using the repository browser.