- PRCUFCB ;WISC/SJG-FMS MO3 SEGMENT FOR CONVERSION ONLY ;11/29/93 09:45
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ; Routine is modification of PRCFFU21 for conversion processing
- 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)
- ; 91 - TOTAL AMOUNT (FILE 442)
- ; 92 - NET AMOUNT (FILE 442)
- ; 5 - VENDOR (FILE 442)
- ; .07 - PRIMARY 2237 REQUEST (FILE 442)
- ; 13 - VENDOR CONTRACT NUMBER (FILE 410)
- ; 21 - DATE COMMITTED (FILE 410)
- ; 33 - END DATE FOR 1358 (FILE 410)
- ; 34 - AUTO ACCRUE (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;91;92",DA=+PO,DIQ="PRCTMP(",DIQ(0)="IE",DR(442.12)=".01",DA(442.12)=1 D EN^DIQ1 K DIC,DIQ,DR
- MO3B D
- .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" D
- .S VENID=$G(PRCTMP(442,+PO,5,"I")),PRIMREQ=$G(PRCTMP(442,+PO,.07,"I"))
- .S PRCFA("AUTOACC")=""
- .I PRIMREQ]"" D
- ..N DA S DA=+PRIMREQ,DIC=410,DR="13;21;33;34;52",DIQ="PRCTMP(",DIQ(0)="IEN" D EN^DIQ1 K DIC,DIQ,DR
- ..S PRCFA("AUTOACC")=$E($G(PRCTMP(410,+PRIMREQ,34,"E")),1)
- ..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;33;34","IEN","")
- ....S PRCFA("AUTOACC")=$E($G(PRCTMP(410,ORGIEN,34,"E")),1)
- ....Q
- ...Q
- ..I PRCFA("AUTOACC")="" S PRCFA("AUTOACC")="N"
- ..S VENCONT=$G(PRCTMP(410,+PRIMREQ,13,"E"))
- ..I VENID]""&(VENCONT]"")&($G(PRCTMP(410,+PRIMREQ,33,"I"))="") D
- ...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]"" D DATE(CONTEND,.A,.B,.C) S CONTEND=FMSYR_U_FMSMO_U_FMSDAY,$P(SEG,U,9)=CONTEND
- ...S CONTBEG=$G(PRCTMP(440.03,CONTIEN,.5,"I")) I CONTBEG]"" D DATE(CONTBEG,.A,.B,.C) S CONTBEG=FMSYR_U_FMSMO_U_FMSDAY,$P(SEG,U,18)=CONTBEG
- ..I $G(PRCTMP(410,+PRIMREQ,33,"I"))]"" D
- ...S ENDDATE=$G(PRCTMP(410,+PRIMREQ,33,"I")) I ENDDATE]"" D DATE(ENDDATE,.A,.B,.C) S ENDDATE=FMSYR_U_FMSMO_U_FMSDAY,$P(SEG,U,9)=ENDDATE
- ...S BEGDATE=$G(PRCTMP(410,+PRIMREQ,21,"I")) I PRCFA("AUTOACC")["Y" I BEGDATE]"" D DATE(BEGDATE,.A,.B,.C) S BEGDATE=FMSYR_U_FMSMO_U_FMSDAY,$P(SEG,U,18)=BEGDATE
- ...Q
- ..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)
- 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)
- Q
- 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[HPRCUFCB 4062 printed Mar 13, 2025@21:24:28 Page 2
- PRCUFCB ;WISC/SJG-FMS MO3 SEGMENT FOR CONVERSION ONLY ;11/29/93 09:45
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 ; Routine is modification of PRCFFU21 for conversion processing
- 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 ; 91 - TOTAL AMOUNT (FILE 442)
- +6 ; 92 - NET AMOUNT (FILE 442)
- +7 ; 5 - VENDOR (FILE 442)
- +8 ; .07 - PRIMARY 2237 REQUEST (FILE 442)
- +9 ; 13 - VENDOR CONTRACT NUMBER (FILE 410)
- +10 ; 21 - DATE COMMITTED (FILE 410)
- +11 ; 33 - END DATE FOR 1358 (FILE 410)
- +12 ; 34 - AUTO ACCRUE (FILE 410)
- +13 ;
- 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;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
- MO3B Begin DoDot:1
- +1 IF TYCODE="M"
- if (PRCFA("DEL")="")&(PRCFA("DELSCH")="")
- QUIT
- +2 SET DELDATE=PRCTMP(442,+PO,7,"I")
- +3 SET DELDATE=$$DELSCH^PRCFFU5(.DELDATE)
- +4 SET X1=BEGDATE
- SET X2=DELDATE
- DO ^%DTC
- IF X>0
- SET DELDATE=BEGDATE
- +5 DO DATE(DELDATE,.A,.B,.C)
- SET DELDATE=FMSYR_U_FMSMO_U_FMSDAY
- +6 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"
- Begin DoDot:1
- +1 SET VENID=$GET(PRCTMP(442,+PO,5,"I"))
- SET PRIMREQ=$GET(PRCTMP(442,+PO,.07,"I"))
- +2 SET PRCFA("AUTOACC")=""
- +3 IF PRIMREQ]""
- Begin DoDot:2
- +4 NEW DA
- SET DA=+PRIMREQ
- SET DIC=410
- SET DR="13;21;33;34;52"
- SET DIQ="PRCTMP("
- SET DIQ(0)="IEN"
- DO EN^DIQ1
- KILL DIC,DIQ,DR
- +5 SET PRCFA("AUTOACC")=$EXTRACT($GET(PRCTMP(410,+PRIMREQ,34,"E")),1)
- +6 IF TYCODE="M"
- Begin DoDot:3
- +7 NEW POIEN
- SET POIEN=$GET(PRCTMP(410,PRIMREQ,52,"I"))
- +8 IF POIEN]""
- Begin DoDot:4
- +9 NEW ORGIEN
- SET ORGIEN=$GET(PRCTMP(442,POIEN,.07,"I"))
- +10 DO GENDIQ^PRCFFU7(410,ORGIEN,"11;13;21;33;34","IEN","")
- +11 SET PRCFA("AUTOACC")=$EXTRACT($GET(PRCTMP(410,ORGIEN,34,"E")),1)
- +12 QUIT
- End DoDot:4
- +13 QUIT
- End DoDot:3
- +14 IF PRCFA("AUTOACC")=""
- SET PRCFA("AUTOACC")="N"
- +15 SET VENCONT=$GET(PRCTMP(410,+PRIMREQ,13,"E"))
- +16 IF VENID]""&(VENCONT]"")&($GET(PRCTMP(410,+PRIMREQ,33,"I"))="")
- Begin DoDot:3
- +17 SET DIC="^PRC(440,"_VENID_",4,"
- SET DIC(0)="MNQZ"
- SET X=VENCONT
- DO ^DIC
- KILL DIC
- +18 SET CONTIEN=+Y
- +19 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
- +20 SET CONTEND=$GET(PRCTMP(440.03,CONTIEN,1,"I"))
- IF CONTEND]""
- DO DATE(CONTEND,.A,.B,.C)
- SET CONTEND=FMSYR_U_FMSMO_U_FMSDAY
- SET $PIECE(SEG,U,9)=CONTEND
- +21 SET CONTBEG=$GET(PRCTMP(440.03,CONTIEN,.5,"I"))
- IF CONTBEG]""
- DO DATE(CONTBEG,.A,.B,.C)
- SET CONTBEG=FMSYR_U_FMSMO_U_FMSDAY
- SET $PIECE(SEG,U,18)=CONTBEG
- End DoDot:3
- +22 IF $GET(PRCTMP(410,+PRIMREQ,33,"I"))]""
- Begin DoDot:3
- +23 SET ENDDATE=$GET(PRCTMP(410,+PRIMREQ,33,"I"))
- IF ENDDATE]""
- DO DATE(ENDDATE,.A,.B,.C)
- SET ENDDATE=FMSYR_U_FMSMO_U_FMSDAY
- SET $PIECE(SEG,U,9)=ENDDATE
- +24 SET BEGDATE=$GET(PRCTMP(410,+PRIMREQ,21,"I"))
- IF PRCFA("AUTOACC")["Y"
- IF BEGDATE]""
- DO DATE(BEGDATE,.A,.B,.C)
- SET BEGDATE=FMSYR_U_FMSMO_U_FMSDAY
- SET $PIECE(SEG,U,18)=BEGDATE
- +25 QUIT
- End DoDot:3
- +26 QUIT
- End DoDot:2
- +27 IF TYCODE="E"
- Begin DoDot:2
- +28 IF PRCFA("MP")=21
- SET TOT=$GET(PRCTMP(442,+PO,91,"E"))
- SET TOT=$FNUMBER(TOT,"",2)
- SET $PIECE(SEG,U,27)=TOT
- +29 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
- +30 IF TYCODE="M"
- Begin DoDot:2
- +31 IF PRCFA("MP")=21
- SET TOT=$GET(PRCTMP(442,+PO,7.2,"E"))
- SET TOT=$FNUMBER(TOT,"",2)
- SET $PIECE(SEG,U,27)=TOT
- +32 IF PRCFA("MP")=2
- if '$DATA(PRCFCHG("BOC"))
- QUIT
- SET TOT=$FNUMBER(TOTAMT,"",2)
- SET $PIECE(SEG,U,27)=TOT
- End DoDot:2
- +33 IF $GET(VENCONT)
- SET $PIECE(SEG,U,33)=$EXTRACT(VENCONT,1,10)
- End DoDot:1
- +34 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)=SEG_"^~"
- KILL PRCTMP
- +35 QUIT
- +36 ;
- 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)
- +2 QUIT
- 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
