- PRCHQ1C ;(WASH IRMFO)/LKG-RFQ INPUT TRANSFORMS ETC (CONT) ;9/5/96 13:25
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- STUFFITM(PRCX,D0,D1) ;Stuff Item Master file info
- N PRCDT,PRCI,PRCV,PRCW,PRCY,PRCZ,%,%H,%I,X D NOW^%DTC S PRCDT=X
- I PRCX]"" D
- . S PRCZ=$G(^PRC(441,PRCX,0)) Q:PRCZ=""
- . S $P(^PRC(444,D0,2,D1,5),U)=$P(PRCZ,U,2)
- . K ^PRC(444,D0,2,D1,2)
- . I $P($G(^PRC(441,PRCX,1,0)),U,4)>0 D
- . . S PRCY=0,PRCI=0
- . . F S PRCY=$O(^PRC(441,PRCX,1,PRCY)) Q:+PRCY'=PRCY D
- . . . Q:'$D(^PRC(441,PRCX,1,PRCY,0)) S PRCW=^(0)
- . . . S PRCI=PRCI+1,^PRC(444,D0,2,D1,2,PRCI,0)=PRCW
- . . S ^PRC(444,D0,2,D1,2,0)="^^"_PRCI_"^"_PRCI_"^"_PRCDT
- . S $P(^PRC(444,D0,2,D1,0),U,5)=$P(PRCZ,U,3)
- . S $P(^PRC(444,D0,2,D1,0),U,11)=$P(PRCZ,U,14)
- . S $P(^PRC(444,D0,2,D1,0),U,7)=$P($G(^PRC(441,PRCX,3)),U,10)
- . S $P(^PRC(444,D0,2,D1,0),U,6)=$P(PRCZ,U,5)
- . S $P(^PRC(444,D0,2,D1,0),U,9)=$P($G(^PRC(441,PRCX,3)),U,5)
- . S PRCY=$P(PRCZ,U,4)
- . I PRCY="" S $P(^PRC(444,D0,2,D1,1),U,3,7)="^^^^" Q
- . S PRCZ=$G(^PRC(441,PRCX,2,PRCY,0)) Q:PRCZ=""
- . S $P(^PRC(444,D0,2,D1,1),U,3,7)=PRCY_U_$P(PRCZ,U,4)_U_$P(PRCZ,U,2)_U_$P(PRCZ,U,7)_U_$P(PRCZ,U,6)
- . S $P(^PRC(444,D0,2,D1,0),U,8)=$P(PRCZ,U,5)
- . S PRCW=$P(PRCZ,U,8),PRCV=$P(PRCZ,U,7) S:PRCW]"" PRCW="PACKAGING MULTIPLE: "_PRCW
- . S:PRCV]"" PRCW=PRCW_"/"_$P($G(^PRCD(420.5,PRCV,0)),U)
- . S:PRCV]"" $P(^PRC(444,D0,2,D1,0),U,3)=PRCV
- . I PRCW]"" D
- . . S PRCI=$P($G(^PRC(444,D0,2,D1,2,0)),U,3)
- . . S PRCI=PRCI+1,^PRC(444,D0,2,D1,2,PRCI,0)=PRCW
- . . S ^PRC(444,D0,2,D1,2,0)="^^"_PRCI_"^"_PRCI_"^"_PRCDT
- I PRCX="" D
- . S $P(^PRC(444,D0,2,D1,5),U)="" K ^PRC(444,D0,2,D1,2)
- . S $P(^PRC(444,D0,2,D1,0),U,3,9)="^^^^^^",$P(^(0),U,11)=""
- . S $P(^PRC(444,D0,2,D1,1),U,3,7)="^^^^"
- Q
- ADMCERT(D0) ;Lookup and add Administrative Certification
- N DIR,DIC,X,Y,DIRUT,DIROUT,DTOUT,DUOUT,%,%H,%I,PRCDT,PRCI,PRCJ,PRCX,PRCY,PRCZ
- D NOW^%DTC S PRCDT=X
- S PRCJ=+$P($G(^PRC(444,D0,4,0)),U,4)
- W !,"There are currently ",PRCJ," lines of Administrative Certification."
- S DIR(0)="YA",DIR("A")="Do you wish to add a standard Administrative Certification phrase? "
- S DIR("B")="YES" D ^DIR K DIR
- I $D(DIRUT)!$D(DIROUT) S X="^" Q X
- I Y'=1 S X="" Q X
- ADMLOOP S DIC=442.7,DIC(0)="AEMZ" D ^DIC K DIC
- I $D(DUOUT)!$D(DTOUT) S X="^" Q X
- I Y<1 S X="" Q X
- S PRCX=+Y,PRCY=0,PRCJ=$P($G(^PRC(444,D0,4,0)),U,3,4),PRCI=$P(PRCJ,U),PRCJ=$P(PRCJ,U,2)
- ;Adding a blank line between each Administrative Cert.
- I PRCI>0 D
- . S PRCI=PRCI+1
- . S PRCJ=PRCJ+1
- . S ^PRC(444,D0,4,PRCI,0)=" "
- F S PRCY=$O(^PRC(442.7,PRCX,1,PRCY)) Q:+PRCY'=PRCY D
- . Q:'$D(^PRC(442.7,PRCX,1,PRCY,0)) S PRCZ=^(0)
- . S PRCI=PRCI+1,PRCJ=PRCJ+1,^PRC(444,D0,4,PRCI,0)=PRCZ
- ;I PRCI>0 S PRCI=PRCI+1,PRCJ=PRCJ+1,^PRC(444,D0,4,PRCI,0)=PRCTILDA
- S:PRCJ>0 ^PRC(444,D0,4,0)="^^"_PRCI_"^"_PRCJ_"^"_PRCDT
- W !,"Administrative Certification phrase #",PRCX," has been added."
- G ADMLOOP
- ;
- QUOTEDUE(PRCX,PRCY,PRCZ) ;Input transform for Date Quote Due in Input Template
- N X1,X2,%Y,X
- S X1=PRCX,X2=PRCY D ^%DTC I X<3 W !,"Quote Due Date must be at least 3 days after RFQ Reference Date." Q 1
- I PRCX'<PRCZ W !,"Quote Due Date must be before Required Delivery Date." Q 13
- S X=""
- Q X
- DELTOTAL(D0,D1) ;Check Delivery Total
- N PRCX,PRCY S PRCX=""
- Q:$P($G(^PRC(444,D0,2,D1,4,0)),U,4)'>0 PRCX
- S PRCX=0,PRCY=0
- F S PRCX=$O(^PRC(444,D0,2,D1,4,PRCX)) Q:+PRCX'=PRCX D
- . S PRCY=PRCY+$P($G(^PRC(444,D0,2,D1,4,PRCX,0)),U,3)
- S PRCX=+$P($G(^PRC(444,D0,2,D1,0)),U,2)
- I PRCX'=PRCY W !,"Total Quantity of Delivery Schedule does NOT equal Item Quantity.",!," ",PRCY," versus ",PRCX S PRCX=20 Q PRCX
- S PRCX=""
- Q PRCX
- NSN(PRCY) ;Validation of National Stock #
- N PRCX
- Q:PRCY="" PRCY
- I '$D(^PRC(441.2,+PRCY,0)) W !,"Invalid NSN - First 4 characters must be a FSC Code." Q 5
- S PRCX=$O(^PRC(441,"BB",PRCY,0))
- S:PRCX=PRCITMO PRCX=$O(^PRC(441,"BB",PRCY,PRCX))
- I PRCX'="" W !,"This NSN has already been assigned to Item #",PRCX Q 5
- S PRCY=""
- Q PRCY
- PREF ;User enter editing preference into file #444.4
- K DIC,DA
- I '$D(^PRC(444.4,DUZ)) D I Y<1!(+Y'=DUZ) W !,"Entry not properly added!" Q
- . K DD,DO S DIC="^PRC(444.4,",DIC(0)="LX",X=DUZ,DLAYGO=444.4,DINUM=X
- . D FILE^DICN K DIC,DLAYGO
- K DA S DA=DUZ,DIE="^PRC(444.4,",DR=1 D ^DIE K DIE,DR,DA,DTOUT,DUOUT
- Q
- EDITOR() ;Returns the chosen editor
- N X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT S X="" Q:$D(DUZ)#10'=1 X
- S X=$P($G(^PRC(444.4,DUZ,0)),U,2) I X="i"!(X="s") Q X
- S DIR(0)="SMA^i:Input Template;s:ScreenMan Form",DIR("A")="Enter Desired Input Mode: "
- S DIR("?",1)="Here you can indicate if you wish to edit in scroll mode with FileMan"
- S DIR("?")=" Input Templates or screen mode with ScreenMan"
- D ^DIR I $D(DIROUT)!$D(DIRUT)!$D(DTOUT) S X="" Q X
- Q Y
- LINENETS(D0,D1) ;Stuffs net line amounts for items in quote
- ;;Net = Unit_Price * Quantity - Volume_Discount
- N PRCX,PRCY,PRCV,PRCW,PRCDA3
- S PRCDA3=0
- F S PRCDA3=$O(^PRC(444,D0,8,D1,3,PRCDA3)) Q:+PRCDA3'=PRCDA3 D
- . S PRCV=$G(^PRC(444,D0,8,D1,3,PRCDA3,0)),PRCW=$G(^(1))
- . S PRCX=$P(PRCW,U,3)*$P(PRCV,U,2),PRCY=+$P(PRCW,U,4)
- . S PRCY=$S(PRCY>0:PRCX*PRCY/100,1:$P(PRCW,U,5))
- . S:PRCY>0 PRCX=PRCX-PRCY
- . S $P(^PRC(444,D0,8,D1,3,PRCDA3,1),U,7)=$FN(PRCX,"",2)
- Q
- METHOD(PRCX,PRCVEN) ;Additional Validation for Method of Solicitation
- N PRCERR,PRCY S PRCY=""
- Q:PRCX="m" PRCY
- I PRCVEN'["PRC(440" S PRCERR=1 G METHMSG
- S:$P($G(^PRC(440,+PRCVEN,3)),U,2)'="Y" PRCERR=1
- S:$P($G(^PRC(440,+PRCVEN,7)),U,12)="" PRCERR=1
- METHMSG I $G(PRCERR) D EN^DDIOL("Only MANUAL method is available for Non-EDI Vendor or vendor without Dun#.") Q 1
- Q PRCY
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ1C 5662 printed Feb 18, 2025@23:36:03 Page 2
- PRCHQ1C ;(WASH IRMFO)/LKG-RFQ INPUT TRANSFORMS ETC (CONT) ;9/5/96 13:25
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- STUFFITM(PRCX,D0,D1) ;Stuff Item Master file info
- +1 NEW PRCDT,PRCI,PRCV,PRCW,PRCY,PRCZ,%,%H,%I,X
- DO NOW^%DTC
- SET PRCDT=X
- +2 IF PRCX]""
- Begin DoDot:1
- +3 SET PRCZ=$GET(^PRC(441,PRCX,0))
- if PRCZ=""
- QUIT
- +4 SET $PIECE(^PRC(444,D0,2,D1,5),U)=$PIECE(PRCZ,U,2)
- +5 KILL ^PRC(444,D0,2,D1,2)
- +6 IF $PIECE($GET(^PRC(441,PRCX,1,0)),U,4)>0
- Begin DoDot:2
- +7 SET PRCY=0
- SET PRCI=0
- +8 FOR
- SET PRCY=$ORDER(^PRC(441,PRCX,1,PRCY))
- if +PRCY'=PRCY
- QUIT
- Begin DoDot:3
- +9 if '$DATA(^PRC(441,PRCX,1,PRCY,0))
- QUIT
- SET PRCW=^(0)
- +10 SET PRCI=PRCI+1
- SET ^PRC(444,D0,2,D1,2,PRCI,0)=PRCW
- End DoDot:3
- +11 SET ^PRC(444,D0,2,D1,2,0)="^^"_PRCI_"^"_PRCI_"^"_PRCDT
- End DoDot:2
- +12 SET $PIECE(^PRC(444,D0,2,D1,0),U,5)=$PIECE(PRCZ,U,3)
- +13 SET $PIECE(^PRC(444,D0,2,D1,0),U,11)=$PIECE(PRCZ,U,14)
- +14 SET $PIECE(^PRC(444,D0,2,D1,0),U,7)=$PIECE($GET(^PRC(441,PRCX,3)),U,10)
- +15 SET $PIECE(^PRC(444,D0,2,D1,0),U,6)=$PIECE(PRCZ,U,5)
- +16 SET $PIECE(^PRC(444,D0,2,D1,0),U,9)=$PIECE($GET(^PRC(441,PRCX,3)),U,5)
- +17 SET PRCY=$PIECE(PRCZ,U,4)
- +18 IF PRCY=""
- SET $PIECE(^PRC(444,D0,2,D1,1),U,3,7)="^^^^"
- QUIT
- +19 SET PRCZ=$GET(^PRC(441,PRCX,2,PRCY,0))
- if PRCZ=""
- QUIT
- +20 SET $PIECE(^PRC(444,D0,2,D1,1),U,3,7)=PRCY_U_$PIECE(PRCZ,U,4)_U_$PIECE(PRCZ,U,2)_U_$PIECE(PRCZ,U,7)_U_$PIECE(PRCZ,U,6)
- +21 SET $PIECE(^PRC(444,D0,2,D1,0),U,8)=$PIECE(PRCZ,U,5)
- +22 SET PRCW=$PIECE(PRCZ,U,8)
- SET PRCV=$PIECE(PRCZ,U,7)
- if PRCW]""
- SET PRCW="PACKAGING MULTIPLE: "_PRCW
- +23 if PRCV]""
- SET PRCW=PRCW_"/"_$PIECE($GET(^PRCD(420.5,PRCV,0)),U)
- +24 if PRCV]""
- SET $PIECE(^PRC(444,D0,2,D1,0),U,3)=PRCV
- +25 IF PRCW]""
- Begin DoDot:2
- +26 SET PRCI=$PIECE($GET(^PRC(444,D0,2,D1,2,0)),U,3)
- +27 SET PRCI=PRCI+1
- SET ^PRC(444,D0,2,D1,2,PRCI,0)=PRCW
- +28 SET ^PRC(444,D0,2,D1,2,0)="^^"_PRCI_"^"_PRCI_"^"_PRCDT
- End DoDot:2
- End DoDot:1
- +29 IF PRCX=""
- Begin DoDot:1
- +30 SET $PIECE(^PRC(444,D0,2,D1,5),U)=""
- KILL ^PRC(444,D0,2,D1,2)
- +31 SET $PIECE(^PRC(444,D0,2,D1,0),U,3,9)="^^^^^^"
- SET $PIECE(^(0),U,11)=""
- +32 SET $PIECE(^PRC(444,D0,2,D1,1),U,3,7)="^^^^"
- End DoDot:1
- +33 QUIT
- ADMCERT(D0) ;Lookup and add Administrative Certification
- +1 NEW DIR,DIC,X,Y,DIRUT,DIROUT,DTOUT,DUOUT,%,%H,%I,PRCDT,PRCI,PRCJ,PRCX,PRCY,PRCZ
- +2 DO NOW^%DTC
- SET PRCDT=X
- +3 SET PRCJ=+$PIECE($GET(^PRC(444,D0,4,0)),U,4)
- +4 WRITE !,"There are currently ",PRCJ," lines of Administrative Certification."
- +5 SET DIR(0)="YA"
- SET DIR("A")="Do you wish to add a standard Administrative Certification phrase? "
- +6 SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- +7 IF $DATA(DIRUT)!$DATA(DIROUT)
- SET X="^"
- QUIT X
- +8 IF Y'=1
- SET X=""
- QUIT X
- ADMLOOP SET DIC=442.7
- SET DIC(0)="AEMZ"
- DO ^DIC
- KILL DIC
- +1 IF $DATA(DUOUT)!$DATA(DTOUT)
- SET X="^"
- QUIT X
- +2 IF Y<1
- SET X=""
- QUIT X
- +3 SET PRCX=+Y
- SET PRCY=0
- SET PRCJ=$PIECE($GET(^PRC(444,D0,4,0)),U,3,4)
- SET PRCI=$PIECE(PRCJ,U)
- SET PRCJ=$PIECE(PRCJ,U,2)
- +4 ;Adding a blank line between each Administrative Cert.
- +5 IF PRCI>0
- Begin DoDot:1
- +6 SET PRCI=PRCI+1
- +7 SET PRCJ=PRCJ+1
- +8 SET ^PRC(444,D0,4,PRCI,0)=" "
- End DoDot:1
- +9 FOR
- SET PRCY=$ORDER(^PRC(442.7,PRCX,1,PRCY))
- if +PRCY'=PRCY
- QUIT
- Begin DoDot:1
- +10 if '$DATA(^PRC(442.7,PRCX,1,PRCY,0))
- QUIT
- SET PRCZ=^(0)
- +11 SET PRCI=PRCI+1
- SET PRCJ=PRCJ+1
- SET ^PRC(444,D0,4,PRCI,0)=PRCZ
- End DoDot:1
- +12 ;I PRCI>0 S PRCI=PRCI+1,PRCJ=PRCJ+1,^PRC(444,D0,4,PRCI,0)=PRCTILDA
- +13 if PRCJ>0
- SET ^PRC(444,D0,4,0)="^^"_PRCI_"^"_PRCJ_"^"_PRCDT
- +14 WRITE !,"Administrative Certification phrase #",PRCX," has been added."
- +15 GOTO ADMLOOP
- +16 ;
- QUOTEDUE(PRCX,PRCY,PRCZ) ;Input transform for Date Quote Due in Input Template
- +1 NEW X1,X2,%Y,X
- +2 SET X1=PRCX
- SET X2=PRCY
- DO ^%DTC
- IF X<3
- WRITE !,"Quote Due Date must be at least 3 days after RFQ Reference Date."
- QUIT 1
- +3 IF PRCX'<PRCZ
- WRITE !,"Quote Due Date must be before Required Delivery Date."
- QUIT 13
- +4 SET X=""
- +5 QUIT X
- DELTOTAL(D0,D1) ;Check Delivery Total
- +1 NEW PRCX,PRCY
- SET PRCX=""
- +2 if $PIECE($GET(^PRC(444,D0,2,D1,4,0)),U,4)'>0
- QUIT PRCX
- +3 SET PRCX=0
- SET PRCY=0
- +4 FOR
- SET PRCX=$ORDER(^PRC(444,D0,2,D1,4,PRCX))
- if +PRCX'=PRCX
- QUIT
- Begin DoDot:1
- +5 SET PRCY=PRCY+$PIECE($GET(^PRC(444,D0,2,D1,4,PRCX,0)),U,3)
- End DoDot:1
- +6 SET PRCX=+$PIECE($GET(^PRC(444,D0,2,D1,0)),U,2)
- +7 IF PRCX'=PRCY
- WRITE !,"Total Quantity of Delivery Schedule does NOT equal Item Quantity.",!," ",PRCY," versus ",PRCX
- SET PRCX=20
- QUIT PRCX
- +8 SET PRCX=""
- +9 QUIT PRCX
- NSN(PRCY) ;Validation of National Stock #
- +1 NEW PRCX
- +2 if PRCY=""
- QUIT PRCY
- +3 IF '$DATA(^PRC(441.2,+PRCY,0))
- WRITE !,"Invalid NSN - First 4 characters must be a FSC Code."
- QUIT 5
- +4 SET PRCX=$ORDER(^PRC(441,"BB",PRCY,0))
- +5 if PRCX=PRCITMO
- SET PRCX=$ORDER(^PRC(441,"BB",PRCY,PRCX))
- +6 IF PRCX'=""
- WRITE !,"This NSN has already been assigned to Item #",PRCX
- QUIT 5
- +7 SET PRCY=""
- +8 QUIT PRCY
- PREF ;User enter editing preference into file #444.4
- +1 KILL DIC,DA
- +2 IF '$DATA(^PRC(444.4,DUZ))
- Begin DoDot:1
- +3 KILL DD,DO
- SET DIC="^PRC(444.4,"
- SET DIC(0)="LX"
- SET X=DUZ
- SET DLAYGO=444.4
- SET DINUM=X
- +4 DO FILE^DICN
- KILL DIC,DLAYGO
- End DoDot:1
- IF Y<1!(+Y'=DUZ)
- WRITE !,"Entry not properly added!"
- QUIT
- +5 KILL DA
- SET DA=DUZ
- SET DIE="^PRC(444.4,"
- SET DR=1
- DO ^DIE
- KILL DIE,DR,DA,DTOUT,DUOUT
- +6 QUIT
- EDITOR() ;Returns the chosen editor
- +1 NEW X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT
- SET X=""
- if $DATA(DUZ)#10'=1
- QUIT X
- +2 SET X=$PIECE($GET(^PRC(444.4,DUZ,0)),U,2)
- IF X="i"!(X="s")
- QUIT X
- +3 SET DIR(0)="SMA^i:Input Template;s:ScreenMan Form"
- SET DIR("A")="Enter Desired Input Mode: "
- +4 SET DIR("?",1)="Here you can indicate if you wish to edit in scroll mode with FileMan"
- +5 SET DIR("?")=" Input Templates or screen mode with ScreenMan"
- +6 DO ^DIR
- IF $DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)
- SET X=""
- QUIT X
- +7 QUIT Y
- LINENETS(D0,D1) ;Stuffs net line amounts for items in quote
- +1 ;;Net = Unit_Price * Quantity - Volume_Discount
- +2 NEW PRCX,PRCY,PRCV,PRCW,PRCDA3
- +3 SET PRCDA3=0
- +4 FOR
- SET PRCDA3=$ORDER(^PRC(444,D0,8,D1,3,PRCDA3))
- if +PRCDA3'=PRCDA3
- QUIT
- Begin DoDot:1
- +5 SET PRCV=$GET(^PRC(444,D0,8,D1,3,PRCDA3,0))
- SET PRCW=$GET(^(1))
- +6 SET PRCX=$PIECE(PRCW,U,3)*$PIECE(PRCV,U,2)
- SET PRCY=+$PIECE(PRCW,U,4)
- +7 SET PRCY=$SELECT(PRCY>0:PRCX*PRCY/100,1:$PIECE(PRCW,U,5))
- +8 if PRCY>0
- SET PRCX=PRCX-PRCY
- +9 SET $PIECE(^PRC(444,D0,8,D1,3,PRCDA3,1),U,7)=$FNUMBER(PRCX,"",2)
- End DoDot:1
- +10 QUIT
- METHOD(PRCX,PRCVEN) ;Additional Validation for Method of Solicitation
- +1 NEW PRCERR,PRCY
- SET PRCY=""
- +2 if PRCX="m"
- QUIT PRCY
- +3 IF PRCVEN'["PRC(440"
- SET PRCERR=1
- GOTO METHMSG
- +4 if $PIECE($GET(^PRC(440,+PRCVEN,3)),U,2)'="Y"
- SET PRCERR=1
- +5 if $PIECE($GET(^PRC(440,+PRCVEN,7)),U,12)=""
- SET PRCERR=1
- METHMSG IF $GET(PRCERR)
- DO EN^DDIOL("Only MANUAL method is available for Non-EDI Vendor or vendor without Dun#.")
- QUIT 1
- +1 QUIT PRCY
