source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB8A2.m@ 1710

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

initial load of WorldVistAEHR

File size: 3.3 KB
RevLine 
[613]1PRCB8A2 ;WISC/PLT-PRCB8A CONTINUED ; 08/16/95 3:54 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6 ;.X = record id of file 2100.1 if generated, "" if fail
7 ;A is ^1 = FMS documents (fileman) date, ^2 = doc year, ^3 = doc quarter
8 ; ^4 = SITE #, ^5 = transfer from fund control point #, ^6 = $amount
9 ; ^7 = BBFY, ^8 = to fund control point, ^9=fiscal accounting period (mmyy), ^10=cal acct per
10 ;PRCID=FMS document id if regenerated
11 ;
12AT(X,PRCFC,PRCID) ;AT auto document
13 N PRCA,PRCB,PRCC,PRCDDT,PRCF,PRCF1,PRCQ,PRCRI,PRCSITE,PRCY,GECSFMS,PRCAP
14 N B,Z
15 S PRCDDT=$P(PRCFC,"^"),PRCY=$P(PRCFC,"^",2),PRCQ=$P(PRCFC,"^",3)
16 S PRCSITE=+$P(PRCFC,"^",4),PRCRI(420.01)=+$P(PRCFC,"^",5),PRCAMT=$P(PRCFC,"^",6)
17 S PRCRI("420.01A")=$P(PRCFC,"^",8),PRCAP=$P(PRCFC,"^",9)_"/"_$P(PRCFC,"^",10)
18 I $G(PRCID)]"" S PRCRI(2100.1)=+PRCID,PRCID=$P(PRCID,"^",2)
19 I $G(PRCID)="" S (X,Z)=PRCSITE_"-FC" D EN1^PRCSUT3 S X="0000"_+$P(X,"-",3),PRCID=PRCSITE_"FC"_$E(X,$L(X)-3,$L(X))
20 S PRCY=$$YEAR^PRC0C(PRCY)+0
21 I $G(PRCRI(2100.1)) D REBUILD^GECSUFM1(PRCRI(2100.1),"I",$$SEC1^PRC0C(PRCSITE),"Y","Edited Rejected Auto AT Document")
22 ;add entry in file 2100.1 if not rejected process
23 D:$G(PRCRI(2100.1))="" G EXIT:PRCRI(2100.1)<1
24 . D CONTROL^GECSUFMS("I",PRCSITE,PRCID,"AT",$$SEC1^PRC0C(PRCSITE),0,"Y","Original Auto AT Document")
25 . S PRCRI(2100.1)=GECSFMS("DA")
26 . QUIT
27 D SETPARAM^GECSSDCT(PRCRI(2100.1),$P($TR(PRCFC,"^","/"),"/",1,8)_"//"_PRCAP)
28 S PRCC=1,PRCB(PRCC)=""
29 D ATDOC,DLM("~")
30 D ATLIN,DLM("~{")
31 S PRCA="" F S PRCA=$O(PRCB(PRCA)) Q:'PRCA D SETCS^GECSSTAA(PRCRI(2100.1),PRCB(PRCA))
32 D SETSTAT^GECSSTAA(PRCRI(2100.1),"Q")
33EXIT S X=$G(PRCRI(2100.1))_"^"_PRCID
34 QUIT
35ATDOC ;assemble AT doc
36 D DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI(420.01)_"^"_$E(PRCY,3,4)_"^"_$P(PRCFC,"^",7),"AB","PRCF")
37 D DOCREQ^PRC0C("^"_PRCSITE_"^"_PRCRI("420.01A")_"^"_$E(PRCY,3,4)_"^"_$P(PRCFC,"^",7),"AB","PRCF1")
38 D STR("AT1",3),STR("AT",2),STR(PRCID,11)
39 D STR($E(PRCDDT,4,5),2),STR($E(PRCDDT,6,7),2),STR($E(PRCDDT,2,3),2)
40 D STR($E(PRCAP,1,2),2),STR($E(PRCAP,3,4),2),STR($E($P(PRCF,"^",6),3,4),2),STR($S($P(PRCF,"^",6)=$P(PRCF,"^",7):"",1:$E($P(PRCF,"^",7),3,4)),2)
41 D STR($P(PRCF,"^",5),6)
42 QUIT
43 ;
44ATLIN ;assemble AT line
45 D STR("LIN",3),DLM("~")
46 D STR("ATA",3)
47 D STR($S($G(PRCF("AO"))="N":"",1:$P(PRCF,"^")),4)
48 D STR($S($G(PRCF("SITE"))="N":"",1:PRCSITE),7)
49 D STR($S($G(PRCF("PGM"))="N":"",1:$P(PRCF,"^",2)),9)
50 D STR($S($G(PRCF("OC"))="N":"",1:$P(PRCF,"^",4)),4)
51 D STR(PRCQ,1)
52 S X=$$DATE^PRC0C(PRCDDT,"I"),X=$S(PRCY_"^"_PRCQ]$P(X,"^",1,2):"A",1:"Y") D STR(X,1)
53 D STR($S($G(PRCF1("AO"))="N":"",1:$P(PRCF1,"^")),4)
54 D STR($S($G(PRCF1("SITE"))="N":"",1:PRCSITE),7)
55 D STR($S($G(PRCF1("PGM"))="N":"",1:$P(PRCF1,"^",2)),9)
56 D STR($S($G(PRCF1("OC"))="N":"",1:$P(PRCF1,"^",4)),4)
57 D STR(PRCQ,1),STR($FN(PRCAMT,"-",2),15)
58 QUIT
59 ;
60 ;A = data, B = field length
61STR(A,B) ;store data in node/piece
62 S:$L(PRCB(PRCC))+$L(A)>230 PRCC=PRCC+1,PRCB(PRCC)=""
63 S PRCB(PRCC)=PRCB(PRCC)_$E(A,1,B)_"^"
64 QUIT
65 ;
66DLM(A) ;store seg ~ or txn { delimiters
67 S PRCB(PRCC)=PRCB(PRCC)_A
68 QUIT
69 ;
70FMSACC(A,B) ;convert to field .01 in file 420.141 format
71 N C
72 S C=A,$P(C,"~",2)=$P(B,"^",6),$P(C,"~",3)=$P(B,"^",5)
73 S $P(C,"~",4)=$P(B,"^"),$P(C,"~",5)=$P(B,"^",2),$P(C,"~",6)=$P(B,"^",3)
74 S $P(C,"~",7)=$P(B,"^",4),$P(C,"~",8)=$P(B,"^",10)
75 QUIT C
76 ;
Note: See TracBrowser for help on using the repository browser.