Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHAMU

PRCHAMU.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;Patch PRC*5.1*175 modifies cancel error switch used in template
  1. ; PRCHAMENDPRO to be PRCPROSW.
  1. ;
  1. ;Patch PRC*5.1*180 Ask Delivery Date field edit each time
  1. ; amendment process is used
  1. ;
  1. ;PRC*5.1*190 Do not ask Delivery Date for cancelled order
  1. ; or Replaced Requisition number amend types.
  1. ;
  1. W !,"Call at the appropriate entry point",$C(7)
  1. Q
  1. ;
  1. GETPO ;get a valid PO
  1. ;the variable RETURN is either the PO/REQ# or null if no PO is selected
  1. N DIC,D,Y,X,TRANS,PRCHSTAT
  1. S DIC="^PRC(442,",DIC(0)="QEAMZ",D="C"
  1. S DIC("A")=$S($D(PRCHREQ):"REQUISITION NO.: ",1:"PURCHASE ORDER: ")
  1. 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)")
  1. 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""))"
  1. I $G(PRCHAUTH)=2 S DIC("S")="I +$P(^(0),U)=PRC(""SITE""),$P($G(^(23)),U,11)=""D"""
  1. D ^DIC K DIC I Y<0 S OUT=1 Q
  1. ;A time-out/up-arrow check before locking the record.
  1. I $D(DTOUT)!$D(DUOUT) Q
  1. ; Locking the 442 entry i.e. selected by the user to amend.
  1. ; This lock is released ONLY at one exit point in EXIT^PRCHMA routine.
  1. ;
  1. S PRCENTRY=+Y,OUT=0
  1. L +^PRC(442,PRCENTRY):1 E W !!,?5," Someone else is already editing this amendment record." S PRCFL=1 Q
  1. S X=$S($D(^PRC(442,+Y,7)):$P($G(^PRCD(442.3,+^(7),0)),U,2),1:"")
  1. I X="" W !,$C(7),"Invalid Supply Status" Q
  1. I X<20 W !,$C(7)," This order is not properly signed yet!!" Q
  1. I X=45 W !,$C(7),"This is a cancelled " W:$D(PRCHREQ) "requisition." W:'$D(PRCHREQ) "purchase order." Q
  1. I $G(PRCHAUTH)=1 S PCARD=$P($G(^PRC(442,+Y,23)),U,8) D I $G(PRCHFG) K PCARD,PRCHFG Q
  1. . I '$D(^PRC(440.5,"C",DUZ,PCARD)) W !,?5,"You are not authorized to amend this purchase card order." S PRCHFG=1
  1. K PCARD,PRCHFG
  1. I $G(PRCHAUTH)=2 S PRCHAUCP=$P(^PRC(442,+Y,0),U,3) D I $G(PRCHAUFG) K PRCHAUCP,PRCHAUFG Q
  1. . I '$D(^PRC(420,PRC("SITE"),1,+PRCHAUCP,1,DUZ)) D S PRCHAUFG=1
  1. . . W !!,"You are not an authorized user for "_$P(PRCHAUCP," ",1,2)_" control point.",!
  1. K PRCHAUCP,PRCHAUFG
  1. I '$D(TRANSCMP) I X=40!(X=41) D Q:$G(TRANS)=1
  1. .Q:($P(^PRC(442,+Y,0),"^",2)=2)!($P(^PRC(442,+Y,0),"^",2)=4)
  1. .W $C(7),!!,?5,"Purchase orders (Excluding CERTIFIED INVOICE and GUARANTEED DELIVERY)",!,?5,"with a status of 'Transaction Complete' cannot be amended."
  1. .S TRANS=1
  1. I X=50!(X=51) D Q
  1. . W $C(7),!!,?5,"Reconciled Purchase Card orders cannot be amended."
  1. I X=28!(X=33) W $C(7),!,"Amendment not allowed until after order has been obligated!!" Q
  1. I $D(^PRC(443.6,+Y,0)) S PRCHAM=$O(^PRC(443.6,+Y,6,0)) I PRCHAM="" D Q
  1. .W !!?5,"This record is not set-up properly, it is being cleaned-up."
  1. .W !?5,"Please RE-START the amendment process.",!
  1. .D DEL
  1. I $D(^PRC(443.6,+Y,0)) S PRCHAM=$O(^PRC(443.6,+Y,6,0)) Q:PRCHAM'>0 D Q:$D(FIS)
  1. .I $P($G(^PRC(443.6,+Y,6,PRCHAM,1)),U,2)]"" D
  1. ..W !!,?5,"Pending Amendment: ",PRCHAM," Status: Pending Fiscal Action" S FIS=1
  1. D FMS
  1. I $G(STATUS)]"" I $E(STATUS,1)="R"!($E(STATUS,1)="E") D K STATUS Q
  1. .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."
  1. 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
  1. 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)
  1. .S %=1,%B="",%A=" Would you like to Edit it" D ^PRCFYN W !
  1. .I %=2 S %B="",%A=" Would you like to delete it" D ^PRCFYN W ! D
  1. ..D:%=1 DEL
  1. S PRCHPO=+Y
  1. Q
  1. AMENDNO ;gets next valid amendment number to create
  1. ;
  1. N I,%,%A,%B,PRCHEX,PRCHEX1
  1. S PRCHAM=1
  1. I $D(^PRC(442,PRCHPO,6)) D
  1. .S I=0 F S I=$O(^PRC(442,PRCHPO,6,I)) Q:'I S PRCHAM=I+1
  1. W !!?5,"Amendment Number: ",PRCHAM
  1. I $D(^PRC(443.6,PRCHPO,0)) W ! Q
  1. W !!,"...copying Purchase Order into work file...",! D WAIT^DICD W !
  1. F I=0,1,7,12,23 S ^PRC(443.6,PRCHPO,I)=$G(^PRC(442,PRCHPO,I))
  1. S $P(^PRC(443.6,0),"^",3)=PRCHPO,$P(^(0),"^",4)=$P(^(0),"^",4)+1
  1. S PRCHEX=$P(^PRC(443.6,PRCHPO,0),"^"),PRCHEX1=$P(PRCHEX,"-",2)
  1. S (^PRC(443.6,"B",PRCHEX,PRCHPO),^PRC(443.6,"E",PRCHEX1,PRCHPO))=""
  1. Q
  1. ;
  1. INFO ; Ask for common information for amendments
  1. N DIE,DA,DR,FLGUP
  1. S ER=0,FLGUP=0,DIE="^PRC(443.6,",DA=PRCHPO,DR="[PRCHAMEND]"
  1. S:$D(PRCHAV) DR="[PRCHAMENDAV]"
  1. S:$G(PRCPROST)=90 DR="[PRCHAMENDPRO]"
  1. S:$G(PRCPROST)=6 DR="[PRCHAMENDPRO EDIT]"
  1. D ^DIE
  1. I $G(PRCPROSW)!'FLGUP S ER=1 Q ;PRC*5.1*175
  1. S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE
  1. I '$D(^PRC(443.6,PRCHPO,6,PRCHAM,1)) D S ER=1 Q
  1. .W !,?5,"Can't continue without a Purchasing Agent !"
  1. ;S PRCHLC=$P(PRCH(0),U,14)
  1. Q
  1. ASK ;Ask type amendment
  1. N PRCHREPO S PRCHREPO=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0)) I PRCHREPO>0 S REPONUM=1 Q
  1. S ER=0 W !
  1. I '$G(PRCHAUTH) D
  1. . S DIC=$S($D(PRCHREQ):"^PRCD(441.6,",1:"^PRCD(442.2,")
  1. . S DIC("S")="I Y>19,($P(^(0),U,3)]"""")"
  1. . S DIC(0)="MQEAZ" D ^DIC K DIC
  1. I $G(PRCHAUTH) D
  1. . D:'$D(PRCHREQ) DIRPO^PRCHPCAR D:$D(PRCHREQ) DIRREQ^PRCHPCAR
  1. I Y<0 S ER=1 K PRCHVFLG Q
  1. I $D(PRCHREQ) D G:ER ASK
  1. .I '$D(^PRCD(441.6,+Y,1)) D S ER=1
  1. ..W !!?5,"Amendment Lines in 'Type of Requisition Amendment' file are not defined "
  1. I '$D(PRCHREQ) D G:ER ASK
  1. .I '$D(^PRCD(442.2,+Y,1)) D S ER=1
  1. ..W !!?5,"Amendment Lines in 'Type of Amendment' file are not defined "
  1. I $P($G(Y(0)),U,3)="" D
  1. . S Y(0)=$S($D(PRCHREQ):^PRCD(441.6,Y,0),1:^PRCD(442.2,Y,0))
  1. S PRCHAMDA=+Y,ROU=$P(Y(0),U,3),ROU=$TR(ROU,"~","^")
  1. S PRCHL1=$P(^PRCD(442.2,+Y,1),U),PRCHL2=$P(^(1),U,2)
  1. Q
  1. UPDATE ;Update Delivery date, Original Delivery Date, Amendment status and
  1. ;Justification.
  1. ;;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
  1. ;;PRC*5.1*190 DO NOT ask Delivery date for Cancelled Order or Replaced Requistion Number amendment types
  1. I $G(CAN)=0,$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0))'>0 D ;PRC*5.1*190
  1. . S PRCHDT=$P(^PRC(443.6,PRCHPO,0),U,10)
  1. . I $P($G(^PRC(442,PRCHPO,23)),"^",11)'="S" S DIE="^PRC(443.6,",DA=PRCHPO,DR=7 D ^DIE K DIE
  1. . I PRCHDT,$P(^PRC(443.6,PRCHPO,0),U,20)="",$P(^(0),U,10)'=PRCHDT S $P(^(0),U,20)=PRCHDT
  1. . K PRCHDT
  1. S POSTAT=+$G(^PRC(443.6,PRCHPO,7))
  1. 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)
  1. I $G(PRCHAUTH)=1,(AMSTAT=40!(AMSTAT=71)) S AMSTAT=83
  1. S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U)
  1. S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT;16"
  1. N AAREPO S AAREPO=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",32,0))
  1. I $G(CAN)=1!(AAREPO>0) S DR=16
  1. I $G(PRCPROST)=90 S DR="16////Prosthetic order cancelled"
  1. I $G(PRCPROST)=6 S DR="16////Prosthetic Cost Changes"
  1. D ^DIE K DIE,AMSTAT,POSTAT
  1. QUIT
  1. FMS ;Checking FMS documents status
  1. ;
  1. N N,CODE
  1. 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")
  1. .I $E(^PRC(442,+Y,10,N,0),1,2)="MO"!($E(^(0),1,2)="SO") D
  1. ..S CODE=$P($G(^PRC(442,+Y,10,N,0)),U,4)
  1. ..S STATUS=$$STATUS^GECSSGET(CODE)
  1. Q
  1. DEL ;Delete this amendment
  1. N PO,EXPO,EXPO1,N,ZERO,REC,PAT,ITEM
  1. S PO=+Y
  1. S EXPO=$P(^PRC(443.6,PO,0),U),EXPO1=$P(EXPO,"-",2)
  1. S N=0 F S N=$O(^PRC(441.7,"B",EXPO,N)) Q:N'>0 D
  1. .S REC=^PRC(441.7,N,0)
  1. .S PAT=$P(REC,U)
  1. .S ITEM=$P(REC,U,2)
  1. .I ITEM>0 K ^PRC(441.7,"AG",PAT,ITEM,N)
  1. .K ^PRC(441.7,"B",PAT,N)
  1. .K ^PRC(441.7,N,0)
  1. .S ZERO=^PRC(441.7,0)
  1. .S $P(ZERO,U,4)=$P(ZERO,U,4)-1
  1. .S:$P(ZERO,U,4)<1 $P(ZERO,U,4)=""
  1. .S ^PRC(441.7,0)=ZERO
  1. K ^PRC(443.6,"B",EXPO),^PRC(443.6,"C",PO),^PRC(443.6,"D",PO)
  1. K ^PRC(443.6,"E",EXPO1),^PRC(443.6,PO)
  1. S ZERO=^PRC(443.6,0)
  1. S $P(ZERO,U,4)=$P(ZERO,U,4)-1
  1. S:$P(ZERO,U,4)<1 $P(ZERO,U,4)=""
  1. S ^PRC(443.6,0)=ZERO
  1. S DEL=1
  1. QUIT
  1. ;
  1. MSG ;This subroutine is called by PRCHMA
  1. ;Display message for 'Vendor Change'
  1. N AA
  1. S AA="NOTE: The vendor has been changed."
  1. S AA=AA_" Please review LINE ITEM & FPDS information"
  1. S AA=AA_" for any necessary changes."
  1. D EN^DDIOL(AA) W !
  1. QUIT
  1. ;
  1. MSG1 ;This subroutine is called by PRCHMA
  1. ;Source code was changed to 2
  1. N AA
  1. S AA="NOTE: THE CONTRACT WILL BE REMOVED FROM ALL ITEMS"
  1. D EN^DDIOL(AA) W !
  1. QUIT
  1. ;
  1. SOURCE ;This subroutine is called by PRCHMA
  1. ;Source code was changed to 2
  1. ;Remove contract number from $P2 and AC x-reference.
  1. KILL SCE
  1. N CONTRACT,ITEM S ITEM=0
  1. F S ITEM=$O(^PRC(443.6,PRCHPO,2,ITEM)) Q:'ITEM D
  1. . S CONTRACT=$G(^PRC(443.6,PRCHPO,2,ITEM,2))
  1. . S CONTRACT=$P(CONTRACT,U,2)
  1. . Q:CONTRACT=""
  1. . S $P(^PRC(443.6,PRCHPO,2,ITEM,2),U,2)=""
  1. . KILL ^PRC(443.6,PRCHPO,2,"AC",CONTRACT,ITEM)
  1. ;
  1. QUIT