PRCFFU21 ;WISC/SJG-FMS MO3 SEGMENT ;6/25/97 16:36
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
MO3 ;BUILD 'MO3' SEGMENT
; 7 - DELIVERY DATE (FILE 442)
; 7.2 - ESTIMATED COST (FILE 442)
; 9.2 - PROMPT PAYMENT TERMS (FILE 442)
; 8.3 - PURCHASE METHOD (442.12)
; 29 - END DATE (FILE 442)
; 30 - AUTO ACCRUE (FILE 410)
; 91 - TOTAL AMOUNT (FILE 442)
; 92 - NET AMOUNT (FILE 442)
; 5 - VENDOR (FILE 442)
; .07 - PRIMARY 2237 REQUEST (FILE 442)
; 11 - VENDOR (FILE 410)
; 13 - VENDOR CONTRACT NUMBER (FILE 410)
; 21 - DATE COMMITTED (FILE 410)
; 52 - STA NO-PO NUM (FILE 410)
;
MO3A N SEG,DELDATE,FMSYR,FMSMO,FMSDAY,PPT,PM,TOT,CONT,START,VENID,PRIMREQ,VENCONT,CONTIEN,CONTEND,CONTBEG
S TMPLINE=TMPLINE+1,SEG="MO3^^^^^^^01"
K PRCTMP N DA S DIC=442,DR=".07;5;7.2;7;8.3;29;30;91;92",DA=+PO,DIQ="PRCTMP(",DIQ(0)="IE",DR(442.12)=".01",DA(442.12)=1 D EN^DIQ1 K DIC,DIQ,DR
I TRCODE="SO",PRCFA("MP")=21,$G(PRCCON3) S:$G(PRCTMP(442,+PO,92,"E"))]"" PRCTMP(442,+PO,91,"E")=PRCTMP(442,+PO,92,"E")
MO3B D
.Q:(PRCFA("MP")=2)&(PRCFA("TT")="SO")
.I TYCODE="M" Q:(PRCFA("DEL")="")&(PRCFA("DELSCH")="")
.S DELDATE=PRCTMP(442,+PO,7,"I")
.S DELDATE=$$DELSCH^PRCFFU5(.DELDATE)
.S X1=BEGDATE,X2=DELDATE D ^%DTC I X>0 S DELDATE=BEGDATE
.D DATE(DELDATE,.A,.B,.C) S DELDATE=FMSYR_U_FMSMO_U_FMSDAY
.S $P(SEG,U,9)=DELDATE
MO3C I TRCODE="MO" D
.S PM=$G(PRCTMP(442.12,1,.01,"I"))
.S CONT="" I $D(^PRC(442,+PO,2,"AC"))\10 S START="",CONT=$O(^PRC(442,+PO,2,"AC",START))
.I TYCODE="E" S:PRCFMO("G/N")="G" TOT=$G(PRCTMP(442,+PO,91,"E")) S:PRCFMO("G/N")="N" TOT=$G(PRCTMP(442,+PO,92,"E")) S TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
.I TYCODE="M" D
..Q:'$D(PRCFCHG("BOC"))
..S TOT=$FN(TOTAMT,"",2),$P(SEG,U,27)=TOT
.I $G(CONT)]"" I TRCODE'="MO" S $P(SEG,U,33)=$E(CONT,1,10)
MO3D I TRCODE="SO"&(PRCFA("MP")=21) D
.S VENID=$G(PRCTMP(442,+PO,5,"I")),PRIMREQ=$G(PRCTMP(442,+PO,.07,"I"))
.S PRCFA("AUTOACC")=$E($G(PRCTMP(442,+PO,30,"E")),1)
.I PRIMREQ]"" D
..N DA S DA=+PRIMREQ,DIC=410,DR="13;21;52",DIQ="PRCTMP(",DIQ(0)="IEN" D EN^DIQ1 K DIC,DIQ,DR
..I TYCODE="M" D
...N POIEN S POIEN=$G(PRCTMP(410,PRIMREQ,52,"I"))
...I POIEN]"" D
....N ORGIEN S ORGIEN=$G(PRCTMP(442,POIEN,.07,"I"))
....D GENDIQ^PRCFFU7(410,ORGIEN,"11;13;21","IEN","")
....Q
...Q
..I PRCFA("AUTOACC")="" S PRCFA("AUTOACC")="N"
..S VENCONT=$G(PRCTMP(410,+PRIMREQ,13,"E"))
..I VENID]""&(VENCONT]"")&($G(PRCTMP(442,+PO,29,"I"))="") D Q
...S DIC="^PRC(440,"_VENID_",4,",DIC(0)="MNQZ",X=VENCONT D ^DIC K DIC
...S CONTIEN=+Y
...N DA S DIC=440,DR=6,DA=+VENID,DIQ="PRCTMP(",DIQ(0)="IEN",DR(440.03)=".5;1",DA(440.03)=CONTIEN D EN^DIQ1 K DIC,DIQ,DR
...S CONTEND=$G(PRCTMP(440.03,CONTIEN,1,"I")) I CONTEND]"" S CONTEND=$$DATE2(CONTEND),$P(SEG,U,9)=CONTEND
...S CONTBEG=$G(PRCTMP(440.03,CONTIEN,.5,"I")) I CONTBEG]"" S CONTBEG=$$DATE2(CONTBEG),$P(SEG,U,18)=CONTBEG
..I $G(PRCTMP(442,+PO,29,"I"))]"" D Q
...S ENDDATE=$G(PRCTMP(442,+PO,29,"I")) I ENDDATE]"" S ENDDATE=$$DATE2(ENDDATE),$P(SEG,U,9)=ENDDATE
...S BEGDATE=$G(PRCTMP(410,+PRIMREQ,21,"I")) I PRCFA("AUTOACC")["Y" I BEGDATE]"" S BEGDATE=$$DATE2(BEGDATE),$P(SEG,U,18)=BEGDATE
...Q
..S ENDDATE=$G(PRCTMP(442,+PO,29,"I")) I ENDDATE="" D NOW^%DTC S ENDDATE=$$DATE2(X),$P(SEG,U,9)=ENDDATE
..Q
.I TYCODE="E" D
..I PRCFA("MP")=21 S TOT=$G(PRCTMP(442,+PO,91,"E")),TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
..I PRCFA("MP")=1!(PRCFA("MP")=8)!(PRCFA("MP")=2) S TOT=$G(PRCTMP(442,+PO,92,"E")),TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
.I TYCODE="M" D
..I PRCFA("MP")=21 S TOT=$G(PRCTMP(442,+PO,7.2,"E")),TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
..I PRCFA("MP")=2 Q:'$D(PRCFCHG("BOC")) S TOT=$FN(TOTAMT,"",2),$P(SEG,U,27)=TOT
.I $G(VENCONT) S $P(SEG,U,33)=$E(VENCONT,1,10)
MO3E I TRCODE="SO"&(PRCFA("MP")=2) D
.S PRCFA("AUTOACC")=$E($G(PRCTMP(442,+PO,30,"E")),1) S:PRCFA("AUTOACC")="" PRCFA("AUTOACC")="N"
.S ENDDATE=$G(PRCTMP(442,+PO,29,"I")) I ENDDATE]"" S ENDDATE=$$DATE2(ENDDATE),$P(SEG,U,9)=ENDDATE
.S BEGDATE=PRCFA("OBLDATE") I BEGDATE]"" S BEGDATE=$$DATE2(BEGDATE),$P(SEG,U,18)=BEGDATE
.I TYCODE="E",PRCFA("MP")=2 S TOT=$G(PRCTMP(442,+PO,92,"E")),TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
.I TYCODE="M",PRCFA("MP")=2 Q:'$D(PRCFCHG("BOC")) S TOT=$FN(TOTAMT,"",2),$P(SEG,U,27)=TOT
.N LOOP S LOOP="",VENCONT=$O(^PRC(442,+PO,2,"AC",LOOP))
.I $G(VENCONT) S $P(SEG,U,33)=$E(VENCONT,1,10)
.Q
S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~" K PRCTMP
Q
;
DATE(X,A,B,C) ;
S FMSYR=$E(X,2,3),FMSMO=$E(X,4,5),FMSDAY=$E(X,6,7)
Q
DATE1(X) ;
Q $E(X,4,5)_$E(X,6,7)_$E(X,2,3)
DATE2(Y) ;
Q $E(Y,2,3)_U_$E(Y,4,5)_U_$E(Y,6,7)
ASKDATE(X) ;
N Y,ASKDATE
S %DT="AEX",%DT("A")=X D ^%DT
S ASKDATE=Y K %DT
Q ASKDATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU21 4762 printed Nov 22, 2024@17:13:50 Page 2
PRCFFU21 ;WISC/SJG-FMS MO3 SEGMENT ;6/25/97 16:36
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
MO3 ;BUILD 'MO3' SEGMENT
+1 ; 7 - DELIVERY DATE (FILE 442)
+2 ; 7.2 - ESTIMATED COST (FILE 442)
+3 ; 9.2 - PROMPT PAYMENT TERMS (FILE 442)
+4 ; 8.3 - PURCHASE METHOD (442.12)
+5 ; 29 - END DATE (FILE 442)
+6 ; 30 - AUTO ACCRUE (FILE 410)
+7 ; 91 - TOTAL AMOUNT (FILE 442)
+8 ; 92 - NET AMOUNT (FILE 442)
+9 ; 5 - VENDOR (FILE 442)
+10 ; .07 - PRIMARY 2237 REQUEST (FILE 442)
+11 ; 11 - VENDOR (FILE 410)
+12 ; 13 - VENDOR CONTRACT NUMBER (FILE 410)
+13 ; 21 - DATE COMMITTED (FILE 410)
+14 ; 52 - STA NO-PO NUM (FILE 410)
+15 ;
MO3A NEW SEG,DELDATE,FMSYR,FMSMO,FMSDAY,PPT,PM,TOT,CONT,START,VENID,PRIMREQ,VENCONT,CONTIEN,CONTEND,CONTBEG
+1 SET TMPLINE=TMPLINE+1
SET SEG="MO3^^^^^^^01"
+2 KILL PRCTMP
NEW DA
SET DIC=442
SET DR=".07;5;7.2;7;8.3;29;30;91;92"
SET DA=+PO
SET DIQ="PRCTMP("
SET DIQ(0)="IE"
SET DR(442.12)=".01"
SET DA(442.12)=1
DO EN^DIQ1
KILL DIC,DIQ,DR
+3 IF TRCODE="SO"
IF PRCFA("MP")=21
IF $GET(PRCCON3)
if $GET(PRCTMP(442,+PO,92,"E"))]""
SET PRCTMP(442,+PO,91,"E")=PRCTMP(442,+PO,92,"E")
MO3B Begin DoDot:1
+1 if (PRCFA("MP")=2)&(PRCFA("TT")="SO")
QUIT
+2 IF TYCODE="M"
if (PRCFA("DEL")="")&(PRCFA("DELSCH")="")
QUIT
+3 SET DELDATE=PRCTMP(442,+PO,7,"I")
+4 SET DELDATE=$$DELSCH^PRCFFU5(.DELDATE)
+5 SET X1=BEGDATE
SET X2=DELDATE
DO ^%DTC
IF X>0
SET DELDATE=BEGDATE
+6 DO DATE(DELDATE,.A,.B,.C)
SET DELDATE=FMSYR_U_FMSMO_U_FMSDAY
+7 SET $PIECE(SEG,U,9)=DELDATE
End DoDot:1
MO3C IF TRCODE="MO"
Begin DoDot:1
+1 SET PM=$GET(PRCTMP(442.12,1,.01,"I"))
+2 SET CONT=""
IF $DATA(^PRC(442,+PO,2,"AC"))\10
SET START=""
SET CONT=$ORDER(^PRC(442,+PO,2,"AC",START))
+3 IF TYCODE="E"
if PRCFMO("G/N")="G"
SET TOT=$GET(PRCTMP(442,+PO,91,"E"))
if PRCFMO("G/N")="N"
SET TOT=$GET(PRCTMP(442,+PO,92,"E"))
SET TOT=$FNUMBER(TOT,"",2)
SET $PIECE(SEG,U,27)=TOT
+4 IF TYCODE="M"
Begin DoDot:2
+5 if '$DATA(PRCFCHG("BOC"))
QUIT
+6 SET TOT=$FNUMBER(TOTAMT,"",2)
SET $PIECE(SEG,U,27)=TOT
End DoDot:2
+7 IF $GET(CONT)]""
IF TRCODE'="MO"
SET $PIECE(SEG,U,33)=$EXTRACT(CONT,1,10)
End DoDot:1
MO3D IF TRCODE="SO"&(PRCFA("MP")=21)
Begin DoDot:1
+1 SET VENID=$GET(PRCTMP(442,+PO,5,"I"))
SET PRIMREQ=$GET(PRCTMP(442,+PO,.07,"I"))
+2 SET PRCFA("AUTOACC")=$EXTRACT($GET(PRCTMP(442,+PO,30,"E")),1)
+3 IF PRIMREQ]""
Begin DoDot:2
+4 NEW DA
SET DA=+PRIMREQ
SET DIC=410
SET DR="13;21;52"
SET DIQ="PRCTMP("
SET DIQ(0)="IEN"
DO EN^DIQ1
KILL DIC,DIQ,DR
+5 IF TYCODE="M"
Begin DoDot:3
+6 NEW POIEN
SET POIEN=$GET(PRCTMP(410,PRIMREQ,52,"I"))
+7 IF POIEN]""
Begin DoDot:4
+8 NEW ORGIEN
SET ORGIEN=$GET(PRCTMP(442,POIEN,.07,"I"))
+9 DO GENDIQ^PRCFFU7(410,ORGIEN,"11;13;21","IEN","")
+10 QUIT
End DoDot:4
+11 QUIT
End DoDot:3
+12 IF PRCFA("AUTOACC")=""
SET PRCFA("AUTOACC")="N"
+13 SET VENCONT=$GET(PRCTMP(410,+PRIMREQ,13,"E"))
+14 IF VENID]""&(VENCONT]"")&($GET(PRCTMP(442,+PO,29,"I"))="")
Begin DoDot:3
+15 SET DIC="^PRC(440,"_VENID_",4,"
SET DIC(0)="MNQZ"
SET X=VENCONT
DO ^DIC
KILL DIC
+16 SET CONTIEN=+Y
+17 NEW DA
SET DIC=440
SET DR=6
SET DA=+VENID
SET DIQ="PRCTMP("
SET DIQ(0)="IEN"
SET DR(440.03)=".5;1"
SET DA(440.03)=CONTIEN
DO EN^DIQ1
KILL DIC,DIQ,DR
+18 SET CONTEND=$GET(PRCTMP(440.03,CONTIEN,1,"I"))
IF CONTEND]""
SET CONTEND=$$DATE2(CONTEND)
SET $PIECE(SEG,U,9)=CONTEND
+19 SET CONTBEG=$GET(PRCTMP(440.03,CONTIEN,.5,"I"))
IF CONTBEG]""
SET CONTBEG=$$DATE2(CONTBEG)
SET $PIECE(SEG,U,18)=CONTBEG
End DoDot:3
QUIT
+20 IF $GET(PRCTMP(442,+PO,29,"I"))]""
Begin DoDot:3
+21 SET ENDDATE=$GET(PRCTMP(442,+PO,29,"I"))
IF ENDDATE]""
SET ENDDATE=$$DATE2(ENDDATE)
SET $PIECE(SEG,U,9)=ENDDATE
+22 SET BEGDATE=$GET(PRCTMP(410,+PRIMREQ,21,"I"))
IF PRCFA("AUTOACC")["Y"
IF BEGDATE]""
SET BEGDATE=$$DATE2(BEGDATE)
SET $PIECE(SEG,U,18)=BEGDATE
+23 QUIT
End DoDot:3
QUIT
+24 SET ENDDATE=$GET(PRCTMP(442,+PO,29,"I"))
IF ENDDATE=""
DO NOW^%DTC
SET ENDDATE=$$DATE2(X)
SET $PIECE(SEG,U,9)=ENDDATE
+25 QUIT
End DoDot:2
+26 IF TYCODE="E"
Begin DoDot:2
+27 IF PRCFA("MP")=21
SET TOT=$GET(PRCTMP(442,+PO,91,"E"))
SET TOT=$FNUMBER(TOT,"",2)
SET $PIECE(SEG,U,27)=TOT
+28 IF PRCFA("MP")=1!(PRCFA("MP")=8)!(PRCFA("MP")=2)
SET TOT=$GET(PRCTMP(442,+PO,92,"E"))
SET TOT=$FNUMBER(TOT,"",2)
SET $PIECE(SEG,U,27)=TOT
End DoDot:2
+29 IF TYCODE="M"
Begin DoDot:2
+30 IF PRCFA("MP")=21
SET TOT=$GET(PRCTMP(442,+PO,7.2,"E"))
SET TOT=$FNUMBER(TOT,"",2)
SET $PIECE(SEG,U,27)=TOT
+31 IF PRCFA("MP")=2
if '$DATA(PRCFCHG("BOC"))
QUIT
SET TOT=$FNUMBER(TOTAMT,"",2)
SET $PIECE(SEG,U,27)=TOT
End DoDot:2
+32 IF $GET(VENCONT)
SET $PIECE(SEG,U,33)=$EXTRACT(VENCONT,1,10)
End DoDot:1
MO3E IF TRCODE="SO"&(PRCFA("MP")=2)
Begin DoDot:1
+1 SET PRCFA("AUTOACC")=$EXTRACT($GET(PRCTMP(442,+PO,30,"E")),1)
if PRCFA("AUTOACC")=""
SET PRCFA("AUTOACC")="N"
+2 SET ENDDATE=$GET(PRCTMP(442,+PO,29,"I"))
IF ENDDATE]""
SET ENDDATE=$$DATE2(ENDDATE)
SET $PIECE(SEG,U,9)=ENDDATE
+3 SET BEGDATE=PRCFA("OBLDATE")
IF BEGDATE]""
SET BEGDATE=$$DATE2(BEGDATE)
SET $PIECE(SEG,U,18)=BEGDATE
+4 IF TYCODE="E"
IF PRCFA("MP")=2
SET TOT=$GET(PRCTMP(442,+PO,92,"E"))
SET TOT=$FNUMBER(TOT,"",2)
SET $PIECE(SEG,U,27)=TOT
+5 IF TYCODE="M"
IF PRCFA("MP")=2
if '$DATA(PRCFCHG("BOC"))
QUIT
SET TOT=$FNUMBER(TOTAMT,"",2)
SET $PIECE(SEG,U,27)=TOT
+6 NEW LOOP
SET LOOP=""
SET VENCONT=$ORDER(^PRC(442,+PO,2,"AC",LOOP))
+7 IF $GET(VENCONT)
SET $PIECE(SEG,U,33)=$EXTRACT(VENCONT,1,10)
+8 QUIT
End DoDot:1
+9 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)=SEG_"^~"
KILL PRCTMP
+10 QUIT
+11 ;
DATE(X,A,B,C) ;
+1 SET FMSYR=$EXTRACT(X,2,3)
SET FMSMO=$EXTRACT(X,4,5)
SET FMSDAY=$EXTRACT(X,6,7)
+2 QUIT
DATE1(X) ;
+1 QUIT $EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)
DATE2(Y) ;
+1 QUIT $EXTRACT(Y,2,3)_U_$EXTRACT(Y,4,5)_U_$EXTRACT(Y,6,7)
ASKDATE(X) ;
+1 NEW Y,ASKDATE
+2 SET %DT="AEX"
SET %DT("A")=X
DO ^%DT
+3 SET ASKDATE=Y
KILL %DT
+4 QUIT ASKDATE
