- PRCHAMU ;WISC/AKS-Modules helpful in amendments ;8/18/97 9:12
- ;;5.1;IFCAP;**21,117,175,180,190**;Oct 20, 2000;Build 3
- ;Per VA Directive 6402, this routine should not be modified.
- ;Patch PRC*5.1*175 modifies cancel error switch used in template
- ; PRCHAMENDPRO to be PRCPROSW.
- ;
- ;Patch PRC*5.1*180 Ask Delivery Date field edit each time
- ; amendment process is used
- ;
- ;PRC*5.1*190 Do not ask Delivery Date for cancelled order
- ; or Replaced Requisition number amend types.
- ;
- W !,"Call at the appropriate entry point",$C(7)
- Q
- ;
- GETPO ;get a valid PO
- ;the variable RETURN is either the PO/REQ# or null if no PO is selected
- N DIC,D,Y,X,TRANS,PRCHSTAT
- S DIC="^PRC(442,",DIC(0)="QEAMZ",D="C"
- S DIC("A")=$S($D(PRCHREQ):"REQUISITION NO.: ",1:"PURCHASE ORDER: ")
- S DIC("S")="I +$P(^(0),U)=PRC(""SITE"")"_$S($D(PRCHREQ):",$P(^(0),U,2)=8!($P(^(0),U,2)=25)",1:",$P(^(0),U,2)<8!($P(^(0),U,2)=25)!($P(^(0),U,2)=26)")
- I $G(PRCHAUTH)=1 S DIC("S")="I +$P(^(0),U)=PRC(""SITE""),($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))"
- I $G(PRCHAUTH)=2 S DIC("S")="I +$P(^(0),U)=PRC(""SITE""),$P($G(^(23)),U,11)=""D"""
- D ^DIC K DIC I Y<0 S OUT=1 Q
- ;A time-out/up-arrow check before locking the record.
- I $D(DTOUT)!$D(DUOUT) Q
- ; Locking the 442 entry i.e. selected by the user to amend.
- ; This lock is released ONLY at one exit point in EXIT^PRCHMA routine.
- ;
- S PRCENTRY=+Y,OUT=0
- L +^PRC(442,PRCENTRY):1 E W !!,?5," Someone else is already editing this amendment record." S PRCFL=1 Q
- S X=$S($D(^PRC(442,+Y,7)):$P($G(^PRCD(442.3,+^(7),0)),U,2),1:"")
- I X="" W !,$C(7),"Invalid Supply Status" Q
- I X<20 W !,$C(7)," This order is not properly signed yet!!" Q
- I X=45 W !,$C(7),"This is a cancelled " W:$D(PRCHREQ) "requisition." W:'$D(PRCHREQ) "purchase order." Q
- I $G(PRCHAUTH)=1 S PCARD=$P($G(^PRC(442,+Y,23)),U,8) D I $G(PRCHFG) K PCARD,PRCHFG Q
- . I '$D(^PRC(440.5,"C",DUZ,PCARD)) W !,?5,"You are not authorized to amend this purchase card order." S PRCHFG=1
- K PCARD,PRCHFG
- I $G(PRCHAUTH)=2 S PRCHAUCP=$P(^PRC(442,+Y,0),U,3) D I $G(PRCHAUFG) K PRCHAUCP,PRCHAUFG Q
- . I '$D(^PRC(420,PRC("SITE"),1,+PRCHAUCP,1,DUZ)) D S PRCHAUFG=1
- . . W !!,"You are not an authorized user for "_$P(PRCHAUCP," ",1,2)_" control point.",!
- K PRCHAUCP,PRCHAUFG
- I '$D(TRANSCMP) I X=40!(X=41) D Q:$G(TRANS)=1
- .Q:($P(^PRC(442,+Y,0),"^",2)=2)!($P(^PRC(442,+Y,0),"^",2)=4)
- .W $C(7),!!,?5,"Purchase orders (Excluding CERTIFIED INVOICE and GUARANTEED DELIVERY)",!,?5,"with a status of 'Transaction Complete' cannot be amended."
- .S TRANS=1
- I X=50!(X=51) D Q
- . W $C(7),!!,?5,"Reconciled Purchase Card orders cannot be amended."
- I X=28!(X=33) W $C(7),!,"Amendment not allowed until after order has been obligated!!" Q
- I $D(^PRC(443.6,+Y,0)) S PRCHAM=$O(^PRC(443.6,+Y,6,0)) I PRCHAM="" D Q
- .W !!?5,"This record is not set-up properly, it is being cleaned-up."
- .W !?5,"Please RE-START the amendment process.",!
- .D DEL
- I $D(^PRC(443.6,+Y,0)) S PRCHAM=$O(^PRC(443.6,+Y,6,0)) Q:PRCHAM'>0 D Q:$D(FIS)
- .I $P($G(^PRC(443.6,+Y,6,PRCHAM,1)),U,2)]"" D
- ..W !!,?5,"Pending Amendment: ",PRCHAM," Status: Pending Fiscal Action" S FIS=1
- D FMS
- I $G(STATUS)]"" I $E(STATUS,1)="R"!($E(STATUS,1)="E") D K STATUS Q
- .W !!,?5,"One of the previous documents has been rejected by",!,?5,"FMS or has errored in transmission.",!,?5,"This purchase order cannot be amended at this time."
- I $D(^PRC(443.6,+Y,0)) I $D(^PRC(443.6,+Y,11)) W !!,"There is a pending Adjustment Voucher against this purchase order" Q
- I $D(^PRC(443.6,+Y,0)) W $C(7),!!,?5,"*** There is already an amendment pending for this purchase order. ***" S PRCHNEW=111 D Q:%'=1!$D(DEL)
- .S %=1,%B="",%A=" Would you like to Edit it" D ^PRCFYN W !
- .I %=2 S %B="",%A=" Would you like to delete it" D ^PRCFYN W ! D
- ..D:%=1 DEL
- S PRCHPO=+Y
- Q
- AMENDNO ;gets next valid amendment number to create
- ;
- N I,%,%A,%B,PRCHEX,PRCHEX1
- S PRCHAM=1
- I $D(^PRC(442,PRCHPO,6)) D
- .S I=0 F S I=$O(^PRC(442,PRCHPO,6,I)) Q:'I S PRCHAM=I+1
- W !!?5,"Amendment Number: ",PRCHAM
- I $D(^PRC(443.6,PRCHPO,0)) W ! Q
- W !!,"...copying Purchase Order into work file...",! D WAIT^DICD W !
- F I=0,1,7,12,23 S ^PRC(443.6,PRCHPO,I)=$G(^PRC(442,PRCHPO,I))
- S $P(^PRC(443.6,0),"^",3)=PRCHPO,$P(^(0),"^",4)=$P(^(0),"^",4)+1
- S PRCHEX=$P(^PRC(443.6,PRCHPO,0),"^"),PRCHEX1=$P(PRCHEX,"-",2)
- S (^PRC(443.6,"B",PRCHEX,PRCHPO),^PRC(443.6,"E",PRCHEX1,PRCHPO))=""
- Q
- ;
- INFO ; Ask for common information for amendments
- N DIE,DA,DR,FLGUP
- S ER=0,FLGUP=0,DIE="^PRC(443.6,",DA=PRCHPO,DR="[PRCHAMEND]"
- S:$D(PRCHAV) DR="[PRCHAMENDAV]"
- S:$G(PRCPROST)=90 DR="[PRCHAMENDPRO]"
- S:$G(PRCPROST)=6 DR="[PRCHAMENDPRO EDIT]"
- D ^DIE
- I $G(PRCPROSW)!'FLGUP S ER=1 Q ;PRC*5.1*175
- S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE
- I '$D(^PRC(443.6,PRCHPO,6,PRCHAM,1)) D S ER=1 Q
- .W !,?5,"Can't continue without a Purchasing Agent !"
- ;S PRCHLC=$P(PRCH(0),U,14)
- Q
- ASK ;Ask type amendment
- N PRCHREPO S PRCHREPO=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0)) I PRCHREPO>0 S REPONUM=1 Q
- S ER=0 W !
- I '$G(PRCHAUTH) D
- . S DIC=$S($D(PRCHREQ):"^PRCD(441.6,",1:"^PRCD(442.2,")
- . S DIC("S")="I Y>19,($P(^(0),U,3)]"""")"
- . S DIC(0)="MQEAZ" D ^DIC K DIC
- I $G(PRCHAUTH) D
- . D:'$D(PRCHREQ) DIRPO^PRCHPCAR D:$D(PRCHREQ) DIRREQ^PRCHPCAR
- I Y<0 S ER=1 K PRCHVFLG Q
- I $D(PRCHREQ) D G:ER ASK
- .I '$D(^PRCD(441.6,+Y,1)) D S ER=1
- ..W !!?5,"Amendment Lines in 'Type of Requisition Amendment' file are not defined "
- I '$D(PRCHREQ) D G:ER ASK
- .I '$D(^PRCD(442.2,+Y,1)) D S ER=1
- ..W !!?5,"Amendment Lines in 'Type of Amendment' file are not defined "
- I $P($G(Y(0)),U,3)="" D
- . S Y(0)=$S($D(PRCHREQ):^PRCD(441.6,Y,0),1:^PRCD(442.2,Y,0))
- S PRCHAMDA=+Y,ROU=$P(Y(0),U,3),ROU=$TR(ROU,"~","^")
- S PRCHL1=$P(^PRCD(442.2,+Y,1),U),PRCHL2=$P(^(1),U,2)
- Q
- UPDATE ;Update Delivery date, Original Delivery Date, Amendment status and
- ;Justification.
- ;;PRC*5.1*180 Ask Delivery date every time, regardless of amendment types. Replaces DELIVER=1 control set by certain amendment types which drove Delivery Date query
- ;;PRC*5.1*190 DO NOT ask Delivery date for Cancelled Order or Replaced Requistion Number amendment types
- I $G(CAN)=0,$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0))'>0 D ;PRC*5.1*190
- . S PRCHDT=$P(^PRC(443.6,PRCHPO,0),U,10)
- . I $P($G(^PRC(442,PRCHPO,23)),"^",11)'="S" S DIE="^PRC(443.6,",DA=PRCHPO,DR=7 D ^DIE K DIE
- . I PRCHDT,$P(^PRC(443.6,PRCHPO,0),U,20)="",$P(^(0),U,10)'=PRCHDT S $P(^(0),U,20)=PRCHDT
- . K PRCHDT
- S POSTAT=+$G(^PRC(443.6,PRCHPO,7))
- S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT)
- I $G(PRCHAUTH)=1,(AMSTAT=40!(AMSTAT=71)) S AMSTAT=83
- S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U)
- S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT;16"
- N AAREPO S AAREPO=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0))
- I $G(CAN)=1!(AAREPO>0) S DR=16
- I $G(PRCPROST)=90 S DR="16////Prosthetic order cancelled"
- I $G(PRCPROST)=6 S DR="16////Prosthetic Cost Changes"
- D ^DIE K DIE,AMSTAT,POSTAT
- QUIT
- FMS ;Checking FMS documents status
- ;
- N N,CODE
- S N=0,STATUS="" F S N=$O(^PRC(442,+Y,10,N)) Q:N'>0 D Q:$E(STATUS,1)="R"!($E(STATUS,1)="E")
- .I $E(^PRC(442,+Y,10,N,0),1,2)="MO"!($E(^(0),1,2)="SO") D
- ..S CODE=$P($G(^PRC(442,+Y,10,N,0)),U,4)
- ..S STATUS=$$STATUS^GECSSGET(CODE)
- Q
- DEL ;Delete this amendment
- N PO,EXPO,EXPO1,N,ZERO,REC,PAT,ITEM
- S PO=+Y
- S EXPO=$P(^PRC(443.6,PO,0),U),EXPO1=$P(EXPO,"-",2)
- S N=0 F S N=$O(^PRC(441.7,"B",EXPO,N)) Q:N'>0 D
- .S REC=^PRC(441.7,N,0)
- .S PAT=$P(REC,U)
- .S ITEM=$P(REC,U,2)
- .I ITEM>0 K ^PRC(441.7,"AG",PAT,ITEM,N)
- .K ^PRC(441.7,"B",PAT,N)
- .K ^PRC(441.7,N,0)
- .S ZERO=^PRC(441.7,0)
- .S $P(ZERO,U,4)=$P(ZERO,U,4)-1
- .S:$P(ZERO,U,4)<1 $P(ZERO,U,4)=""
- .S ^PRC(441.7,0)=ZERO
- K ^PRC(443.6,"B",EXPO),^PRC(443.6,"C",PO),^PRC(443.6,"D",PO)
- K ^PRC(443.6,"E",EXPO1),^PRC(443.6,PO)
- S ZERO=^PRC(443.6,0)
- S $P(ZERO,U,4)=$P(ZERO,U,4)-1
- S:$P(ZERO,U,4)<1 $P(ZERO,U,4)=""
- S ^PRC(443.6,0)=ZERO
- S DEL=1
- QUIT
- ;
- MSG ;This subroutine is called by PRCHMA
- ;Display message for 'Vendor Change'
- N AA
- S AA="NOTE: The vendor has been changed."
- S AA=AA_" Please review LINE ITEM & FPDS information"
- S AA=AA_" for any necessary changes."
- D EN^DDIOL(AA) W !
- QUIT
- ;
- MSG1 ;This subroutine is called by PRCHMA
- ;Source code was changed to 2
- N AA
- S AA="NOTE: THE CONTRACT WILL BE REMOVED FROM ALL ITEMS"
- D EN^DDIOL(AA) W !
- QUIT
- ;
- SOURCE ;This subroutine is called by PRCHMA
- ;Source code was changed to 2
- ;Remove contract number from $P2 and AC x-reference.
- KILL SCE
- N CONTRACT,ITEM S ITEM=0
- F S ITEM=$O(^PRC(443.6,PRCHPO,2,ITEM)) Q:'ITEM D
- . S CONTRACT=$G(^PRC(443.6,PRCHPO,2,ITEM,2))
- . S CONTRACT=$P(CONTRACT,U,2)
- . Q:CONTRACT=""
- . S $P(^PRC(443.6,PRCHPO,2,ITEM,2),U,2)=""
- . KILL ^PRC(443.6,PRCHPO,2,"AC",CONTRACT,ITEM)
- ;
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMU 9119 printed Jan 18, 2025@03:06:56 Page 2
- PRCHAMU ;WISC/AKS-Modules helpful in amendments ;8/18/97 9:12
- +1 ;;5.1;IFCAP;**21,117,175,180,190**;Oct 20, 2000;Build 3
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;Patch PRC*5.1*175 modifies cancel error switch used in template
- +4 ; PRCHAMENDPRO to be PRCPROSW.
- +5 ;
- +6 ;Patch PRC*5.1*180 Ask Delivery Date field edit each time
- +7 ; amendment process is used
- +8 ;
- +9 ;PRC*5.1*190 Do not ask Delivery Date for cancelled order
- +10 ; or Replaced Requisition number amend types.
- +11 ;
- +12 WRITE !,"Call at the appropriate entry point",$CHAR(7)
- +13 QUIT
- +14 ;
- GETPO ;get a valid PO
- +1 ;the variable RETURN is either the PO/REQ# or null if no PO is selected
- +2 NEW DIC,D,Y,X,TRANS,PRCHSTAT
- +3 SET DIC="^PRC(442,"
- SET DIC(0)="QEAMZ"
- SET D="C"
- +4 SET DIC("A")=$SELECT($DATA(PRCHREQ):"REQUISITION NO.: ",1:"PURCHASE ORDER: ")
- +5 SET DIC("S")="I +$P(^(0),U)=PRC(""SITE"")"_$SELECT($DATA(PRCHREQ):",$P(^(0),U,2)=8!($P(^(0),U,2)=25)",1:",$P(^(0),U,2)<8!($P(^(0),U,2)=25)!($P(^(0),U,2)=26)")
- +6 IF $GET(PRCHAUTH)=1
- SET DIC("S")="I +$P(^(0),U)=PRC(""SITE""),($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))"
- +7 IF $GET(PRCHAUTH)=2
- SET DIC("S")="I +$P(^(0),U)=PRC(""SITE""),$P($G(^(23)),U,11)=""D"""
- +8 DO ^DIC
- KILL DIC
- IF Y<0
- SET OUT=1
- QUIT
- +9 ;A time-out/up-arrow check before locking the record.
- +10 IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +11 ; Locking the 442 entry i.e. selected by the user to amend.
- +12 ; This lock is released ONLY at one exit point in EXIT^PRCHMA routine.
- +13 ;
- +14 SET PRCENTRY=+Y
- SET OUT=0
- +15 LOCK +^PRC(442,PRCENTRY):1
- IF '$TEST
- WRITE !!,?5," Someone else is already editing this amendment record."
- SET PRCFL=1
- QUIT
- +16 SET X=$SELECT($DATA(^PRC(442,+Y,7)):$PIECE($GET(^PRCD(442.3,+^(7),0)),U,2),1:"")
- +17 IF X=""
- WRITE !,$CHAR(7),"Invalid Supply Status"
- QUIT
- +18 IF X<20
- WRITE !,$CHAR(7)," This order is not properly signed yet!!"
- QUIT
- +19 IF X=45
- WRITE !,$CHAR(7),"This is a cancelled "
- if $DATA(PRCHREQ)
- WRITE "requisition."
- if '$DATA(PRCHREQ)
- WRITE "purchase order."
- QUIT
- +20 IF $GET(PRCHAUTH)=1
- SET PCARD=$PIECE($GET(^PRC(442,+Y,23)),U,8)
- Begin DoDot:1
- +21 IF '$DATA(^PRC(440.5,"C",DUZ,PCARD))
- WRITE !,?5,"You are not authorized to amend this purchase card order."
- SET PRCHFG=1
- End DoDot:1
- IF $GET(PRCHFG)
- KILL PCARD,PRCHFG
- QUIT
- +22 KILL PCARD,PRCHFG
- +23 IF $GET(PRCHAUTH)=2
- SET PRCHAUCP=$PIECE(^PRC(442,+Y,0),U,3)
- Begin DoDot:1
- +24 IF '$DATA(^PRC(420,PRC("SITE"),1,+PRCHAUCP,1,DUZ))
- Begin DoDot:2
- +25 WRITE !!,"You are not an authorized user for "_$PIECE(PRCHAUCP," ",1,2)_" control point.",!
- End DoDot:2
- SET PRCHAUFG=1
- End DoDot:1
- IF $GET(PRCHAUFG)
- KILL PRCHAUCP,PRCHAUFG
- QUIT
- +26 KILL PRCHAUCP,PRCHAUFG
- +27 IF '$DATA(TRANSCMP)
- IF X=40!(X=41)
- Begin DoDot:1
- +28 if ($PIECE(^PRC(442,+Y,0),"^",2)=2)!($PIECE(^PRC(442,+Y,0),"^",2)=4)
- QUIT
- +29 WRITE $CHAR(7),!!,?5,"Purchase orders (Excluding CERTIFIED INVOICE and GUARANTEED DELIVERY)",!,?5,"with a status of 'Transaction Complete' cannot be amended."
- +30 SET TRANS=1
- End DoDot:1
- if $GET(TRANS)=1
- QUIT
- +31 IF X=50!(X=51)
- Begin DoDot:1
- +32 WRITE $CHAR(7),!!,?5,"Reconciled Purchase Card orders cannot be amended."
- End DoDot:1
- QUIT
- +33 IF X=28!(X=33)
- WRITE $CHAR(7),!,"Amendment not allowed until after order has been obligated!!"
- QUIT
- +34 IF $DATA(^PRC(443.6,+Y,0))
- SET PRCHAM=$ORDER(^PRC(443.6,+Y,6,0))
- IF PRCHAM=""
- Begin DoDot:1
- +35 WRITE !!?5,"This record is not set-up properly, it is being cleaned-up."
- +36 WRITE !?5,"Please RE-START the amendment process.",!
- +37 DO DEL
- End DoDot:1
- QUIT
- +38 IF $DATA(^PRC(443.6,+Y,0))
- SET PRCHAM=$ORDER(^PRC(443.6,+Y,6,0))
- if PRCHAM'>0
- QUIT
- Begin DoDot:1
- +39 IF $PIECE($GET(^PRC(443.6,+Y,6,PRCHAM,1)),U,2)]""
- Begin DoDot:2
- +40 WRITE !!,?5,"Pending Amendment: ",PRCHAM," Status: Pending Fiscal Action"
- SET FIS=1
- End DoDot:2
- End DoDot:1
- if $DATA(FIS)
- QUIT
- +41 DO FMS
- +42 IF $GET(STATUS)]""
- IF $EXTRACT(STATUS,1)="R"!($EXTRACT(STATUS,1)="E")
- Begin DoDot:1
- +43 WRITE !!,?5,"One of the previous documents has been rejected by",!,?5,"FMS or has errored in transmission.",!,?5,"This purchase order cannot be amended at this time."
- End DoDot:1
- KILL STATUS
- QUIT
- +44 IF $DATA(^PRC(443.6,+Y,0))
- IF $DATA(^PRC(443.6,+Y,11))
- WRITE !!,"There is a pending Adjustment Voucher against this purchase order"
- QUIT
- +45 IF $DATA(^PRC(443.6,+Y,0))
- WRITE $CHAR(7),!!,?5,"*** There is already an amendment pending for this purchase order. ***"
- SET PRCHNEW=111
- Begin DoDot:1
- +46 SET %=1
- SET %B=""
- SET %A=" Would you like to Edit it"
- DO ^PRCFYN
- WRITE !
- +47 IF %=2
- SET %B=""
- SET %A=" Would you like to delete it"
- DO ^PRCFYN
- WRITE !
- Begin DoDot:2
- +48 if %=1
- DO DEL
- End DoDot:2
- End DoDot:1
- if %'=1!$DATA(DEL)
- QUIT
- +49 SET PRCHPO=+Y
- +50 QUIT
- AMENDNO ;gets next valid amendment number to create
- +1 ;
- +2 NEW I,%,%A,%B,PRCHEX,PRCHEX1
- +3 SET PRCHAM=1
- +4 IF $DATA(^PRC(442,PRCHPO,6))
- Begin DoDot:1
- +5 SET I=0
- FOR
- SET I=$ORDER(^PRC(442,PRCHPO,6,I))
- if 'I
- QUIT
- SET PRCHAM=I+1
- End DoDot:1
- +6 WRITE !!?5,"Amendment Number: ",PRCHAM
- +7 IF $DATA(^PRC(443.6,PRCHPO,0))
- WRITE !
- QUIT
- +8 WRITE !!,"...copying Purchase Order into work file...",!
- DO WAIT^DICD
- WRITE !
- +9 FOR I=0,1,7,12,23
- SET ^PRC(443.6,PRCHPO,I)=$GET(^PRC(442,PRCHPO,I))
- +10 SET $PIECE(^PRC(443.6,0),"^",3)=PRCHPO
- SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+1
- +11 SET PRCHEX=$PIECE(^PRC(443.6,PRCHPO,0),"^")
- SET PRCHEX1=$PIECE(PRCHEX,"-",2)
- +12 SET (^PRC(443.6,"B",PRCHEX,PRCHPO),^PRC(443.6,"E",PRCHEX1,PRCHPO))=""
- +13 QUIT
- +14 ;
- INFO ; Ask for common information for amendments
- +1 NEW DIE,DA,DR,FLGUP
- +2 SET ER=0
- SET FLGUP=0
- SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- SET DR="[PRCHAMEND]"
- +3 if $DATA(PRCHAV)
- SET DR="[PRCHAMENDAV]"
- +4 if $GET(PRCPROST)=90
- SET DR="[PRCHAMENDPRO]"
- +5 if $GET(PRCPROST)=6
- SET DR="[PRCHAMENDPRO EDIT]"
- +6 DO ^DIE
- +7 ;PRC*5.1*175
- IF $GET(PRCPROSW)!'FLGUP
- SET ER=1
- QUIT
- +8 SET DIE="^PRC(443.6,"_PRCHPO_",6,"
- SET DA=PRCHAM
- SET DR="15///TODAY+4"
- DO ^DIE
- +9 IF '$DATA(^PRC(443.6,PRCHPO,6,PRCHAM,1))
- Begin DoDot:1
- +10 WRITE !,?5,"Can't continue without a Purchasing Agent !"
- End DoDot:1
- SET ER=1
- QUIT
- +11 ;S PRCHLC=$P(PRCH(0),U,14)
- +12 QUIT
- ASK ;Ask type amendment
- +1 NEW PRCHREPO
- SET PRCHREPO=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0))
- IF PRCHREPO>0
- SET REPONUM=1
- QUIT
- +2 SET ER=0
- WRITE !
- +3 IF '$GET(PRCHAUTH)
- Begin DoDot:1
- +4 SET DIC=$SELECT($DATA(PRCHREQ):"^PRCD(441.6,",1:"^PRCD(442.2,")
- +5 SET DIC("S")="I Y>19,($P(^(0),U,3)]"""")"
- +6 SET DIC(0)="MQEAZ"
- DO ^DIC
- KILL DIC
- End DoDot:1
- +7 IF $GET(PRCHAUTH)
- Begin DoDot:1
- +8 if '$DATA(PRCHREQ)
- DO DIRPO^PRCHPCAR
- if $DATA(PRCHREQ)
- DO DIRREQ^PRCHPCAR
- End DoDot:1
- +9 IF Y<0
- SET ER=1
- KILL PRCHVFLG
- QUIT
- +10 IF $DATA(PRCHREQ)
- Begin DoDot:1
- +11 IF '$DATA(^PRCD(441.6,+Y,1))
- Begin DoDot:2
- +12 WRITE !!?5,"Amendment Lines in 'Type of Requisition Amendment' file are not defined "
- End DoDot:2
- SET ER=1
- End DoDot:1
- if ER
- GOTO ASK
- +13 IF '$DATA(PRCHREQ)
- Begin DoDot:1
- +14 IF '$DATA(^PRCD(442.2,+Y,1))
- Begin DoDot:2
- +15 WRITE !!?5,"Amendment Lines in 'Type of Amendment' file are not defined "
- End DoDot:2
- SET ER=1
- End DoDot:1
- if ER
- GOTO ASK
- +16 IF $PIECE($GET(Y(0)),U,3)=""
- Begin DoDot:1
- +17 SET Y(0)=$SELECT($DATA(PRCHREQ):^PRCD(441.6,Y,0),1:^PRCD(442.2,Y,0))
- End DoDot:1
- +18 SET PRCHAMDA=+Y
- SET ROU=$PIECE(Y(0),U,3)
- SET ROU=$TRANSLATE(ROU,"~","^")
- +19 SET PRCHL1=$PIECE(^PRCD(442.2,+Y,1),U)
- SET PRCHL2=$PIECE(^(1),U,2)
- +20 QUIT
- UPDATE ;Update Delivery date, Original Delivery Date, Amendment status and
- +1 ;Justification.
- +2 ;;PRC*5.1*180 Ask Delivery date every time, regardless of amendment types. Replaces DELIVER=1 control set by certain amendment types which drove Delivery Date query
- +3 ;;PRC*5.1*190 DO NOT ask Delivery date for Cancelled Order or Replaced Requistion Number amendment types
- +4 ;PRC*5.1*190
- IF $GET(CAN)=0
- IF $ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0))'>0
- Begin DoDot:1
- +5 SET PRCHDT=$PIECE(^PRC(443.6,PRCHPO,0),U,10)
- +6 IF $PIECE($GET(^PRC(442,PRCHPO,23)),"^",11)'="S"
- SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- SET DR=7
- DO ^DIE
- KILL DIE
- +7 IF PRCHDT
- IF $PIECE(^PRC(443.6,PRCHPO,0),U,20)=""
- IF $PIECE(^(0),U,10)'=PRCHDT
- SET $PIECE(^(0),U,20)=PRCHDT
- +8 KILL PRCHDT
- End DoDot:1
- +9 SET POSTAT=+$GET(^PRC(443.6,PRCHPO,7))
- +10 SET AMSTAT=$SELECT(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT)
- +11 IF $GET(PRCHAUTH)=1
- IF (AMSTAT=40!(AMSTAT=71))
- SET AMSTAT=83
- +12 SET AMSTAT=$PIECE(^PRCD(442.3,AMSTAT,0),U)
- +13 SET DIE="^PRC(443.6,PRCHPO,6,"
- SET DA(1)=PRCHPO
- SET DA=PRCHAM
- SET DR="9//^S X=AMSTAT;16"
- +14 NEW AAREPO
- SET AAREPO=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0))
- +15 IF $GET(CAN)=1!(AAREPO>0)
- SET DR=16
- +16 IF $GET(PRCPROST)=90
- SET DR="16////Prosthetic order cancelled"
- +17 IF $GET(PRCPROST)=6
- SET DR="16////Prosthetic Cost Changes"
- +18 DO ^DIE
- KILL DIE,AMSTAT,POSTAT
- +19 QUIT
- FMS ;Checking FMS documents status
- +1 ;
- +2 NEW N,CODE
- +3 SET N=0
- SET STATUS=""
- FOR
- SET N=$ORDER(^PRC(442,+Y,10,N))
- if N'>0
- QUIT
- Begin DoDot:1
- +4 IF $EXTRACT(^PRC(442,+Y,10,N,0),1,2)="MO"!($EXTRACT(^(0),1,2)="SO")
- Begin DoDot:2
- +5 SET CODE=$PIECE($GET(^PRC(442,+Y,10,N,0)),U,4)
- +6 SET STATUS=$$STATUS^GECSSGET(CODE)
- End DoDot:2
- End DoDot:1
- if $EXTRACT(STATUS,1)="R"!($EXTRACT(STATUS,1)="E")
- QUIT
- +7 QUIT
- DEL ;Delete this amendment
- +1 NEW PO,EXPO,EXPO1,N,ZERO,REC,PAT,ITEM
- +2 SET PO=+Y
- +3 SET EXPO=$PIECE(^PRC(443.6,PO,0),U)
- SET EXPO1=$PIECE(EXPO,"-",2)
- +4 SET N=0
- FOR
- SET N=$ORDER(^PRC(441.7,"B",EXPO,N))
- if N'>0
- QUIT
- Begin DoDot:1
- +5 SET REC=^PRC(441.7,N,0)
- +6 SET PAT=$PIECE(REC,U)
- +7 SET ITEM=$PIECE(REC,U,2)
- +8 IF ITEM>0
- KILL ^PRC(441.7,"AG",PAT,ITEM,N)
- +9 KILL ^PRC(441.7,"B",PAT,N)
- +10 KILL ^PRC(441.7,N,0)
- +11 SET ZERO=^PRC(441.7,0)
- +12 SET $PIECE(ZERO,U,4)=$PIECE(ZERO,U,4)-1
- +13 if $PIECE(ZERO,U,4)<1
- SET $PIECE(ZERO,U,4)=""
- +14 SET ^PRC(441.7,0)=ZERO
- End DoDot:1
- +15 KILL ^PRC(443.6,"B",EXPO),^PRC(443.6,"C",PO),^PRC(443.6,"D",PO)
- +16 KILL ^PRC(443.6,"E",EXPO1),^PRC(443.6,PO)
- +17 SET ZERO=^PRC(443.6,0)
- +18 SET $PIECE(ZERO,U,4)=$PIECE(ZERO,U,4)-1
- +19 if $PIECE(ZERO,U,4)<1
- SET $PIECE(ZERO,U,4)=""
- +20 SET ^PRC(443.6,0)=ZERO
- +21 SET DEL=1
- +22 QUIT
- +23 ;
- MSG ;This subroutine is called by PRCHMA
- +1 ;Display message for 'Vendor Change'
- +2 NEW AA
- +3 SET AA="NOTE: The vendor has been changed."
- +4 SET AA=AA_" Please review LINE ITEM & FPDS information"
- +5 SET AA=AA_" for any necessary changes."
- +6 DO EN^DDIOL(AA)
- WRITE !
- +7 QUIT
- +8 ;
- MSG1 ;This subroutine is called by PRCHMA
- +1 ;Source code was changed to 2
- +2 NEW AA
- +3 SET AA="NOTE: THE CONTRACT WILL BE REMOVED FROM ALL ITEMS"
- +4 DO EN^DDIOL(AA)
- WRITE !
- +5 QUIT
- +6 ;
- SOURCE ;This subroutine is called by PRCHMA
- +1 ;Source code was changed to 2
- +2 ;Remove contract number from $P2 and AC x-reference.
- +3 KILL SCE
- +4 NEW CONTRACT,ITEM
- SET ITEM=0
- +5 FOR
- SET ITEM=$ORDER(^PRC(443.6,PRCHPO,2,ITEM))
- if 'ITEM
- QUIT
- Begin DoDot:1
- +6 SET CONTRACT=$GET(^PRC(443.6,PRCHPO,2,ITEM,2))
- +7 SET CONTRACT=$PIECE(CONTRACT,U,2)
- +8 if CONTRACT=""
- QUIT
- +9 SET $PIECE(^PRC(443.6,PRCHPO,2,ITEM,2),U,2)=""
- +10 KILL ^PRC(443.6,PRCHPO,2,"AC",CONTRACT,ITEM)
- End DoDot:1
- +11 ;
- +12 QUIT