PRCHMA1 ;WISC/AKS/DWA-Amendments to purchase orders and requisitions ;6/8/96 13:42
;;5.1;IFCAP;**22,40,79,157**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
EN4 ;Line Item edit
;
;MOP=Method of Processing
;SSO=Supply Status Order
;
N DIC,DIE,DA,DR,PRCHSTN,PRCHI,PRCHI1,PRCHO,PRCHEDI,PRCHSTN,PRCHPONO,DIE,DR,PRCHN,PRCHAREC,MOP,SSO
S MOP=$P($G(^PRC(442,PRCHPO,0)),U,2),SSO=$P($G(^PRC(442,PRCHPO,7)),U,2)
I ".27.28.33.25.26.30.31.40.41.32.34.37.38.46.47.48.49.96.97."[("."_SSO_".") D
. I MOP=25,$P(^PRC(442,PRCHPO,23),U,15)'="Y" Q
. I ".2.4.7.26."[("."_MOP_".") Q
. W !!
. W !,?15,"****************** TAKE NOTE!! ********************"
. W !,?15,"* *"
. W !,?15,"* This order has a Receiving Report previously *"
. W !,?15,"* processed. If this amendment will alter the *"
. W !,?15,"* Total Cost of any line item on the order *"
. W !,?15,"* remember to back out the previous Receiving *"
. W !,?15,"* Report with an Adjustment Voucher, process *"
. W !,?15,"* the amendment, and rerun the Receiving *"
. W !,?15,"* Report. *"
. W !,?15,"* *"
. W !,?15,"***************************************************"
. W !!
. Q
K MOP,SSO
D MV^PRCHMA0 I $G(PRCPROST)=6 S PRCHI=$O(^PRC(443.6,PRCRI(443.6),2,0)),PRCHI1=PRCHI,X=1,$P(PRCHI,U,2)=$P(^(PRCHI,0),U) G EN4A
S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",2,",DIC(0)="AEQZ" D ^DIC Q:Y<0 S PRCHI=Y,PRCHI1=$P(Y,U,2)
EN4A ;Called from routine PRCHMA2B for chenge vendor amendments to enable
;line item edits for vendor specific information.
S PRCHO=+$G(^PRC(443.6,PRCHPO,2,+PRCHI,2))
S PRCHEDI=$G(^PRC(440,$P(^PRC(443.6,PRCHPO,1),U),3)) S:PRCHEDI]"" PRCHEDI=$P(PRCHEDI,U,2)
S PRCHSTN=$P($P(^PRC(443.6,PRCHPO,0),U),"-")
S PRCHPONO=$P(^PRC(443.6,PRCHPO,0),U)
I $G(PRCPROST)=6 D G EN4B
. N X
. S PRCRI(443.61)=$O(^PRC(443.6,PRCRI(443.6),2,0))
. I PRCRI(443.61) D EDIT^PRC0B(.X,"443.6;^PRC(443.6,;"_PRCRI(443.6)_"~443.61;^PRC(443.6,"_PRCRI(443.6)_",2,;"_PRCRI(443.61),"5///"_PRCPAMT)
. QUIT
S DIE="^PRC(443.6,",DA=PRCHPO
S DR=$S($D(PRCHREQ):"[PRCHRQITM]",1:"[PRCHLINE]"),DIE("NO^")="BACK"
;I $G(PRCHVFLG)>0 S DR=$S($D(PRCHREQ):"[PRCH CHNGVEND RQ",1:"[PRCH CHNGVEND PO]"),DIE("NO^")="BACK"
I $G(PRCHAUTH)=1 S DR="[PRCH PURCHASE CARD AMEND]"
I $G(PRCHAUTH)=2 S DR="[PRCH DELIVERY ORDER AMEND]"
D ^DIE K DIE
EN4B ;Called from routine PRCHMA2C for change vendor amendments to enable
;line item edits if required information is missing.
S PRCHN=+$G(^PRC(443.6,PRCHPO,2,+PRCHI,2))
I PRCHO'=PRCHN S PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
I $D(^PRC(443.6,PRCHPO,2,+PRCHI,2)),$P(^(2),U,6)>0 S PRCHAREC=1
I $P($G(^PRC(443.6,PRCHPO,2,+PRCHI,0)),U,2)'>$P($G(^(2)),U,8) D
.S PRCHX($P(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
E S PRCHX($P(PRCHI,U,2),$P(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
S DELIVER=1 W !
D ERCHK,EN0^PRCHAMXH
K PRCHI
QUIT
EN5 ;Source Code edit
N DIE,DR
S DIC="^PRCD(420.8,",DIC(0)="AEQ"
S:$D(PRCHREQ) DIC("S")="I ""134590""[$E(^(0))"
S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)>0 DIC("B")=$P(^PRCD(420.8,$P(^(1),U,7),0),"^")
D ^DIC K DIC Q:Y<0
S DIE="^PRC(443.6,",DA=PRCHPO,DR="8////"_+Y D ^DIE K DIE W !
QUIT
EN6 ;Edit Mail Invoice to
N DA,DIE,DR
S DA=PRCHPO,DIE="^PRC(443.6,",DR=.04 D ^DIE W !
QUIT
EN7 ;Edit Method of Payment
N DA,DIE,DR
S DA=PRCHPO,DIE="^PRC(443.6,",DR=.02 D ^DIE W !
QUIT
EN8 ;Administrative Certification add
N DIE,DA,DR,DLAYGO
D MVADM S DA(1)=PRCHPO
S DIC="^PRC(443.6,"_DA(1)_",15,",DIC(0)="AEQL",DLAYGO=443.6 D ^DIC K DIC
W !
QUIT
EN9 ;Administrative Certification delete
N DIE,DA,DR
D MVADM S DA(1)=PRCHPO
S DIC="^PRC(443.6,"_DA(1)_",15,",DIC(0)="AEQ" D ^DIC K DIC
S DIE="^PRC(443.6,"_DA(1)_",15,",DA=+Y,DR=".01////@" D ^DIE K DIE
QUIT
EN13 ;Replace P.O. Number
N X,I,PRCH0,PRCHO,PRCHNRQ,PRCHN,ER,OK,P2237
S (I,ER)=0,X=""
;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
D CAN^PRCHMA3
I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) Q
;PRC*5.1*157 insures that if the user does not use Amendment to Purchase Card option
; an order using a credit card (MOP=25) will also be checked for any recon charges
; still attached to order attempting to be cancelled
I $G(PRCHAUTH)=1!($P(^PRC(442,PRCHPO,0),U,2)=25) D PAID^PRCHINQ I $G(PAID)=1 D K PAID Q
. W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7)
I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)>2 D ERR Q
I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)=2 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)'=34 D ERR Q
S P2237=$P(^PRC(443.6,PRCHPO,0),U,12),OK=1 D:P2237>0 Q:OK=0
.I '$$VERIFY^PRCSC2(P2237) W !!,?5,"This requisition has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! S OK=0
I $D(PRCHREQ) S PRCHNRQ=PRCHREQ
S PRCH0=$G(^PRC(443.6,PRCHPO,0))
S PRCHO=$P(PRCH0,U),PRCH=PRCHPO D
.I $D(PRCHNRQ) S PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1 D EN^PRCHPAT Q
.I $D(PRCHIMP) S PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("T")=7,PRCHP("S")=3 D EN^PRCHPAT Q
.D ENPO^PRCHUTL Q
I '$D(PRCHPO) S PRCHPO=PRCH Q
S PRCHN=$P(^PRC(442,PRCHPO,0),U),NDOC=$P(^(18),U,3)
N %X,%Y,DIE,DR,DA
S %X="^PRC(442,PRCH,",%Y="^PRC(443.6,PRCHPO," D %XY^%RCR
F I=6,10,11 K ^PRC(443.6,PRCHPO,I)
S DIE="^PRC(443.6,",DA=PRCHPO
S DR=".01///^S X=PRCHN;27///^S X=PRCHO;102///^S X=NDOC"
D ^DIE K DIE,DA,DR,NDOC
S DIE="^PRC(443.6,",DA=PRCH,DR="28///^S X=PRCHN" D ^DIE K DIE,DA,DR
S X=0,PRCHPO=PRCH D EN4^PRCHAMXB
S DA(1)=PRCH,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
D ^DIE
S DELIVER=1,REPO=1,PRCHPO=PRCH,CAN=1 W !
QUIT
MVADM ;Move Administrative Certifications from file 442
Q:$D(^PRC(443.6,PRCHPO,15,0))&($P($G(^(0)),U,4)>0) D WAIT^DICD
N %X,%Y
S %X="^PRC(442,PRCHPO,15,",%Y="^PRC(443.6,PRCHPO,15," D %XY^%RCR
S $P(^PRC(443.6,PRCHPO,15,0),U,2)=$P(^DD(443.6,24,0),U,2)
QUIT
ERCHK N NODE0
S ERROR=0,NODE0=^PRC(443.6,PRCHPO,2,+PRCHI,0)
I '$O(^PRC(443.6,PRCHPO,2,+PRCHI,1,0)) W !,"Line item ",+NODE0," is missing its description!",! S ERROR=1
I $P(NODE0,U,4)="" W !,"Line item ",+NODE0," is missing BOC !",! S ERROR=1
I $G(PRCHAUTH)'=1,$D(PRCHREQ),$P(NODE0,U,13)="" W !,"Line item ",+NODE0," is missing NSN !",! S ERROR=1
I '$D(^PRC(443.6,PRCHPO,2,+PRCHI,2)) W !,"Line item ",+NODE0," is incomplete !",! S ERROR=1
I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,+PRCHI,2)),U,2)="" W !,"Line item ",+NODE0," does contain contract number.",! S ERROR=1
;W:ERROR !,"Editing of the line item is required !",!
Q
KILL ;Kill
K PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,A,B,ER,FL,FIS,DELIVER,PRCHAMDA
K PRCHAV,PRCHL1,PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN
K PRCHO,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,PRCHPO,REPO,PRCHNORE,%,%A,%B,D0,D1
K PRCHU,PRCHER,PRCHLN,PRCHRET,PRCHQ,AA,PRCHVN
Q
ERR W !!?5,"To "_$S($D(PRCHREQ):$P(^PRCD(441.6,32,0),U,2),1:$P(^PRCD(442.2,32,0),U,2))_" it must be the ONLY change you",!?5,"are making on the amendment."
Q
;
PCD ;PRC*5.1*79 - Check line items of Detailed PC orders with source code=6
;for missing contract number, called from PRCHMA.
I $P($G(^PRC(442,PRCHPO,23)),U,11)="P",$P($G(^PRC(442,PRCHPO,1)),U,7)=6,$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP^PRCHMA W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing a required contract number.",$C(7) S PRCHER="",LNCT=LCNT+2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMA1 7749 printed Dec 13, 2024@02:08:39 Page 2
PRCHMA1 ;WISC/AKS/DWA-Amendments to purchase orders and requisitions ;6/8/96 13:42
+1 ;;5.1;IFCAP;**22,40,79,157**;Oct 20, 2000;Build 2
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
EN4 ;Line Item edit
+1 ;
+2 ;MOP=Method of Processing
+3 ;SSO=Supply Status Order
+4 ;
+5 NEW DIC,DIE,DA,DR,PRCHSTN,PRCHI,PRCHI1,PRCHO,PRCHEDI,PRCHSTN,PRCHPONO,DIE,DR,PRCHN,PRCHAREC,MOP,SSO
+6 SET MOP=$PIECE($GET(^PRC(442,PRCHPO,0)),U,2)
SET SSO=$PIECE($GET(^PRC(442,PRCHPO,7)),U,2)
+7 IF ".27.28.33.25.26.30.31.40.41.32.34.37.38.46.47.48.49.96.97."[("."_SSO_".")
Begin DoDot:1
+8 IF MOP=25
IF $PIECE(^PRC(442,PRCHPO,23),U,15)'="Y"
QUIT
+9 IF ".2.4.7.26."[("."_MOP_".")
QUIT
+10 WRITE !!
+11 WRITE !,?15,"****************** TAKE NOTE!! ********************"
+12 WRITE !,?15,"* *"
+13 WRITE !,?15,"* This order has a Receiving Report previously *"
+14 WRITE !,?15,"* processed. If this amendment will alter the *"
+15 WRITE !,?15,"* Total Cost of any line item on the order *"
+16 WRITE !,?15,"* remember to back out the previous Receiving *"
+17 WRITE !,?15,"* Report with an Adjustment Voucher, process *"
+18 WRITE !,?15,"* the amendment, and rerun the Receiving *"
+19 WRITE !,?15,"* Report. *"
+20 WRITE !,?15,"* *"
+21 WRITE !,?15,"***************************************************"
+22 WRITE !!
+23 QUIT
End DoDot:1
+24 KILL MOP,SSO
+25 DO MV^PRCHMA0
IF $GET(PRCPROST)=6
SET PRCHI=$ORDER(^PRC(443.6,PRCRI(443.6),2,0))
SET PRCHI1=PRCHI
SET X=1
SET $PIECE(PRCHI,U,2)=$PIECE(^(PRCHI,0),U)
GOTO EN4A
+26 SET DA(1)=PRCHPO
SET DIC="^PRC(443.6,"_DA(1)_",2,"
SET DIC(0)="AEQZ"
DO ^DIC
if Y<0
QUIT
SET PRCHI=Y
SET PRCHI1=$PIECE(Y,U,2)
EN4A ;Called from routine PRCHMA2B for chenge vendor amendments to enable
+1 ;line item edits for vendor specific information.
+2 SET PRCHO=+$GET(^PRC(443.6,PRCHPO,2,+PRCHI,2))
+3 SET PRCHEDI=$GET(^PRC(440,$PIECE(^PRC(443.6,PRCHPO,1),U),3))
if PRCHEDI]""
SET PRCHEDI=$PIECE(PRCHEDI,U,2)
+4 SET PRCHSTN=$PIECE($PIECE(^PRC(443.6,PRCHPO,0),U),"-")
+5 SET PRCHPONO=$PIECE(^PRC(443.6,PRCHPO,0),U)
+6 IF $GET(PRCPROST)=6
Begin DoDot:1
+7 NEW X
+8 SET PRCRI(443.61)=$ORDER(^PRC(443.6,PRCRI(443.6),2,0))
+9 IF PRCRI(443.61)
DO EDIT^PRC0B(.X,"443.6;^PRC(443.6,;"_PRCRI(443.6)_"~443.61;^PRC(443.6,"_PRCRI(443.6)_",2,;"_PRCRI(443.61),"5///"_PRCPAMT)
+10 QUIT
End DoDot:1
GOTO EN4B
+11 SET DIE="^PRC(443.6,"
SET DA=PRCHPO
+12 SET DR=$SELECT($DATA(PRCHREQ):"[PRCHRQITM]",1:"[PRCHLINE]")
SET DIE("NO^")="BACK"
+13 ;I $G(PRCHVFLG)>0 S DR=$S($D(PRCHREQ):"[PRCH CHNGVEND RQ",1:"[PRCH CHNGVEND PO]"),DIE("NO^")="BACK"
+14 IF $GET(PRCHAUTH)=1
SET DR="[PRCH PURCHASE CARD AMEND]"
+15 IF $GET(PRCHAUTH)=2
SET DR="[PRCH DELIVERY ORDER AMEND]"
+16 DO ^DIE
KILL DIE
EN4B ;Called from routine PRCHMA2C for change vendor amendments to enable
+1 ;line item edits if required information is missing.
+2 SET PRCHN=+$GET(^PRC(443.6,PRCHPO,2,+PRCHI,2))
+3 IF PRCHO'=PRCHN
SET PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
+4 IF $DATA(^PRC(443.6,PRCHPO,2,+PRCHI,2))
IF $PIECE(^(2),U,6)>0
SET PRCHAREC=1
+5 IF $PIECE($GET(^PRC(443.6,PRCHPO,2,+PRCHI,0)),U,2)'>$PIECE($GET(^(2)),U,8)
Begin DoDot:1
+6 SET PRCHX($PIECE(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
End DoDot:1
+7 IF '$TEST
SET PRCHX($PIECE(PRCHI,U,2),$PIECE(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
+8 SET DELIVER=1
WRITE !
+9 DO ERCHK
DO EN0^PRCHAMXH
+10 KILL PRCHI
+11 QUIT
EN5 ;Source Code edit
+1 NEW DIE,DR
+2 SET DIC="^PRCD(420.8,"
SET DIC(0)="AEQ"
+3 if $DATA(PRCHREQ)
SET DIC("S")="I ""134590""[$E(^(0))"
+4 if $PIECE($GET(^PRC(443.6,PRCHPO,1)),U,7)>0
SET DIC("B")=$PIECE(^PRCD(420.8,$PIECE(^(1),U,7),0),"^")
+5 DO ^DIC
KILL DIC
if Y<0
QUIT
+6 SET DIE="^PRC(443.6,"
SET DA=PRCHPO
SET DR="8////"_+Y
DO ^DIE
KILL DIE
WRITE !
+7 QUIT
EN6 ;Edit Mail Invoice to
+1 NEW DA,DIE,DR
+2 SET DA=PRCHPO
SET DIE="^PRC(443.6,"
SET DR=.04
DO ^DIE
WRITE !
+3 QUIT
EN7 ;Edit Method of Payment
+1 NEW DA,DIE,DR
+2 SET DA=PRCHPO
SET DIE="^PRC(443.6,"
SET DR=.02
DO ^DIE
WRITE !
+3 QUIT
EN8 ;Administrative Certification add
+1 NEW DIE,DA,DR,DLAYGO
+2 DO MVADM
SET DA(1)=PRCHPO
+3 SET DIC="^PRC(443.6,"_DA(1)_",15,"
SET DIC(0)="AEQL"
SET DLAYGO=443.6
DO ^DIC
KILL DIC
+4 WRITE !
+5 QUIT
EN9 ;Administrative Certification delete
+1 NEW DIE,DA,DR
+2 DO MVADM
SET DA(1)=PRCHPO
+3 SET DIC="^PRC(443.6,"_DA(1)_",15,"
SET DIC(0)="AEQ"
DO ^DIC
KILL DIC
+4 SET DIE="^PRC(443.6,"_DA(1)_",15,"
SET DA=+Y
SET DR=".01////@"
DO ^DIE
KILL DIE
+5 QUIT
EN13 ;Replace P.O. Number
+1 NEW X,I,PRCH0,PRCHO,PRCHNRQ,PRCHN,ER,OK,P2237
+2 SET (I,ER)=0
SET X=""
+3 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
+4 DO CAN^PRCHMA3
+5 IF $GET(NOCAN)=1
WRITE !?5,$SELECT($DATA(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$CHAR(7)
QUIT
+6 ;PRC*5.1*157 insures that if the user does not use Amendment to Purchase Card option
+7 ; an order using a credit card (MOP=25) will also be checked for any recon charges
+8 ; still attached to order attempting to be cancelled
+9 IF $GET(PRCHAUTH)=1!($PIECE(^PRC(442,PRCHPO,0),U,2)=25)
DO PAID^PRCHINQ
IF $GET(PAID)=1
Begin DoDot:1
+10 WRITE !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$CHAR(7)
End DoDot:1
KILL PAID
QUIT
+11 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)>2
DO ERR
QUIT
+12 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)=2
IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)'=34
DO ERR
QUIT
+13 SET P2237=$PIECE(^PRC(443.6,PRCHPO,0),U,12)
SET OK=1
if P2237>0
Begin DoDot:1
+14 IF '$$VERIFY^PRCSC2(P2237)
WRITE !!,?5,"This requisition has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",!
SET OK=0
End DoDot:1
if OK=0
QUIT
+15 IF $DATA(PRCHREQ)
SET PRCHNRQ=PRCHREQ
+16 SET PRCH0=$GET(^PRC(443.6,PRCHPO,0))
+17 SET PRCHO=$PIECE(PRCH0,U)
SET PRCH=PRCHPO
Begin DoDot:1
+18 IF $DATA(PRCHNRQ)
SET PRCHP("A")="REQUISITION NUMBER"
SET PRCHP("T")=8
SET PRCHP("S")=1
DO EN^PRCHPAT
QUIT
+19 IF $DATA(PRCHIMP)
SET PRCHP("A")="IMPREST FUND P.O.NO.: "
SET PRCHP("T")=7
SET PRCHP("S")=3
DO EN^PRCHPAT
QUIT
+20 DO ENPO^PRCHUTL
QUIT
End DoDot:1
+21 IF '$DATA(PRCHPO)
SET PRCHPO=PRCH
QUIT
+22 SET PRCHN=$PIECE(^PRC(442,PRCHPO,0),U)
SET NDOC=$PIECE(^(18),U,3)
+23 NEW %X,%Y,DIE,DR,DA
+24 SET %X="^PRC(442,PRCH,"
SET %Y="^PRC(443.6,PRCHPO,"
DO %XY^%RCR
+25 FOR I=6,10,11
KILL ^PRC(443.6,PRCHPO,I)
+26 SET DIE="^PRC(443.6,"
SET DA=PRCHPO
+27 SET DR=".01///^S X=PRCHN;27///^S X=PRCHO;102///^S X=NDOC"
+28 DO ^DIE
KILL DIE,DA,DR,NDOC
+29 SET DIE="^PRC(443.6,"
SET DA=PRCH
SET DR="28///^S X=PRCHN"
DO ^DIE
KILL DIE,DA,DR
+30 SET X=0
SET PRCHPO=PRCH
DO EN4^PRCHAMXB
+31 SET DA(1)=PRCH
SET DIE="^PRC(443.6,"_DA(1)_",6,"
SET DA=PRCHAM
SET DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
+32 DO ^DIE
+33 SET DELIVER=1
SET REPO=1
SET PRCHPO=PRCH
SET CAN=1
WRITE !
+34 QUIT
MVADM ;Move Administrative Certifications from file 442
+1 if $DATA(^PRC(443.6,PRCHPO,15,0))&($PIECE($GET(^(0)),U,4)>0)
QUIT
DO WAIT^DICD
+2 NEW %X,%Y
+3 SET %X="^PRC(442,PRCHPO,15,"
SET %Y="^PRC(443.6,PRCHPO,15,"
DO %XY^%RCR
+4 SET $PIECE(^PRC(443.6,PRCHPO,15,0),U,2)=$PIECE(^DD(443.6,24,0),U,2)
+5 QUIT
ERCHK NEW NODE0
+1 SET ERROR=0
SET NODE0=^PRC(443.6,PRCHPO,2,+PRCHI,0)
+2 IF '$ORDER(^PRC(443.6,PRCHPO,2,+PRCHI,1,0))
WRITE !,"Line item ",+NODE0," is missing its description!",!
SET ERROR=1
+3 IF $PIECE(NODE0,U,4)=""
WRITE !,"Line item ",+NODE0," is missing BOC !",!
SET ERROR=1
+4 IF $GET(PRCHAUTH)'=1
IF $DATA(PRCHREQ)
IF $PIECE(NODE0,U,13)=""
WRITE !,"Line item ",+NODE0," is missing NSN !",!
SET ERROR=1
+5 IF '$DATA(^PRC(443.6,PRCHPO,2,+PRCHI,2))
WRITE !,"Line item ",+NODE0," is incomplete !",!
SET ERROR=1
+6 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"
IF $PIECE($GET(^PRC(443.6,PRCHPO,2,+PRCHI,2)),U,2)=""
WRITE !,"Line item ",+NODE0," does contain contract number.",!
SET ERROR=1
+7 ;W:ERROR !,"Editing of the line item is required !",!
+8 QUIT
KILL ;Kill
+1 KILL PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,A,B,ER,FL,FIS,DELIVER,PRCHAMDA
+2 KILL PRCHAV,PRCHL1,PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN
+3 KILL PRCHO,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,PRCHPO,REPO,PRCHNORE,%,%A,%B,D0,D1
+4 KILL PRCHU,PRCHER,PRCHLN,PRCHRET,PRCHQ,AA,PRCHVN
+5 QUIT
ERR WRITE !!?5,"To "_$SELECT($DATA(PRCHREQ):$PIECE(^PRCD(441.6,32,0),U,2),1:$PIECE(^PRCD(442.2,32,0),U,2))_" it must be the ONLY change you",!?5,"are making on the amendment."
+1 QUIT
+2 ;
PCD ;PRC*5.1*79 - Check line items of Detailed PC orders with source code=6
+1 ;for missing contract number, called from PRCHMA.
+2 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="P"
IF $PIECE($GET(^PRC(442,PRCHPO,1)),U,7)=6
IF $PIECE($GET(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)=""
if LCNT>END
DO TOP^PRCHMA
WRITE !!,?5,"Line item ",+$PIECE(PRCHLN,U)," is missing a required contract number.",$CHAR(7)
SET PRCHER=""
SET LNCT=LCNT+2
+3 QUIT
