| 1 | PRCPSFU0 ;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 | ;
|
|---|
| 7 | FINDLINE(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 | ;
|
|---|
| 25 | SETLINE(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 | ;
|
|---|
| 33 | GETNEXT(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 | ;
|
|---|
| 43 | XREFFMS(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
|
|---|
