- PRCHQ1 ;(WASH ISC)/LKG-RFQ ;8/22/96 17:25
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- IT1 ;Input Transform File 444, Field #14
- N Z0,DIC
- S Z0=$S($P($G(^PRC(444,D0,0)),U,10)]"":$P(^(0),U,10),1:$E($P($G(^PRC(444,D0,0)),U),1,3)) K:'Z0 X Q:'Z0
- S DIC="^PRC(411,Z0,1,",DIC(0)="QEM" D ^DIC S X=+Y K:Y'>0 X
- Q
- OT1 ;Output Transform File 444, Field #14
- N Z0
- Q:Y']""
- S Z0=$S($P($G(^PRC(444,D0,0)),U,10)]"":$P(^(0),U,10),1:$E($P($G(^PRC(444,D0,0)),U),1,3)) Q:'Z0
- S Y=$P($S($D(^PRC(411,Z0,1,Y,0))#10:^(0),1:""),U)
- Q
- EH1 ;Executable Help File 444, Field #14
- N D,Z0,DIC
- S X="?",Z0=$S($P($G(^PRC(444,D0,0)),U,10)]"":$P(^(0),U,10),1:$E($P($G(^PRC(444,D0,0)),U),1,3)) Q:'Z0
- S DIC="^PRC(411,Z0,1,",DIC(0)="QEM" D ^DIC
- Q
- IT2 ;Part of input transform for File 444, Field #.01
- ;Validate that RFQ number based on an existing 2237 number
- ;and work sheet status
- N PRCX,Y,Z
- D
- . S PRCX=$P(X,"-",1,5),Y=$O(^PRCS(410,"B",PRCX,"")) I Y'?1.N K X Q
- . I ";2;3;4;"'[(";"_$P($G(^PRCS(410,Y,0)),U,4)_";") K X Q
- . S Z=$P($G(^PRC(443,Y,0)),U,7) I Z="" K X Q
- . I ";70;80;"'[(";"_$P($G(^PRCD(442.3,Z,0)),U,2)_";") K X Q
- Q
- QUOTEDUE ;Input transform for Date Quote Due
- N X1,X2,%Y,PRCX
- S PRCX=X,X1=X,X2=$$GET^DDSVAL(444,DA,1,"","I") D ^%DTC
- I X<3 D Q
- . D HLP^DDSUTL("Quote Due Date must be at least 3 days after RFQ Reference Date.")
- . S DDSERROR=1
- S X=PRCX
- I X'<$$GET^DDSVAL(444,DA,13,"","I") D Q
- . D HLP^DDSUTL("Quote Due Date must be before Required Delivery Date.")
- . S DDSERROR=1
- Q
- NSN ;Additional Validation of National Stock Number in ScreenMan
- Q:$G(X)=""
- N PRCX
- I '$D(^PRC(441.2,+X,0)) D Q
- . D HLP^DDSUTL("Invalid NSN - First 4 characters must be a FSC Code.")
- . S DDSERROR=1
- S PRCX=$O(^PRC(441,"BB",X,0))
- S:PRCX=$$GET^DDSVAL(444.019,.DA,1,"","I") PRCX=$O(^PRC(441,"BB",X,PRCX))
- I PRCX'="" D Q
- . S PRCX="This NSN has already been assigned to Item # "_PRCX
- . D HLP^DDSUTL(PRCX) S DDSERROR=1
- Q
- STUFFITM ;Stuff Item Description, National Stock #, FSC, & SIC Code upon change
- ;of referenced Item Master #
- N PRCX,PRCY,PRCZ S PRCX=X
- I PRCX?1.N D
- . S PRCZ=$G(^PRC(441,PRCX,0))
- . D PUT^DDSVAL(444.019,.DA,1.6,$P(PRCZ,U,2))
- . D PUT^DDSVAL(444.019,.DA,1.5,"^PRC(441,PRCX,1)")
- . D PUT^DDSVAL(444.019,.DA,4,$P(PRCZ,U,3))
- . S PRCY=$P(PRCZ,U,14) S:PRCY="" PRCY="@"
- . D PUT^DDSVAL(444.019,.DA,12,PRCY,"",$S(PRCY'="@":"I",1:"E"))
- S PRCY=$S(PRCX="":"",1:$P($G(^PRC(441,PRCX,3)),U,10))
- D:PRCY?1.N PUT^DDSVAL(444.019,.DA,6,PRCY,"","I")
- S PRCY=$S($G(DDSOLD)]""&($G(PRCX)=""):"@",$G(PRCX)="":"",1:$P($G(^PRC(441,PRCX,0)),U,5))
- D:PRCY'="" PUT^DDSVAL(444.019,.DA,5,PRCY,"","E")
- S PRCY=$S($G(DDSOLD)]""&($G(PRCX)=""):"@",$G(PRCX)="":"",1:$P($G(^PRC(441,PRCX,3)),U,5))
- D:PRCY'="" PUT^DDSVAL(444.019,.DA,8,PRCY,"","E")
- S PRCY=$S($G(DDSOLD)]""&($G(PRCX)=""):"@",$G(PRCX)="":"",1:$P($G(^PRC(441,PRCX,0)),U,4))
- I PRCY="@" D
- . N PRCI
- . F PRCI=13,14,14.1,14.2,14.3 D PUT^DDSVAL(444.019,.DA,PRCI,PRCY)
- I PRCY?1.N D
- . N PRCW,PRCV
- . D PUT^DDSVAL(444.019,.DA,13,PRCY,"","I")
- . S PRCZ=$G(^PRC(441,PRCX,2,PRCY,0)) Q:PRCZ=""
- . S PRCW(1)=$P(PRCZ,U,8),PRCV=$P(PRCZ,U,7) S:PRCW(1)]"" PRCW(1)="PACKAGING MULTIPLE: "_PRCW(1)
- . S:PRCV]"" PRCW(1)=PRCW(1)_"/"_$P($G(^PRCD(420.5,PRCV,0)),U)
- . D:PRCW(1)]"" PUT^DDSVAL(444.019,.DA,1.5,"PRCW","","A")
- . D PUT^DDSVAL(444.019,.DA,14.1,$P(PRCZ,U,2))
- . D PUT^DDSVAL(444.019,.DA,14.2,$P(PRCZ,U,7),"","I")
- . D PUT^DDSVAL(444.019,.DA,14.3,$P(PRCZ,U,6),"","I")
- . S PRCY=$P(PRCZ,U,5) S:PRCY="" PRCY="@"
- . D PUT^DDSVAL(444.019,.DA,7,PRCY)
- . S PRCZ=$P(PRCZ,U,4) S:PRCZ="" PRCZ="@"
- . D PUT^DDSVAL(444.019,.DA,14,PRCZ)
- Q
- PA(PRCX) ;Verify Purchasing Agent has Commercial Phone
- Q:$G(PRCX)=""
- I $P($G(^VA(200,+PRCX,.13)),U,5)="" D
- . D HLP^DDSUTL("Contracting Officer lacks Commercial Phone #")
- . S DDSERROR=1
- Q
- ESIG(PRCX) ;Verifies that editor has ESIG on file
- I $G(PRCX)]"",$P($G(^VA(200,PRCX,20)),U,4)]"" Q 1
- W !,"*** You must have an Electronic Signature Code on file to use this option!",!
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ1 4084 printed Jan 18, 2025@03:10:42 Page 2
- PRCHQ1 ;(WASH ISC)/LKG-RFQ ;8/22/96 17:25
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- IT1 ;Input Transform File 444, Field #14
- +1 NEW Z0,DIC
- +2 SET Z0=$SELECT($PIECE($GET(^PRC(444,D0,0)),U,10)]"":$PIECE(^(0),U,10),1:$EXTRACT($PIECE($GET(^PRC(444,D0,0)),U),1,3))
- if 'Z0
- KILL X
- if 'Z0
- QUIT
- +3 SET DIC="^PRC(411,Z0,1,"
- SET DIC(0)="QEM"
- DO ^DIC
- SET X=+Y
- if Y'>0
- KILL X
- +4 QUIT
- OT1 ;Output Transform File 444, Field #14
- +1 NEW Z0
- +2 if Y']""
- QUIT
- +3 SET Z0=$SELECT($PIECE($GET(^PRC(444,D0,0)),U,10)]"":$PIECE(^(0),U,10),1:$EXTRACT($PIECE($GET(^PRC(444,D0,0)),U),1,3))
- if 'Z0
- QUIT
- +4 SET Y=$PIECE($SELECT($DATA(^PRC(411,Z0,1,Y,0))#10:^(0),1:""),U)
- +5 QUIT
- EH1 ;Executable Help File 444, Field #14
- +1 NEW D,Z0,DIC
- +2 SET X="?"
- SET Z0=$SELECT($PIECE($GET(^PRC(444,D0,0)),U,10)]"":$PIECE(^(0),U,10),1:$EXTRACT($PIECE($GET(^PRC(444,D0,0)),U),1,3))
- if 'Z0
- QUIT
- +3 SET DIC="^PRC(411,Z0,1,"
- SET DIC(0)="QEM"
- DO ^DIC
- +4 QUIT
- IT2 ;Part of input transform for File 444, Field #.01
- +1 ;Validate that RFQ number based on an existing 2237 number
- +2 ;and work sheet status
- +3 NEW PRCX,Y,Z
- +4 Begin DoDot:1
- +5 SET PRCX=$PIECE(X,"-",1,5)
- SET Y=$ORDER(^PRCS(410,"B",PRCX,""))
- IF Y'?1.N
- KILL X
- QUIT
- +6 IF ";2;3;4;"'[(";"_$PIECE($GET(^PRCS(410,Y,0)),U,4)_";")
- KILL X
- QUIT
- +7 SET Z=$PIECE($GET(^PRC(443,Y,0)),U,7)
- IF Z=""
- KILL X
- QUIT
- +8 IF ";70;80;"'[(";"_$PIECE($GET(^PRCD(442.3,Z,0)),U,2)_";")
- KILL X
- QUIT
- End DoDot:1
- +9 QUIT
- QUOTEDUE ;Input transform for Date Quote Due
- +1 NEW X1,X2,%Y,PRCX
- +2 SET PRCX=X
- SET X1=X
- SET X2=$$GET^DDSVAL(444,DA,1,"","I")
- DO ^%DTC
- +3 IF X<3
- Begin DoDot:1
- +4 DO HLP^DDSUTL("Quote Due Date must be at least 3 days after RFQ Reference Date.")
- +5 SET DDSERROR=1
- End DoDot:1
- QUIT
- +6 SET X=PRCX
- +7 IF X'<$$GET^DDSVAL(444,DA,13,"","I")
- Begin DoDot:1
- +8 DO HLP^DDSUTL("Quote Due Date must be before Required Delivery Date.")
- +9 SET DDSERROR=1
- End DoDot:1
- QUIT
- +10 QUIT
- NSN ;Additional Validation of National Stock Number in ScreenMan
- +1 if $GET(X)=""
- QUIT
- +2 NEW PRCX
- +3 IF '$DATA(^PRC(441.2,+X,0))
- Begin DoDot:1
- +4 DO HLP^DDSUTL("Invalid NSN - First 4 characters must be a FSC Code.")
- +5 SET DDSERROR=1
- End DoDot:1
- QUIT
- +6 SET PRCX=$ORDER(^PRC(441,"BB",X,0))
- +7 if PRCX=$$GET^DDSVAL(444.019,.DA,1,"","I")
- SET PRCX=$ORDER(^PRC(441,"BB",X,PRCX))
- +8 IF PRCX'=""
- Begin DoDot:1
- +9 SET PRCX="This NSN has already been assigned to Item # "_PRCX
- +10 DO HLP^DDSUTL(PRCX)
- SET DDSERROR=1
- End DoDot:1
- QUIT
- +11 QUIT
- STUFFITM ;Stuff Item Description, National Stock #, FSC, & SIC Code upon change
- +1 ;of referenced Item Master #
- +2 NEW PRCX,PRCY,PRCZ
- SET PRCX=X
- +3 IF PRCX?1.N
- Begin DoDot:1
- +4 SET PRCZ=$GET(^PRC(441,PRCX,0))
- +5 DO PUT^DDSVAL(444.019,.DA,1.6,$PIECE(PRCZ,U,2))
- +6 DO PUT^DDSVAL(444.019,.DA,1.5,"^PRC(441,PRCX,1)")
- +7 DO PUT^DDSVAL(444.019,.DA,4,$PIECE(PRCZ,U,3))
- +8 SET PRCY=$PIECE(PRCZ,U,14)
- if PRCY=""
- SET PRCY="@"
- +9 DO PUT^DDSVAL(444.019,.DA,12,PRCY,"",$SELECT(PRCY'="@":"I",1:"E"))
- End DoDot:1
- +10 SET PRCY=$SELECT(PRCX="":"",1:$PIECE($GET(^PRC(441,PRCX,3)),U,10))
- +11 if PRCY?1.N
- DO PUT^DDSVAL(444.019,.DA,6,PRCY,"","I")
- +12 SET PRCY=$SELECT($GET(DDSOLD)]""&($GET(PRCX)=""):"@",$GET(PRCX)="":"",1:$PIECE($GET(^PRC(441,PRCX,0)),U,5))
- +13 if PRCY'=""
- DO PUT^DDSVAL(444.019,.DA,5,PRCY,"","E")
- +14 SET PRCY=$SELECT($GET(DDSOLD)]""&($GET(PRCX)=""):"@",$GET(PRCX)="":"",1:$PIECE($GET(^PRC(441,PRCX,3)),U,5))
- +15 if PRCY'=""
- DO PUT^DDSVAL(444.019,.DA,8,PRCY,"","E")
- +16 SET PRCY=$SELECT($GET(DDSOLD)]""&($GET(PRCX)=""):"@",$GET(PRCX)="":"",1:$PIECE($GET(^PRC(441,PRCX,0)),U,4))
- +17 IF PRCY="@"
- Begin DoDot:1
- +18 NEW PRCI
- +19 FOR PRCI=13,14,14.1,14.2,14.3
- DO PUT^DDSVAL(444.019,.DA,PRCI,PRCY)
- End DoDot:1
- +20 IF PRCY?1.N
- Begin DoDot:1
- +21 NEW PRCW,PRCV
- +22 DO PUT^DDSVAL(444.019,.DA,13,PRCY,"","I")
- +23 SET PRCZ=$GET(^PRC(441,PRCX,2,PRCY,0))
- if PRCZ=""
- QUIT
- +24 SET PRCW(1)=$PIECE(PRCZ,U,8)
- SET PRCV=$PIECE(PRCZ,U,7)
- if PRCW(1)]""
- SET PRCW(1)="PACKAGING MULTIPLE: "_PRCW(1)
- +25 if PRCV]""
- SET PRCW(1)=PRCW(1)_"/"_$PIECE($GET(^PRCD(420.5,PRCV,0)),U)
- +26 if PRCW(1)]""
- DO PUT^DDSVAL(444.019,.DA,1.5,"PRCW","","A")
- +27 DO PUT^DDSVAL(444.019,.DA,14.1,$PIECE(PRCZ,U,2))
- +28 DO PUT^DDSVAL(444.019,.DA,14.2,$PIECE(PRCZ,U,7),"","I")
- +29 DO PUT^DDSVAL(444.019,.DA,14.3,$PIECE(PRCZ,U,6),"","I")
- +30 SET PRCY=$PIECE(PRCZ,U,5)
- if PRCY=""
- SET PRCY="@"
- +31 DO PUT^DDSVAL(444.019,.DA,7,PRCY)
- +32 SET PRCZ=$PIECE(PRCZ,U,4)
- if PRCZ=""
- SET PRCZ="@"
- +33 DO PUT^DDSVAL(444.019,.DA,14,PRCZ)
- End DoDot:1
- +34 QUIT
- PA(PRCX) ;Verify Purchasing Agent has Commercial Phone
- +1 if $GET(PRCX)=""
- QUIT
- +2 IF $PIECE($GET(^VA(200,+PRCX,.13)),U,5)=""
- Begin DoDot:1
- +3 DO HLP^DDSUTL("Contracting Officer lacks Commercial Phone #")
- +4 SET DDSERROR=1
- End DoDot:1
- +5 QUIT
- ESIG(PRCX) ;Verifies that editor has ESIG on file
- +1 IF $GET(PRCX)]""
- IF $PIECE($GET(^VA(200,PRCX,20)),U,4)]""
- QUIT 1
- +2 WRITE !,"*** You must have an Electronic Signature Code on file to use this option!",!
- +3 QUIT 0