Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCFFU21

PRCFFU21.m

Go to the documentation of this file. 
  1. PRCFFU21 ;WISC/SJG-FMS MO3 SEGMENT ;6/25/97  16:36
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. MO3 ;BUILD 'MO3' SEGMENT
  1.  ; 7   - DELIVERY DATE (FILE 442)
  1.  ; 7.2 - ESTIMATED COST (FILE 442)
  1.  ; 9.2 - PROMPT PAYMENT TERMS (FILE 442)
  1.  ; 8.3 - PURCHASE METHOD (442.12)
  1.  ; 29  - END DATE (FILE 442)
  1.  ; 30  - AUTO ACCRUE (FILE 410)
  1.  ; 91  - TOTAL AMOUNT (FILE 442)
  1.  ; 92  - NET AMOUNT (FILE 442)
  1.  ; 5   - VENDOR (FILE 442)
  1.  ; .07 - PRIMARY 2237 REQUEST (FILE 442)
  1.  ; 11  - VENDOR (FILE 410)
  1.  ; 13  - VENDOR CONTRACT NUMBER (FILE 410)
  1.  ; 21  - DATE COMMITTED (FILE 410)
  1.  ; 52  - STA NO-PO NUM (FILE 410)
  1.  ;
  1. MO3A N SEG,DELDATE,FMSYR,FMSMO,FMSDAY,PPT,PM,TOT,CONT,START,VENID,PRIMREQ,VENCONT,CONTIEN,CONTEND,CONTBEG
  1.  S TMPLINE=TMPLINE+1,SEG="MO3^^^^^^^01"
  1.  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
  1.  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")
  1. MO3B D
  1.  .Q:(PRCFA("MP")=2)&(PRCFA("TT")="SO")
  1.  .I TYCODE="M" Q:(PRCFA("DEL")="")&(PRCFA("DELSCH")="")
  1.  .S DELDATE=PRCTMP(442,+PO,7,"I")
  1.  .S DELDATE=$$DELSCH^PRCFFU5(.DELDATE)
  1.  .S X1=BEGDATE,X2=DELDATE D ^%DTC I X>0 S DELDATE=BEGDATE
  1.  .D DATE(DELDATE,.A,.B,.C) S DELDATE=FMSYR_U_FMSMO_U_FMSDAY
  1.  .S $P(SEG,U,9)=DELDATE
  1. MO3C I TRCODE="MO" D
  1.  .S PM=$G(PRCTMP(442.12,1,.01,"I"))
  1.  .S CONT="" I $D(^PRC(442,+PO,2,"AC"))\10 S START="",CONT=$O(^PRC(442,+PO,2,"AC",START))
  1.  .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
  1.  .I TYCODE="M" D 
  1.  ..Q:'$D(PRCFCHG("BOC"))
  1.  ..S TOT=$FN(TOTAMT,"",2),$P(SEG,U,27)=TOT
  1.  .I $G(CONT)]"" I TRCODE'="MO" S $P(SEG,U,33)=$E(CONT,1,10)
  1. MO3D I TRCODE="SO"&(PRCFA("MP")=21) D
  1.  .S VENID=$G(PRCTMP(442,+PO,5,"I")),PRIMREQ=$G(PRCTMP(442,+PO,.07,"I"))
  1.  .S PRCFA("AUTOACC")=$E($G(PRCTMP(442,+PO,30,"E")),1)
  1.  .I PRIMREQ]"" D
  1.  ..N DA S DA=+PRIMREQ,DIC=410,DR="13;21;52",DIQ="PRCTMP(",DIQ(0)="IEN" D EN^DIQ1 K DIC,DIQ,DR
  1.  ..I TYCODE="M" D
  1.  ...N POIEN S POIEN=$G(PRCTMP(410,PRIMREQ,52,"I"))
  1.  ...I POIEN]"" D
  1.  ....N ORGIEN S ORGIEN=$G(PRCTMP(442,POIEN,.07,"I"))
  1.  ....D GENDIQ^PRCFFU7(410,ORGIEN,"11;13;21","IEN","")
  1.  ....Q
  1.  ...Q
  1.  ..I PRCFA("AUTOACC")="" S PRCFA("AUTOACC")="N"
  1.  ..S VENCONT=$G(PRCTMP(410,+PRIMREQ,13,"E"))
  1.  ..I VENID]""&(VENCONT]"")&($G(PRCTMP(442,+PO,29,"I"))="") D  Q
  1.  ...S DIC="^PRC(440,"_VENID_",4,",DIC(0)="MNQZ",X=VENCONT D ^DIC K DIC
  1.  ...S CONTIEN=+Y
  1.  ...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
  1.  ...S CONTEND=$G(PRCTMP(440.03,CONTIEN,1,"I")) I CONTEND]"" S CONTEND=$$DATE2(CONTEND),$P(SEG,U,9)=CONTEND
  1.  ...S CONTBEG=$G(PRCTMP(440.03,CONTIEN,.5,"I")) I CONTBEG]"" S CONTBEG=$$DATE2(CONTBEG),$P(SEG,U,18)=CONTBEG
  1.  ..I $G(PRCTMP(442,+PO,29,"I"))]"" D  Q
  1.  ...S ENDDATE=$G(PRCTMP(442,+PO,29,"I")) I ENDDATE]"" S ENDDATE=$$DATE2(ENDDATE),$P(SEG,U,9)=ENDDATE
  1.  ...S BEGDATE=$G(PRCTMP(410,+PRIMREQ,21,"I")) I PRCFA("AUTOACC")["Y" I BEGDATE]"" S BEGDATE=$$DATE2(BEGDATE),$P(SEG,U,18)=BEGDATE
  1.  ...Q
  1.  ..S ENDDATE=$G(PRCTMP(442,+PO,29,"I")) I ENDDATE="" D NOW^%DTC S ENDDATE=$$DATE2(X),$P(SEG,U,9)=ENDDATE
  1.  ..Q
  1.  .I TYCODE="E" D
  1.  ..I PRCFA("MP")=21 S TOT=$G(PRCTMP(442,+PO,91,"E")),TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
  1.  ..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
  1.  .I TYCODE="M" D 
  1.  ..I PRCFA("MP")=21 S TOT=$G(PRCTMP(442,+PO,7.2,"E")),TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
  1.  ..I PRCFA("MP")=2 Q:'$D(PRCFCHG("BOC"))  S TOT=$FN(TOTAMT,"",2),$P(SEG,U,27)=TOT
  1.  .I $G(VENCONT) S $P(SEG,U,33)=$E(VENCONT,1,10)
  1. MO3E I TRCODE="SO"&(PRCFA("MP")=2) D
  1.  .S PRCFA("AUTOACC")=$E($G(PRCTMP(442,+PO,30,"E")),1) S:PRCFA("AUTOACC")="" PRCFA("AUTOACC")="N"
  1.  .S ENDDATE=$G(PRCTMP(442,+PO,29,"I")) I ENDDATE]"" S ENDDATE=$$DATE2(ENDDATE),$P(SEG,U,9)=ENDDATE
  1.  .S BEGDATE=PRCFA("OBLDATE") I BEGDATE]"" S BEGDATE=$$DATE2(BEGDATE),$P(SEG,U,18)=BEGDATE
  1.  .I TYCODE="E",PRCFA("MP")=2 S TOT=$G(PRCTMP(442,+PO,92,"E")),TOT=$FN(TOT,"",2),$P(SEG,U,27)=TOT
  1.  .I TYCODE="M",PRCFA("MP")=2 Q:'$D(PRCFCHG("BOC"))  S TOT=$FN(TOTAMT,"",2),$P(SEG,U,27)=TOT
  1.  .N LOOP S LOOP="",VENCONT=$O(^PRC(442,+PO,2,"AC",LOOP))
  1.  .I $G(VENCONT) S $P(SEG,U,33)=$E(VENCONT,1,10)
  1.  .Q
  1.  S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~" K PRCTMP
  1.  Q
  1.  ;
  1. DATE(X,A,B,C) ;
  1.  S FMSYR=$E(X,2,3),FMSMO=$E(X,4,5),FMSDAY=$E(X,6,7)
  1.  Q
  1. DATE1(X) ;
  1.  Q $E(X,4,5)_$E(X,6,7)_$E(X,2,3)
  1. DATE2(Y) ;
  1.  Q $E(Y,2,3)_U_$E(Y,4,5)_U_$E(Y,6,7)
  1. ASKDATE(X) ;
  1.  N Y,ASKDATE
  1.  S %DT="AEX",%DT("A")=X D ^%DT
  1.  S ASKDATE=Y K %DT
  1.  Q ASKDATE