PRCPSFU0 ;WISC/RFJ-fms code sheet utilities (find iv line) ;9.9.97
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
FINDLINE(PRCPDA,LINEDA) ; find fms line number for lineda
; return acct,subacct,fmsline
N %,DATA
S %=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
S ACCT=$P($P(%,"^"),"-"),SUBACCT=$P($P(%,"^"),"-",2),FMSLINE=+$P(%,"^",2)
I ACCT,SUBACCT,FMSLINE Q
S DATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0))
S SUBACCT=+$P(DATA,"^",4) S:'SUBACCT SUBACCT=$P($G(^PRC(441,+$P(DATA,"^",5),0)),"^",10) S SUBACCT=$E(SUBACCT_"0000",1,4)
S ACCT=$$ACCT1^PRCPUX1($P($$NSN^PRCPUX1($P(DATA,"^",5)),"-"))
; look to see if a line has already been created for acct-subacct
S FMSLINE=+$O(^PRCS(410,PRCPDA,"IT","FMSLINE","A"_ACCT_"-"_SUBACCT,0))
I FMSLINE D SETLINE(PRCPDA,LINEDA,"A"_ACCT_"-"_SUBACCT,FMSLINE) Q
; get next fms line number and set it for line
S FMSLINE=$$GETNEXT(PRCPDA)
D SETLINE(PRCPDA,LINEDA,"A"_ACCT_"-"_SUBACCT,FMSLINE)
Q
;
;
SETLINE(PRCPDA,LINEDA,ACCTNG,FMSLINE) ; set fms line on issue book line
; fmsline=fmsline number to set; acctng=acct-subaact
I '$D(^PRCS(410,PRCPDA,"IT",LINEDA,0)) Q
S $P(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",1,2)=ACCTNG_"^"_FMSLINE
S ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)=""
Q
;
;
GETNEXT(PRCPDA) ; get next fmsline for issue book
; all fmsline numbers are odd, even numbers used for profit
I '$D(^PRCS(410,PRCPDA,0)) Q 0
N FMSLINE
S FMSLINE=$P($G(^PRCS(410,PRCPDA,445)),"^",2)
I 'FMSLINE S $P(^PRCS(410,PRCPDA,445),"^",2)=1 Q 1
S FMSLINE=FMSLINE+2,$P(^PRCS(410,PRCPDA,445),"^",2)=FMSLINE
Q FMSLINE
;
;
XREFFMS(PRCPDA,LINEDA,VALUE,FIELD,SETKILL) ; build fms cross reference
; used for issue book IV document
; x = value of data in field
; field = field number for x
; setkill = "SET" to set; "KILL" (or anything other than set) to kill
N %,ACCTNG,FMSLINE
S %=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445)) I %="" Q
S ACCTNG=$P(%,"^"),FMSLINE=+$P(%,"^",2)
D
. I FIELD=445.01 S ACCTNG=X Q
. I FIELD=445.02 S FMSLINE=X Q
I ACCTNG=""!('FMSLINE) Q
I SETKILL="SET" S ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)="" Q
K ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSFU0 2293 printed Nov 22, 2024@17:25:52 Page 2
PRCPSFU0 ;WISC/RFJ-fms code sheet utilities (find iv line) ;9.9.97
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
FINDLINE(PRCPDA,LINEDA) ; find fms line number for lineda
+1 ; return acct,subacct,fmsline
+2 NEW %,DATA
+3 SET %=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,445))
+4 SET ACCT=$PIECE($PIECE(%,"^"),"-")
SET SUBACCT=$PIECE($PIECE(%,"^"),"-",2)
SET FMSLINE=+$PIECE(%,"^",2)
+5 IF ACCT
IF SUBACCT
IF FMSLINE
QUIT
+6 SET DATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
+7 SET SUBACCT=+$PIECE(DATA,"^",4)
if 'SUBACCT
SET SUBACCT=$PIECE($GET(^PRC(441,+$PIECE(DATA,"^",5),0)),"^",10)
SET SUBACCT=$EXTRACT(SUBACCT_"0000",1,4)
+8 SET ACCT=$$ACCT1^PRCPUX1($PIECE($$NSN^PRCPUX1($PIECE(DATA,"^",5)),"-"))
+9 ; look to see if a line has already been created for acct-subacct
+10 SET FMSLINE=+$ORDER(^PRCS(410,PRCPDA,"IT","FMSLINE","A"_ACCT_"-"_SUBACCT,0))
+11 IF FMSLINE
DO SETLINE(PRCPDA,LINEDA,"A"_ACCT_"-"_SUBACCT,FMSLINE)
QUIT
+12 ; get next fms line number and set it for line
+13 SET FMSLINE=$$GETNEXT(PRCPDA)
+14 DO SETLINE(PRCPDA,LINEDA,"A"_ACCT_"-"_SUBACCT,FMSLINE)
+15 QUIT
+16 ;
+17 ;
SETLINE(PRCPDA,LINEDA,ACCTNG,FMSLINE) ; set fms line on issue book line
+1 ; fmsline=fmsline number to set; acctng=acct-subaact
+2 IF '$DATA(^PRCS(410,PRCPDA,"IT",LINEDA,0))
QUIT
+3 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",1,2)=ACCTNG_"^"_FMSLINE
+4 SET ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)=""
+5 QUIT
+6 ;
+7 ;
GETNEXT(PRCPDA) ; get next fmsline for issue book
+1 ; all fmsline numbers are odd, even numbers used for profit
+2 IF '$DATA(^PRCS(410,PRCPDA,0))
QUIT 0
+3 NEW FMSLINE
+4 SET FMSLINE=$PIECE($GET(^PRCS(410,PRCPDA,445)),"^",2)
+5 IF 'FMSLINE
SET $PIECE(^PRCS(410,PRCPDA,445),"^",2)=1
QUIT 1
+6 SET FMSLINE=FMSLINE+2
SET $PIECE(^PRCS(410,PRCPDA,445),"^",2)=FMSLINE
+7 QUIT FMSLINE
+8 ;
+9 ;
XREFFMS(PRCPDA,LINEDA,VALUE,FIELD,SETKILL) ; build fms cross reference
+1 ; used for issue book IV document
+2 ; x = value of data in field
+3 ; field = field number for x
+4 ; setkill = "SET" to set; "KILL" (or anything other than set) to kill
+5 NEW %,ACCTNG,FMSLINE
+6 SET %=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,445))
IF %=""
QUIT
+7 SET ACCTNG=$PIECE(%,"^")
SET FMSLINE=+$PIECE(%,"^",2)
+8 Begin DoDot:1
+9 IF FIELD=445.01
SET ACCTNG=X
QUIT
+10 IF FIELD=445.02
SET FMSLINE=X
QUIT
End DoDot:1
+11 IF ACCTNG=""!('FMSLINE)
QUIT
+12 IF SETKILL="SET"
SET ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)=""
QUIT
+13 KILL ^PRCS(410,PRCPDA,"IT","FMSLINE",ACCTNG,FMSLINE,LINEDA)
+14 QUIT
