- PRCHMA0 ;WISC/AKS-Amendments to purchase orders and requisitions ;3/5/97 15:05
- ;;5.1;IFCAP;**97**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN1 ;Ship to edit
- N DR,DIE,DA,DIE,PRCH0
- S PRCH0=$G(^PRC(443.6,PRCHPO,0))
- S DR=$S($P(PRCH0,U,2)'=4:5.4,1:5.3)
- S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE
- S DELIVER=1 W !
- Q
- EN2 ;Line Item add
- N J,%,%A,%B,DIE,DA,DR,D0,D1,PRCHI,PRCHLC,PRCHSTN,NODE0,PRCHI1,PRCHPONO,BFLAG
- N X,Y
- D MV,MVDIS^PRCHMA3 S NODE0=^PRC(443.6,PRCHPO,0),PRCHLC=$P(NODE0,U,14)
- S J=PRCHLC+1,BFLAG=0
- S (I,N,M)=0 F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N S I=$P(^(N,0),U),M=N
- S PRCHI=(I+1)_"^"_J S:$P(^PRC(443.6,PRCHPO,2,0),U,3)<M $P(^(0),U,3)=M
- S %=2,%A=" ADD LINE ITEM "_+PRCHI,%B="" D ^PRCFYN
- I %'=1 W ?40,"<NOTHING ADDED>" Q
- K DD,DO S DA(1)=PRCHPO,X=+PRCHI,DIC="^PRC(443.6,"_DA(1)_",2,"
- S DIC(0)="L" D FILE^DICN K DIC Q:+Y'>0
- S PRCHI1=+PRCHI,$P(PRCHI,U)=+Y
- ;S $P(^PRC(443.6,PRCHPO,2,0),U,3)=$P(PRCHI,U),$P(^(0),U,4)=+PRCHI
- S $P(NODE0,U,14)=J
- I $D(^PRC(443.6,PRCHPO,3)) D
- .S N=0 F S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N S $P(^PRC(443.6,PRCHPO,3,N,0),U,6)=$P(^PRC(443.6,PRCHPO,3,N,0),U,6)+1
- S:$P(NODE0,U,18)]"" $P(NODE0,U,18)=J
- S ^PRC(443.6,PRCHPO,0)=NODE0
- S PRCHEDI=$G(^PRC(440,$P(^PRC(443.6,PRCHPO,1),U),3)) S:PRCHEDI]"" PRCHEDI=$P(PRCHEDI,U,2)
- S PRCHSTN=$P($P(NODE0,U),"-"),PRCHPONO=$P(NODE0,U)
- S DIE="^PRC(443.6,",DA=PRCHPO
- S DR=$S($D(PRCHREQ):"[PRCHRQITM]",1:"[PRCHLINE]"),DIE("NO^")="BACK"
- I $G(PRCHAUTH)=1 S DR="[PRCH PURCHASE CARD AMEND]"
- I $G(PRCHAUTH)=2 S DR="[PRCH DELIVERY ORDER AMEND]"
- S DIE("NO^")="OUTOK"
- D ^DIE K DIE
- I $D(^PRC(443.6,PRCHPO,2,+PRCHI,0)) D
- .S:'$D(^(2)) ^(2)=0
- .I $P(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,2)="" D
- ..W !,"Line item is being deleted because of incomplete information.",!
- ..S DA=+PRCHI,DA(1)=PRCHPO,DIK="^PRC(443.6,"_DA(1)_",2,",BFLAG=1
- ..D ^DIK
- I BFLAG=0 D
- .S DELIVER=1 W !
- .D ERCHK^PRCHMA1 K ERROR
- .S DA(1)=PRCHPO,DA=PRCHI1 D EN12^PRCHAMXG
- Q
- EN3 ;Line Item delete
- N PRCHI,I442,I2Z,DIC,PRCHAREC,DIE,DR,DELIVER,%,%A,%B,PONUM,DIK
- N PONOEXT,PODS,IENDS
- D MV,MVDIS^PRCHMA3 S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",2,",DIC(0)="AEQZ" D ^DIC
- I Y<0 W !?5,"<NOTHING DELETED>" Q
- S PRCHI=Y
- I $P($G(^PRC(443.6,PRCHPO,2,+PRCHI,2)),U,8)>0 D Q
- .W !?5,"CANNOT DELETE ITEM ",$P(PRCHI,U,2),", IT HAS ALREADY BEEN RECEIVED!",$C(7)
- S %="",%A=" SURE YOU WANT TO DELETE LINE ITEM "_$P(PRCHI,U,2),%B=""
- D ^PRCFYN I %'=1 W ?50,"<NOTHING DELETED>" Q
- S I442=$G(^PRC(442,PRCHPO,2,+PRCHI,0)) I I442="" D Q
- .S PONUM=$P(^PRC(443.6,PRCHPO,2,+PRCHI,0),U)
- .K ^PRC(443.6,PRCHPO,2,"B",PONUM),^PRC(443.6,PRCHPO,2,"C",PONUM)
- .I $P($G(^PRC(443.6,PRCHPO,2,+PRCHI,0)),U,5)]"" K ^PRC(443.6,PRCHPO,2,"AE",$P(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,5))
- .;
- .;If item was added during amendment process then kill Item/Del. Sch.
- .S PONOEXT=$P(^PRC(443.6,PRCHPO,0),U),PODS=0
- .F S PODS=$O(^PRC(441.7,"AG",PONOEXT,+PRCHI,PODS)) Q:'PODS I $D(PODS) S DA=PODS,DIK="^PRC(441.7," D ^DIK
- .;
- .K ^PRC(443.6,PRCHPO,2,+PRCHI)
- .S I2Z=^PRC(443.6,PRCHPO,2,0),$P(I2Z,U,4)=$P(I2Z,U,4)-1
- .S ^PRC(443.6,PRCHPO,2,0)=I2Z
- .S N=0 F I=1:1 S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N D
- ..S $P(^PRC(443.6,PRCHPO,2,N,0),U)=I
- .K ^PRC(443.6,PRCHPO,2,"B"),^PRC(443.6,PRCHPO,2,"C")
- .S DA(1)=PRCHPO,DIK(1)=".01^B^C"
- .S DIK="^PRC(443.6,"_DA(1)_",2," D ENALL^DIK K N,I,DIK
- .S J=$P(^PRC(443.6,PRCHPO,0),U,14)-1
- .S $P(^PRC(443.6,PRCHPO,0),U,14)=J,$P(^(0),U,18)=J
- .I $D(^PRC(443.6,PRCHPO,3)) D
- ..S N=0 F S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N S $P(^PRC(443.6,PRCHPO,3,N,0),U,6)=$P(^PRC(443.6,PRCHPO,3,N,0),U,6)-1
- I $D(^PRC(443.6,PRCHPO,2,+PRCHI,2)),$P(^(2),U,6)>0 S PRCHAREC=1
- ;
- ;If item already exists then either mark or delete the Del. Sch.
- I I442]"" D
- .S PONOEXT=$P(^PRC(443.6,PRCHPO,0),U)
- .S POSC=0
- .F S POSC=$O(^PRC(441.7,"AG",PONOEXT,+PRCHI,POSC)) Q:'POSC D
- . . S IENDS=$G(^PRC(441.7,POSC,0))
- . . Q:IENDS=""
- . . S PERM=+$P(IENDS,U,7)
- . . I PERM>0 S DR="5////D",DIE="^PRC(441.7,",DA=POSC D ^DIE Q
- . . I PERM'>0 K PRCHNORE S DIK="^PRC(441.7,",DA=POSC D ^DIK S PRCHNORE=1 Q
- ;
- S DR="5///0;2////0"
- S DA(1)=PRCHPO,DA=+PRCHI
- S DIE="^PRC(443.6,"_DA(1)_",2,"
- D ^DIE K DIE
- S DELIVER=1 W !
- Q
- MV ;Move line item information from 442
- Q:$D(^PRC(443.6,PRCHPO,2,0)) Q:$P($G(^(0)),U,4)>0 D WAIT^DICD
- N %X,%Y,N,M,PRCHPO1,OK,PRCHNORE
- S %X="^PRC(442,PRCHPO,2,",%Y="^PRC(443.6,PRCHPO,2," D %XY^%RCR
- S $P(^PRC(443.6,PRCHPO,2,0),U,2)=$P(^DD(443.6,40,0),U,2) K ^("C")
- S PRCHPO1=$P(^PRC(442,PRCHPO,0),"^")
- Q:'$D(^PRC(442.8,"B",PRCHPO1)) Q:$D(^PRC(441.7,"B",PRCHPO1))
- S N=0,M=+$P(^PRC(441.7,0),"^",3)
- F S N=$O(^PRC(442.8,"B",PRCHPO1,N)) Q:'N D
- MV1 .S M=M+1,OK=$G(^PRC(441.7,M,0)) I OK'="" G MV1
- .S ^PRC(441.7,M,0)=^PRC(442.8,N,0)
- .S $P(^PRC(441.7,M,0),U,7)=N
- .S $P(^PRC(441.7,0),"^",3)=M
- .S $P(^PRC(441.7,0),"^",4)=$P(^(0),"^",4)+1
- .S DIK="^PRC(441.7,",DA=M D IX^DIK K DIK,DA
- .Q
- Q
- ONLY ;Make sure only 'Cancel' amendment
- S PRCHON=0
- 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 D Q
- .I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)'=34 D ERR Q
- .S PRCHON=1
- S PRCHON=1
- QUIT
- ERR ;Error
- ;W !?5,"You can only "_$S($D(PRCHREQ):$P(^PRCD(442.2,15,0),U,2),1:$P(^PRCD(442.2,5,0),U,2))_" if this is the ONLY change you",!?5,"are making to the "_$S($D(PRCHREQ):"requisition.",1:"purchase order.")
- W !?5,"To "_$S($D(PRCHREQ):$P(^PRCD(442.2,15,0),U,2),1:$P(^PRCD(442.2,5,0),U,2))_" it must be the ONLY change you",!?5,"are making on the amendment."
- QUIT
- ;
- SUPBOC(QUIETLY) ;compute pre-implied BOC, moved from template PRCHRQITEM, PRCHLINE into this routine and also called in BOC input transform
- N PRCHIDA,SPFCP,PRCHBOCC,ACCT
- S:$G(QUIETLY)=-1 X=$P($G(^PRC(443.6,DA(1),2,DA,0)),U,4)
- Q:'$D(X)
- S PRCHIDA=+$P($G(^PRC(443.6,DA(1),2,DA,0)),U,5),SPFCP=+$P(^PRC(443.6,DA(1),0),U,19)
- I SPFCP=2 D
- . S PRCHN("SFC")=SPFCP,ACCT=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(PRCHIDA),1,4))
- . D ;:$D(ACCT)
- . . S PRCHBOCC=$P($G(^PRCD(420.2,$S(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699),0)),U)
- . . I PRCHBOCC S $P(^PRC(443.6,DA(1),2,DA,0),U,4)=PRCHBOCC D
- . . . I PRCHBOCC'=X,PRCHBOCC W:'$G(QUIETLY) !,?5,"BOC must be ",PRCHBOCC,!,?5,"For a supply fund order, a BOC ",X," is invalid.",! S X=PRCHBOCC
- Q X
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHMA0 6389 printed Feb 18, 2025@23:35 Page 2
- PRCHMA0 ;WISC/AKS-Amendments to purchase orders and requisitions ;3/5/97 15:05
- +1 ;;5.1;IFCAP;**97**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN1 ;Ship to edit
- +1 NEW DR,DIE,DA,DIE,PRCH0
- +2 SET PRCH0=$GET(^PRC(443.6,PRCHPO,0))
- +3 SET DR=$SELECT($PIECE(PRCH0,U,2)'=4:5.4,1:5.3)
- +4 SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- DO ^DIE
- +5 SET DELIVER=1
- WRITE !
- +6 QUIT
- EN2 ;Line Item add
- +1 NEW J,%,%A,%B,DIE,DA,DR,D0,D1,PRCHI,PRCHLC,PRCHSTN,NODE0,PRCHI1,PRCHPONO,BFLAG
- +2 NEW X,Y
- +3 DO MV
- DO MVDIS^PRCHMA3
- SET NODE0=^PRC(443.6,PRCHPO,0)
- SET PRCHLC=$PIECE(NODE0,U,14)
- +4 SET J=PRCHLC+1
- SET BFLAG=0
- +5 SET (I,N,M)=0
- FOR
- SET N=$ORDER(^PRC(443.6,PRCHPO,2,N))
- if 'N
- QUIT
- SET I=$PIECE(^(N,0),U)
- SET M=N
- +6 SET PRCHI=(I+1)_"^"_J
- if $PIECE(^PRC(443.6,PRCHPO,2,0),U,3)<M
- SET $PIECE(^(0),U,3)=M
- +7 SET %=2
- SET %A=" ADD LINE ITEM "_+PRCHI
- SET %B=""
- DO ^PRCFYN
- +8 IF %'=1
- WRITE ?40,"<NOTHING ADDED>"
- QUIT
- +9 KILL DD,DO
- SET DA(1)=PRCHPO
- SET X=+PRCHI
- SET DIC="^PRC(443.6,"_DA(1)_",2,"
- +10 SET DIC(0)="L"
- DO FILE^DICN
- KILL DIC
- if +Y'>0
- QUIT
- +11 SET PRCHI1=+PRCHI
- SET $PIECE(PRCHI,U)=+Y
- +12 ;S $P(^PRC(443.6,PRCHPO,2,0),U,3)=$P(PRCHI,U),$P(^(0),U,4)=+PRCHI
- +13 SET $PIECE(NODE0,U,14)=J
- +14 IF $DATA(^PRC(443.6,PRCHPO,3))
- Begin DoDot:1
- +15 SET N=0
- FOR
- SET N=$ORDER(^PRC(443.6,PRCHPO,3,N))
- if 'N
- QUIT
- SET $PIECE(^PRC(443.6,PRCHPO,3,N,0),U,6)=$PIECE(^PRC(443.6,PRCHPO,3,N,0),U,6)+1
- End DoDot:1
- +16 if $PIECE(NODE0,U,18)]""
- SET $PIECE(NODE0,U,18)=J
- +17 SET ^PRC(443.6,PRCHPO,0)=NODE0
- +18 SET PRCHEDI=$GET(^PRC(440,$PIECE(^PRC(443.6,PRCHPO,1),U),3))
- if PRCHEDI]""
- SET PRCHEDI=$PIECE(PRCHEDI,U,2)
- +19 SET PRCHSTN=$PIECE($PIECE(NODE0,U),"-")
- SET PRCHPONO=$PIECE(NODE0,U)
- +20 SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- +21 SET DR=$SELECT($DATA(PRCHREQ):"[PRCHRQITM]",1:"[PRCHLINE]")
- SET DIE("NO^")="BACK"
- +22 IF $GET(PRCHAUTH)=1
- SET DR="[PRCH PURCHASE CARD AMEND]"
- +23 IF $GET(PRCHAUTH)=2
- SET DR="[PRCH DELIVERY ORDER AMEND]"
- +24 SET DIE("NO^")="OUTOK"
- +25 DO ^DIE
- KILL DIE
- +26 IF $DATA(^PRC(443.6,PRCHPO,2,+PRCHI,0))
- Begin DoDot:1
- +27 if '$DATA(^(2))
- SET ^(2)=0
- +28 IF $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,2)=""
- Begin DoDot:2
- +29 WRITE !,"Line item is being deleted because of incomplete information.",!
- +30 SET DA=+PRCHI
- SET DA(1)=PRCHPO
- SET DIK="^PRC(443.6,"_DA(1)_",2,"
- SET BFLAG=1
- +31 DO ^DIK
- End DoDot:2
- End DoDot:1
- +32 IF BFLAG=0
- Begin DoDot:1
- +33 SET DELIVER=1
- WRITE !
- +34 DO ERCHK^PRCHMA1
- KILL ERROR
- +35 SET DA(1)=PRCHPO
- SET DA=PRCHI1
- DO EN12^PRCHAMXG
- End DoDot:1
- +36 QUIT
- EN3 ;Line Item delete
- +1 NEW PRCHI,I442,I2Z,DIC,PRCHAREC,DIE,DR,DELIVER,%,%A,%B,PONUM,DIK
- +2 NEW PONOEXT,PODS,IENDS
- +3 DO MV
- DO MVDIS^PRCHMA3
- SET DA(1)=PRCHPO
- SET DIC="^PRC(443.6,"_DA(1)_",2,"
- SET DIC(0)="AEQZ"
- DO ^DIC
- +4 IF Y<0
- WRITE !?5,"<NOTHING DELETED>"
- QUIT
- +5 SET PRCHI=Y
- +6 IF $PIECE($GET(^PRC(443.6,PRCHPO,2,+PRCHI,2)),U,8)>0
- Begin DoDot:1
- +7 WRITE !?5,"CANNOT DELETE ITEM ",$PIECE(PRCHI,U,2),", IT HAS ALREADY BEEN RECEIVED!",$CHAR(7)
- End DoDot:1
- QUIT
- +8 SET %=""
- SET %A=" SURE YOU WANT TO DELETE LINE ITEM "_$PIECE(PRCHI,U,2)
- SET %B=""
- +9 DO ^PRCFYN
- IF %'=1
- WRITE ?50,"<NOTHING DELETED>"
- QUIT
- +10 SET I442=$GET(^PRC(442,PRCHPO,2,+PRCHI,0))
- IF I442=""
- Begin DoDot:1
- +11 SET PONUM=$PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,0),U)
- +12 KILL ^PRC(443.6,PRCHPO,2,"B",PONUM),^PRC(443.6,PRCHPO,2,"C",PONUM)
- +13 IF $PIECE($GET(^PRC(443.6,PRCHPO,2,+PRCHI,0)),U,5)]""
- KILL ^PRC(443.6,PRCHPO,2,"AE",$PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,5))
- +14 ;
- +15 ;If item was added during amendment process then kill Item/Del. Sch.
- +16 SET PONOEXT=$PIECE(^PRC(443.6,PRCHPO,0),U)
- SET PODS=0
- +17 FOR
- SET PODS=$ORDER(^PRC(441.7,"AG",PONOEXT,+PRCHI,PODS))
- if 'PODS
- QUIT
- IF $DATA(PODS)
- SET DA=PODS
- SET DIK="^PRC(441.7,"
- DO ^DIK
- +18 ;
- +19 KILL ^PRC(443.6,PRCHPO,2,+PRCHI)
- +20 SET I2Z=^PRC(443.6,PRCHPO,2,0)
- SET $PIECE(I2Z,U,4)=$PIECE(I2Z,U,4)-1
- +21 SET ^PRC(443.6,PRCHPO,2,0)=I2Z
- +22 SET N=0
- FOR I=1:1
- SET N=$ORDER(^PRC(443.6,PRCHPO,2,N))
- if 'N
- QUIT
- Begin DoDot:2
- +23 SET $PIECE(^PRC(443.6,PRCHPO,2,N,0),U)=I
- End DoDot:2
- +24 KILL ^PRC(443.6,PRCHPO,2,"B"),^PRC(443.6,PRCHPO,2,"C")
- +25 SET DA(1)=PRCHPO
- SET DIK(1)=".01^B^C"
- +26 SET DIK="^PRC(443.6,"_DA(1)_",2,"
- DO ENALL^DIK
- KILL N,I,DIK
- +27 SET J=$PIECE(^PRC(443.6,PRCHPO,0),U,14)-1
- +28 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=J
- SET $PIECE(^(0),U,18)=J
- +29 IF $DATA(^PRC(443.6,PRCHPO,3))
- Begin DoDot:2
- +30 SET N=0
- FOR
- SET N=$ORDER(^PRC(443.6,PRCHPO,3,N))
- if 'N
- QUIT
- SET $PIECE(^PRC(443.6,PRCHPO,3,N,0),U,6)=$PIECE(^PRC(443.6,PRCHPO,3,N,0),U,6)-1
- End DoDot:2
- End DoDot:1
- QUIT
- +31 IF $DATA(^PRC(443.6,PRCHPO,2,+PRCHI,2))
- IF $PIECE(^(2),U,6)>0
- SET PRCHAREC=1
- +32 ;
- +33 ;If item already exists then either mark or delete the Del. Sch.
- +34 IF I442]""
- Begin DoDot:1
- +35 SET PONOEXT=$PIECE(^PRC(443.6,PRCHPO,0),U)
- +36 SET POSC=0
- +37 FOR
- SET POSC=$ORDER(^PRC(441.7,"AG",PONOEXT,+PRCHI,POSC))
- if 'POSC
- QUIT
- Begin DoDot:2
- +38 SET IENDS=$GET(^PRC(441.7,POSC,0))
- +39 if IENDS=""
- QUIT
- +40 SET PERM=+$PIECE(IENDS,U,7)
- +41 IF PERM>0
- SET DR="5////D"
- SET DIE="^PRC(441.7,"
- SET DA=POSC
- DO ^DIE
- QUIT
- +42 IF PERM'>0
- KILL PRCHNORE
- SET DIK="^PRC(441.7,"
- SET DA=POSC
- DO ^DIK
- SET PRCHNORE=1
- QUIT
- End DoDot:2
- End DoDot:1
- +43 ;
- +44 SET DR="5///0;2////0"
- +45 SET DA(1)=PRCHPO
- SET DA=+PRCHI
- +46 SET DIE="^PRC(443.6,"_DA(1)_",2,"
- +47 DO ^DIE
- KILL DIE
- +48 SET DELIVER=1
- WRITE !
- +49 QUIT
- MV ;Move line item information from 442
- +1 if $DATA(^PRC(443.6,PRCHPO,2,0))
- QUIT
- if $PIECE($GET(^(0)),U,4)>0
- QUIT
- DO WAIT^DICD
- +2 NEW %X,%Y,N,M,PRCHPO1,OK,PRCHNORE
- +3 SET %X="^PRC(442,PRCHPO,2,"
- SET %Y="^PRC(443.6,PRCHPO,2,"
- DO %XY^%RCR
- +4 SET $PIECE(^PRC(443.6,PRCHPO,2,0),U,2)=$PIECE(^DD(443.6,40,0),U,2)
- KILL ^("C")
- +5 SET PRCHPO1=$PIECE(^PRC(442,PRCHPO,0),"^")
- +6 if '$DATA(^PRC(442.8,"B",PRCHPO1))
- QUIT
- if $DATA(^PRC(441.7,"B",PRCHPO1))
- QUIT
- +7 SET N=0
- SET M=+$PIECE(^PRC(441.7,0),"^",3)
- +8 FOR
- SET N=$ORDER(^PRC(442.8,"B",PRCHPO1,N))
- if 'N
- QUIT
- Begin DoDot:1
- MV1 SET M=M+1
- SET OK=$GET(^PRC(441.7,M,0))
- IF OK'=""
- GOTO MV1
- +1 SET ^PRC(441.7,M,0)=^PRC(442.8,N,0)
- +2 SET $PIECE(^PRC(441.7,M,0),U,7)=N
- +3 SET $PIECE(^PRC(441.7,0),"^",3)=M
- +4 SET $PIECE(^PRC(441.7,0),"^",4)=$PIECE(^(0),"^",4)+1
- +5 SET DIK="^PRC(441.7,"
- SET DA=M
- DO IX^DIK
- KILL DIK,DA
- +6 QUIT
- End DoDot:1
- +7 QUIT
- ONLY ;Make sure only 'Cancel' amendment
- +1 SET PRCHON=0
- +2 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)>2
- DO ERR
- QUIT
- +3 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)=2
- Begin DoDot:1
- +4 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)'=34
- DO ERR
- QUIT
- +5 SET PRCHON=1
- End DoDot:1
- QUIT
- +6 SET PRCHON=1
- +7 QUIT
- ERR ;Error
- +1 ;W !?5,"You can only "_$S($D(PRCHREQ):$P(^PRCD(442.2,15,0),U,2),1:$P(^PRCD(442.2,5,0),U,2))_" if this is the ONLY change you",!?5,"are making to the "_$S($D(PRCHREQ):"requisition.",1:"purchase order.")
- +2 WRITE !?5,"To "_$SELECT($DATA(PRCHREQ):$PIECE(^PRCD(442.2,15,0),U,2),1:$PIECE(^PRCD(442.2,5,0),U,2))_" it must be the ONLY change you",!?5,"are making on the amendment."
- +3 QUIT
- +4 ;
- SUPBOC(QUIETLY) ;compute pre-implied BOC, moved from template PRCHRQITEM, PRCHLINE into this routine and also called in BOC input transform
- +1 NEW PRCHIDA,SPFCP,PRCHBOCC,ACCT
- +2 if $GET(QUIETLY)=-1
- SET X=$PIECE($GET(^PRC(443.6,DA(1),2,DA,0)),U,4)
- +3 if '$DATA(X)
- QUIT
- +4 SET PRCHIDA=+$PIECE($GET(^PRC(443.6,DA(1),2,DA,0)),U,5)
- SET SPFCP=+$PIECE(^PRC(443.6,DA(1),0),U,19)
- +5 IF SPFCP=2
- Begin DoDot:1
- +6 SET PRCHN("SFC")=SPFCP
- SET ACCT=$$ACCT^PRCPUX1($EXTRACT($$NSN^PRCPUX1(PRCHIDA),1,4))
- +7 ;:$D(ACCT)
- Begin DoDot:2
- +8 SET PRCHBOCC=$PIECE($GET(^PRCD(420.2,$SELECT(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699),0)),U)
- +9 IF PRCHBOCC
- SET $PIECE(^PRC(443.6,DA(1),2,DA,0),U,4)=PRCHBOCC
- Begin DoDot:3
- +10 IF PRCHBOCC'=X
- IF PRCHBOCC
- if '$GET(QUIETLY)
- WRITE !,?5,"BOC must be ",PRCHBOCC,!,?5,"For a supply fund order, a BOC ",X," is invalid.",!
- SET X=PRCHBOCC
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 QUIT X
- +12 ;