PRCFFU22.m

PRCFFU22 ;WISC/SJG-FMS MO4, MO5 SEGMENTS ;11/26/93  15:35

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

MO4 ;Build 'MO4' Segment

 ; 9.2  - PROMPT PAYMENT TERMS (442.06)

 ;  .01 - PROMPT PAYMENT PERCENT

 ;  1   - DAYS (TERM)

 ; Don't send if NET/30; exceptions only

MO4A I TYCODE="M" Q:'PRCFA("PPT")

 N SEG,DISCPER,DISCDAY,PER,DAY,DAYX,AUTOACC,PROXDAY,HIGH

 S TMPLINE=TMPLINE+1,SEG=""

 K PRCTMP N DA S DIC=442,DA=+PO,DIQ="PRCTMP(",DIQ(0)="IE",DR="9.2"

 S DR(442.06)=".01;1",(HIGH,DA(442.06))=$$HIGH(.RET) D EN^DIQ1 K DIC,DIQ,DR

 S (AUTOACC,DISCPER,DISCDAY,PROXDAY)=""

MO4B I TRCODE="SO"&((PRCFA("MP")=21)!(PRCFA("MP")=2)) S AUTOACC=PRCFA("AUTOACC")

 S DAY=$G(PRCTMP(442.06,HIGH,1,"E"))

 S DAYX=$E(DAY,$L(DAY)-1,$L(DAY))

 I "^st^ST^nd^ND^rd^RD^th^TH^"[DAYX S PROXDAY=+DAY

 I PROXDAY="" S DISCDAY=+DAY

 S PER=$G(PRCTMP(442.06,HIGH,.01,"E"))

 S DISCPER=$G(PRCTMP(442.06,HIGH,.01,"E"))

 I DISCPER="NET" S (DISCPER,DISCDAY)=""

 I DISCPER]"" S DISCPER=$FN(DISCPER,"",3)

 I (DISCPER="")&(DISCDAY="")&(AUTOACC="") S TMPLINE=TMPLINE-1 Q

 S $P(SEG,U,1)=DISCDAY,$P(SEG,U,2)=DISCPER

MO4C I TRCODE="SO"&((PRCFA("MP")=21)!(PRCFA("MP")=2)) S $P(SEG,U,7)=AUTOACC

 I +$G(PROXDAY) S $P(SEG,U,8)=PROXDAY

 S ^TMP($J,"PRCMO",INT,TMPLINE)="MO4^^"_SEG_"^~"

 Q

MO5 ; Build 'MO5' Segment

 N SEG

 S TMPLINE=TMPLINE+1,SEG=""

 S ^TMP($J,"PRCMO",INT,TMPLINE)="MO5^~"

 I SEG S ^TMP($J,"PRCMO",INT,TMPLINE)="MO5^"_SEG_"^~"

 Q

HIGH(RET) ; Determine largest Prompt Payment Terms 

 N LOOP,LOOP1,PPT,PPTVAL,PPTIEN

 S LOOP=0,LOOP1="",PPTIEN=1

 F  S LOOP=$O(^PRC(442,+PO,5,LOOP)) Q:'LOOP  D

 .S PPTVAL=^PRC(442,+PO,5,LOOP,0)

 .I +PPTVAL>0 S PPT(100-PPTVAL)=+PPTVAL_"^"_LOOP

 .Q

 I $D(PPT) S LOOP1=$O(PPT(LOOP1)),PPTIEN=$P(PPT(LOOP1),U,2)

 Q PPTIEN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFFU22   1808     printed  Feb 18, 2025@23:30:08                                                                                                                                                                                                    Page 2

PRCFFU22  ;WISC/SJG-FMS MO4, MO5 SEGMENTS ;11/26/93  15:35

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

MO4       ;Build 'MO4' Segment

 +1       ; 9.2  - PROMPT PAYMENT TERMS (442.06)

 +2       ;  .01 - PROMPT PAYMENT PERCENT

 +3       ;  1   - DAYS (TERM)

 +4       ; Don't send if NET/30; exceptions only

MO4A       IF TYCODE="M"

               if 'PRCFA("PPT")

                   QUIT 

 +1        NEW SEG,DISCPER,DISCDAY,PER,DAY,DAYX,AUTOACC,PROXDAY,HIGH

 +2        SET TMPLINE=TMPLINE+1

           SET SEG=""

 +3        KILL PRCTMP

           NEW DA

           SET DIC=442

           SET DA=+PO

           SET DIQ="PRCTMP("

           SET DIQ(0)="IE"

           SET DR="9.2"

 +4        SET DR(442.06)=".01;1"

           SET (HIGH,DA(442.06))=$$HIGH(.RET)

           DO EN^DIQ1

           KILL DIC,DIQ,DR

 +5        SET (AUTOACC,DISCPER,DISCDAY,PROXDAY)=""

MO4B       IF TRCODE="SO"&((PRCFA("MP")=21)!(PRCFA("MP")=2))

               SET AUTOACC=PRCFA("AUTOACC")

 +1        SET DAY=$GET(PRCTMP(442.06,HIGH,1,"E"))

 +2        SET DAYX=$EXTRACT(DAY,$LENGTH(DAY)-1,$LENGTH(DAY))

 +3        IF "^st^ST^nd^ND^rd^RD^th^TH^"[DAYX

               SET PROXDAY=+DAY

 +4        IF PROXDAY=""

               SET DISCDAY=+DAY

 +5        SET PER=$GET(PRCTMP(442.06,HIGH,.01,"E"))

 +6        SET DISCPER=$GET(PRCTMP(442.06,HIGH,.01,"E"))

 +7        IF DISCPER="NET"

               SET (DISCPER,DISCDAY)=""

 +8        IF DISCPER]""

               SET DISCPER=$FNUMBER(DISCPER,"",3)

 +9        IF (DISCPER="")&(DISCDAY="")&(AUTOACC="")

               SET TMPLINE=TMPLINE-1

               QUIT 

 +10       SET $PIECE(SEG,U,1)=DISCDAY

           SET $PIECE(SEG,U,2)=DISCPER

MO4C       IF TRCODE="SO"&((PRCFA("MP")=21)!(PRCFA("MP")=2))

               SET $PIECE(SEG,U,7)=AUTOACC

 +1        IF +$GET(PROXDAY)

               SET $PIECE(SEG,U,8)=PROXDAY

 +2        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="MO4^^"_SEG_"^~"

 +3        QUIT 

MO5       ; Build 'MO5' Segment

 +1        NEW SEG

 +2        SET TMPLINE=TMPLINE+1

           SET SEG=""

 +3        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="MO5^~"

 +4        IF SEG

               SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="MO5^"_SEG_"^~"

 +5        QUIT 

HIGH(RET) ; Determine largest Prompt Payment Terms 

 +1        NEW LOOP,LOOP1,PPT,PPTVAL,PPTIEN

 +2        SET LOOP=0

           SET LOOP1=""

           SET PPTIEN=1

 +3        FOR 

               SET LOOP=$ORDER(^PRC(442,+PO,5,LOOP))

               if 'LOOP

                   QUIT 

               Begin DoDot:1

 +4                SET PPTVAL=^PRC(442,+PO,5,LOOP,0)

 +5                IF +PPTVAL>0

                       SET PPT(100-PPTVAL)=+PPTVAL_"^"_LOOP

 +6                QUIT 

               End DoDot:1

 +7        IF $DATA(PPT)

               SET LOOP1=$ORDER(PPT(LOOP1))

               SET PPTIEN=$PIECE(PPT(LOOP1),U,2)

 +8        QUIT PPTIEN