PRCPSFU0.m

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 ---PRCPSFU0   2293     printed  Feb 18, 2025@23:42:10                                                                                                                                                                                                    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