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 ---[H[J[2J[HPRCFFU22 1808 printed Nov 22, 2024@17:13:51 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
