source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPSFU0.m@ 1582

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

initial load of WorldVistAEHR

File size: 2.2 KB
Line 
1PRCPSFU0 ;WISC/RFJ-fms code sheet utilities (find iv line) ;9.9.97
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7FINDLINE(PRCPDA,LINEDA) ; find fms line number for lineda
8 ; return acct,subacct,fmsline
9 N %,DATA
10 S %=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
11 S ACCT=$P($P(%,"^"),"-"),SUBACCT=$P($P(%,"^"),"-",2),FMSLINE=+$P(%,"^",2)
12 I ACCT,SUBACCT,FMSLINE Q
13 S DATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0))
14 S SUBACCT=+$P(DATA,"^",4) S:'SUBACCT SUBACCT=$P($G(^PRC(441,+$P(DATA,"^",5),0)),"^",10) S SUBACCT=$E(SUBACCT_"0000",1,4)
15 S ACCT=$$ACCT1^PRCPUX1($P($$NSN^PRCPUX1($P(DATA,"^",5)),"-"))
16 ; look to see if a line has already been created for acct-subacct
17 S FMSLINE=+$O(^PRCS(410,PRCPDA,"IT","FMSLINE","A"_ACCT_"-"_SUBACCT,0))
18 I FMSLINE D SETLINE(PRCPDA,LINEDA,"A"_ACCT_"-"_SUBACCT,FMSLINE) Q
19 ; get next fms line number and set it for line
20 S FMSLINE=$$GETNEXT(PRCPDA)
21 D SETLINE(PRCPDA,LINEDA,"A"_ACCT_"-"_SUBACCT,FMSLINE)
22 Q
23 ;
24 ;
25SETLINE(PRCPDA,LINEDA,ACCTNG,FMSLINE) ; set fms line on issue book line
26 ; fmsline=fmsline number to set; acctng=acct-subaact
27 I '$D(^PRCS(410,PRCPDA,"IT",LINEDA,0)) Q
28 S $P(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",1,2)=ACCTNG_"^"_FMSLINE
29 S ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)=""
30 Q
31 ;
32 ;
33GETNEXT(PRCPDA) ; get next fmsline for issue book
34 ; all fmsline numbers are odd, even numbers used for profit
35 I '$D(^PRCS(410,PRCPDA,0)) Q 0
36 N FMSLINE
37 S FMSLINE=$P($G(^PRCS(410,PRCPDA,445)),"^",2)
38 I 'FMSLINE S $P(^PRCS(410,PRCPDA,445),"^",2)=1 Q 1
39 S FMSLINE=FMSLINE+2,$P(^PRCS(410,PRCPDA,445),"^",2)=FMSLINE
40 Q FMSLINE
41 ;
42 ;
43XREFFMS(PRCPDA,LINEDA,VALUE,FIELD,SETKILL) ; build fms cross reference
44 ; used for issue book IV document
45 ; x = value of data in field
46 ; field = field number for x
47 ; setkill = "SET" to set; "KILL" (or anything other than set) to kill
48 N %,ACCTNG,FMSLINE
49 S %=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445)) I %="" Q
50 S ACCTNG=$P(%,"^"),FMSLINE=+$P(%,"^",2)
51 D
52 . I FIELD=445.01 S ACCTNG=X Q
53 . I FIELD=445.02 S FMSLINE=X Q
54 I ACCTNG=""!('FMSLINE) Q
55 I SETKILL="SET" S ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)="" Q
56 K ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)
57 Q
Note: See TracBrowser for help on using the repository browser.