PRCHE2 ;WISC/DJM,ID/RSD,SF-ISC/TKW-REMOVE 2237 FROM PO/PUT IN FILE 443 ;08/11/93 3:18 PM
V ;;5.1;IFCAP;**186**;Oct 20, 2000;Build 10
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*186 Fix duplicate entries in file 443 by changing
; the direct field 1.5 and x-ref 'AC' set to
; Fileman update of status field.
;
D ST^PRCHE Q:'$D(PRC("SITE"))
;
EN W !!,"Enter the Order number where the 2237 information resides."
S PRCHP("S")="$P(^(0),U,2)<8!($P(^(0),U,2)=25)" S:$D(PRCHNRQ) PRCHP("A")="REQUISITION NO.: ",PRCHP("S")="$P(^(0),U,2)=8!($P(^(0),U,2)=25)" S:$D(PRCHIMP) PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("S")="$P(^(0),U,2)=7"
D EN3^PRCHPAT Q:'$D(PRCHPO)
I $S($D(PRCHIMP)&(X=22):0,X>9:1,1:0) W $C(7)," ??" G EN
D LCK1^PRCHE G:'$D(DA) EN I '$O(^PRC(442,PRCHPO,13,0)) W !?3,"This Purchase Order contains no 2237 !",$C(7) G EN
W !?3,"This Purchase Order contains the following 2237's : " S PRCHP=+$P(^PRC(442,PRCHPO,0),U,12),PRCHP=$S($D(^PRCS(410,PRCHP,0)):PRCHP,1:0) S:PRCHP PRCHP(0)=$P(^(0),U,1) D HLP S PRCHLC=I
;
EN1 W !?3,"Enter the 2237 reference number you want to remove. You cannot",!," remove the PRIMARY 2237 unless you remove all other 2237s.",!
R !,"2237 REFERENCE NUMBER: ",X:DTIME G Q:X=""!(X=U) S PRCHY=$O(^PRCS(410,"B",$E(X,1,30),0))
I 'PRCHY W " ??",$C(7),!?3,"You must enter the entire 2237 reference number. Choose from: ",! D HLP G EN1
I PRCHY=PRCHP,PRCHLC>1 W " ??",$C(7) G EN1
K PRCHI F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I S X=^(I,0) I $P(X,U,10)=PRCHY S PRCHI(+X)=I_"^"_$G(^(1,1,0))
I '$D(PRCHI) W !!,$C(7),"There are NO items from this 2237 on this Purchase Order!!",! G EN1
W !?3,"The following items will be removed from this Purchase Order : " F I=0:0 S I=$O(PRCHI(I)) Q:'I W !?5,I,".",?12,$P(PRCHI(I),"^",2)
S %=2,%B="",%A=" Do you wish to proceed " D ^PRCFYN I %'=1 G Q
S PRCHY(0)=$P(^PRCS(410,PRCHY,0),U,1) G:PRCHP=PRCHY PRCS S X="HAS BEEN CARRIED FORWARD TO TRANSACTION",Y=PRCHY D WP
S X="REFLECTS ORIGINAL COST PLUS, $",Y=PRCHP D WP S DA(1)=PRCHY X ^DD(410.02,7,1,1,1)
S Y=$P(^PRCS(410,PRCHY,4),U,8),X=$P(^PRCS(410,PRCHP,4),U,8)-Y,$P(^(4),U,1)=X,$P(^(4),U,8)=X,X=$G(^(7)) I $P(X,"^",6)]"" D REMOVE^PRCSC1(PRCHP),ENCODE^PRCSC1(PRCHP,$P(X,"^",3))
;
PRCS D WAIT^DICD S X=$P(^PRCS(410,PRCHY,4),U,5),$P(^(4),U,5)="",$P(^(10),U,3)="" I X]"" K ^PRCS(410,"D",X,PRCHY)
S X=^PRCS(410,PRCHY,4) I $P(X,"^",10)]"" D REMOVE^PRCSC2(PRCHY),ENCODE^PRCSC2(PRCHY,$P(X,"^",3))
F I=0:0 S I=$O(^PRCS(410,PRCHY,"IT",I)) Q:'I S X=+^(I,0),^PRCS(410,PRCHY,"IT","AB",X,I)=""
S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1) G:'$O(^PRC(442.8,"B",PRCHPONO,0)) PRCS2 S DIK="^PRC(442.8,",PRCHI=0
;F PRCHLC=0:1 S PRCHI=$O(PRCHI(PRCHI)) Q:'PRCHI S PRCHLINO=$S($D(^PRC(442,PRCHPO,2,+PRCHI(PRCHI),0)):$P(^(0),U,1),1:"") I PRCHLINO F DA=0:0 S DA=$O(^PRC(442.8,"AC",PRCHPONO,PRCHLINO,DA)) Q:'DA D ^DIK
F PRCHLC=0:1 S PRCHI=$O(PRCHI(PRCHI)) Q:'PRCHI S PRCHLINO=$P($G(^PRC(442,PRCHPO,2,+PRCHI(PRCHI),0)),U,1) I PRCHLINO F DA=0:0 S DA=$O(^PRC(442.8,"AC",PRCHPONO,PRCHLINO,DA)) Q:'DA D ^DIK
;
PRCS2 S DIK="^PRC(442,PRCHPO,2,",PRCHI=0 F PRCHLC=0:1 S PRCHI=$O(PRCHI(PRCHI)) Q:'PRCHI S DA=+PRCHI(PRCHI),DA(1)=PRCHPO I DA,$D(^PRC(442,PRCHPO,2,DA)) D ^DIK
S $P(^PRC(442,PRCHPO,0),U,15)=0 K ^(9)
S Y=^PRC(442,PRCHPO,13,PRCHY,0),^PRC(443,PRCHY,0)=Y,$P(^PRC(443,0),U,3,4)=PRCHY_"^"_($P(^PRC(443,0),U,4)+1)
;PRC*5.1*186
S PRCHHDA=DA
S DIK="^PRC(443,",DA=PRCHY D IX^DIK K DIK
S DA=PRCHHDA K PRCHHDA
K ^PRC(442,PRCHPO,13,PRCHY) S $P(^(0),3,4)="0^"_($P(^(0),U,4)-1) I PRCHY=PRCHP S $P(^PRC(442,PRCHPO,0),U,12)="" K ^(13)
I $O(^PRC(442,PRCHPO,4,0))!($O(^PRC(442,PRCHPO,19,0))) W !!,"You may need to edit P.O. Comments!",! S DIE="^PRC(442,",DA=PRCHPO,DR="20;5.7" D ^DIE
;
Q K DIE,DR,I,J,K,PRCHLC,PRCHLINO,PRCHI,PRCHP,PRCHPONO,PRCHY,X,Y
G EN
;
HLP S X=0 F I=0:0 S X=$O(^PRC(442,PRCHPO,13,X)) Q:'X I $D(^PRCS(410,X,0)) W !?5,$P(^(0),U,1) W:PRCHP=X " PRIMARY",$C(7) S I=I+1
Q
;
WP Q:'$D(^PRCS(410,Y,"CO",0)) F I=0:0 S I=$O(^PRCS(410,Y,"CO",I)) Q:'I S J=^(I,0) I J[X,J["THE COST OF THIS REQUEST" K ^(0)
S I=0 F J=1:1 S I=$O(^PRCS(410,Y,"CO",I)) Q:'I I J'=I S K=^(I,0) K ^(0) S ^PRCS(410,Y,"CO",J,0)=K,I=J
S $P(^PRCS(410,Y,"CO",0),"^",3,4)=J_"^"_J
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHE2 4287 printed Dec 13, 2024@02:07:04 Page 2
PRCHE2 ;WISC/DJM,ID/RSD,SF-ISC/TKW-REMOVE 2237 FROM PO/PUT IN FILE 443 ;08/11/93 3:18 PM
V ;;5.1;IFCAP;**186**;Oct 20, 2000;Build 10
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*186 Fix duplicate entries in file 443 by changing
+4 ; the direct field 1.5 and x-ref 'AC' set to
+5 ; Fileman update of status field.
+6 ;
+7 DO ST^PRCHE
if '$DATA(PRC("SITE"))
QUIT
+8 ;
EN WRITE !!,"Enter the Order number where the 2237 information resides."
+1 SET PRCHP("S")="$P(^(0),U,2)<8!($P(^(0),U,2)=25)"
if $DATA(PRCHNRQ)
SET PRCHP("A")="REQUISITION NO.: "
SET PRCHP("S")="$P(^(0),U,2)=8!($P(^(0),U,2)=25)"
if $DATA(PRCHIMP)
SET PRCHP("A")="IMPREST FUND P.O.NO.: "
SET PRCHP("S")="$P(^(0),U,2)=7"
+2 DO EN3^PRCHPAT
if '$DATA(PRCHPO)
QUIT
+3 IF $SELECT($DATA(PRCHIMP)&(X=22):0,X>9:1,1:0)
WRITE $CHAR(7)," ??"
GOTO EN
+4 DO LCK1^PRCHE
if '$DATA(DA)
GOTO EN
IF '$ORDER(^PRC(442,PRCHPO,13,0))
WRITE !?3,"This Purchase Order contains no 2237 !",$CHAR(7)
GOTO EN
+5 WRITE !?3,"This Purchase Order contains the following 2237's : "
SET PRCHP=+$PIECE(^PRC(442,PRCHPO,0),U,12)
SET PRCHP=$SELECT($DATA(^PRCS(410,PRCHP,0)):PRCHP,1:0)
if PRCHP
SET PRCHP(0)=$PIECE(^(0),U,1)
DO HLP
SET PRCHLC=I
+6 ;
EN1 WRITE !?3,"Enter the 2237 reference number you want to remove. You cannot",!," remove the PRIMARY 2237 unless you remove all other 2237s.",!
+1 READ !,"2237 REFERENCE NUMBER: ",X:DTIME
if X=""!(X=U)
GOTO Q
SET PRCHY=$ORDER(^PRCS(410,"B",$EXTRACT(X,1,30),0))
+2 IF 'PRCHY
WRITE " ??",$CHAR(7),!?3,"You must enter the entire 2237 reference number. Choose from: ",!
DO HLP
GOTO EN1
+3 IF PRCHY=PRCHP
IF PRCHLC>1
WRITE " ??",$CHAR(7)
GOTO EN1
+4 KILL PRCHI
FOR I=0:0
SET I=$ORDER(^PRC(442,PRCHPO,2,I))
if 'I
QUIT
SET X=^(I,0)
IF $PIECE(X,U,10)=PRCHY
SET PRCHI(+X)=I_"^"_$GET(^(1,1,0))
+5 IF '$DATA(PRCHI)
WRITE !!,$CHAR(7),"There are NO items from this 2237 on this Purchase Order!!",!
GOTO EN1
+6 WRITE !?3,"The following items will be removed from this Purchase Order : "
FOR I=0:0
SET I=$ORDER(PRCHI(I))
if 'I
QUIT
WRITE !?5,I,".",?12,$PIECE(PRCHI(I),"^",2)
+7 SET %=2
SET %B=""
SET %A=" Do you wish to proceed "
DO ^PRCFYN
IF %'=1
GOTO Q
+8 SET PRCHY(0)=$PIECE(^PRCS(410,PRCHY,0),U,1)
if PRCHP=PRCHY
GOTO PRCS
SET X="HAS BEEN CARRIED FORWARD TO TRANSACTION"
SET Y=PRCHY
DO WP
+9 SET X="REFLECTS ORIGINAL COST PLUS, $"
SET Y=PRCHP
DO WP
SET DA(1)=PRCHY
XECUTE ^DD(410.02,7,1,1,1)
+10 SET Y=$PIECE(^PRCS(410,PRCHY,4),U,8)
SET X=$PIECE(^PRCS(410,PRCHP,4),U,8)-Y
SET $PIECE(^(4),U,1)=X
SET $PIECE(^(4),U,8)=X
SET X=$GET(^(7))
IF $PIECE(X,"^",6)]""
DO REMOVE^PRCSC1(PRCHP)
DO ENCODE^PRCSC1(PRCHP,$PIECE(X,"^",3))
+11 ;
PRCS DO WAIT^DICD
SET X=$PIECE(^PRCS(410,PRCHY,4),U,5)
SET $PIECE(^(4),U,5)=""
SET $PIECE(^(10),U,3)=""
IF X]""
KILL ^PRCS(410,"D",X,PRCHY)
+1 SET X=^PRCS(410,PRCHY,4)
IF $PIECE(X,"^",10)]""
DO REMOVE^PRCSC2(PRCHY)
DO ENCODE^PRCSC2(PRCHY,$PIECE(X,"^",3))
+2 FOR I=0:0
SET I=$ORDER(^PRCS(410,PRCHY,"IT",I))
if 'I
QUIT
SET X=+^(I,0)
SET ^PRCS(410,PRCHY,"IT","AB",X,I)=""
+3 SET PRCHPONO=$PIECE(^PRC(442,PRCHPO,0),U,1)
if '$ORDER(^PRC(442.8,"B",PRCHPONO,0))
GOTO PRCS2
SET DIK="^PRC(442.8,"
SET PRCHI=0
+4 ;F PRCHLC=0:1 S PRCHI=$O(PRCHI(PRCHI)) Q:'PRCHI S PRCHLINO=$S($D(^PRC(442,PRCHPO,2,+PRCHI(PRCHI),0)):$P(^(0),U,1),1:"") I PRCHLINO F DA=0:0 S DA=$O(^PRC(442.8,"AC",PRCHPONO,PRCHLINO,DA)) Q:'DA D ^DIK
+5 FOR PRCHLC=0:1
SET PRCHI=$ORDER(PRCHI(PRCHI))
if 'PRCHI
QUIT
SET PRCHLINO=$PIECE($GET(^PRC(442,PRCHPO,2,+PRCHI(PRCHI),0)),U,1)
IF PRCHLINO
FOR DA=0:0
SET DA=$ORDER(^PRC(442.8,"AC",PRCHPONO,PRCHLINO,DA))
if 'DA
QUIT
DO ^DIK
+6 ;
PRCS2 SET DIK="^PRC(442,PRCHPO,2,"
SET PRCHI=0
FOR PRCHLC=0:1
SET PRCHI=$ORDER(PRCHI(PRCHI))
if 'PRCHI
QUIT
SET DA=+PRCHI(PRCHI)
SET DA(1)=PRCHPO
IF DA
IF $DATA(^PRC(442,PRCHPO,2,DA))
DO ^DIK
+1 SET $PIECE(^PRC(442,PRCHPO,0),U,15)=0
KILL ^(9)
+2 SET Y=^PRC(442,PRCHPO,13,PRCHY,0)
SET ^PRC(443,PRCHY,0)=Y
SET $PIECE(^PRC(443,0),U,3,4)=PRCHY_"^"_($PIECE(^PRC(443,0),U,4)+1)
+3 ;PRC*5.1*186
+4 SET PRCHHDA=DA
+5 SET DIK="^PRC(443,"
SET DA=PRCHY
DO IX^DIK
KILL DIK
+6 SET DA=PRCHHDA
KILL PRCHHDA
+7 KILL ^PRC(442,PRCHPO,13,PRCHY)
SET $PIECE(^(0),3,4)="0^"_($PIECE(^(0),U,4)-1)
IF PRCHY=PRCHP
SET $PIECE(^PRC(442,PRCHPO,0),U,12)=""
KILL ^(13)
+8 IF $ORDER(^PRC(442,PRCHPO,4,0))!($ORDER(^PRC(442,PRCHPO,19,0)))
WRITE !!,"You may need to edit P.O. Comments!",!
SET DIE="^PRC(442,"
SET DA=PRCHPO
SET DR="20;5.7"
DO ^DIE
+9 ;
Q KILL DIE,DR,I,J,K,PRCHLC,PRCHLINO,PRCHI,PRCHP,PRCHPONO,PRCHY,X,Y
+1 GOTO EN
+2 ;
HLP SET X=0
FOR I=0:0
SET X=$ORDER(^PRC(442,PRCHPO,13,X))
if 'X
QUIT
IF $DATA(^PRCS(410,X,0))
WRITE !?5,$PIECE(^(0),U,1)
if PRCHP=X
WRITE " PRIMARY",$CHAR(7)
SET I=I+1
+1 QUIT
+2 ;
WP if '$DATA(^PRCS(410,Y,"CO",0))
QUIT
FOR I=0:0
SET I=$ORDER(^PRCS(410,Y,"CO",I))
if 'I
QUIT
SET J=^(I,0)
IF J[X
IF J["THE COST OF THIS REQUEST"
KILL ^(0)
+1 SET I=0
FOR J=1:1
SET I=$ORDER(^PRCS(410,Y,"CO",I))
if 'I
QUIT
IF J'=I
SET K=^(I,0)
KILL ^(0)
SET ^PRCS(410,Y,"CO",J,0)=K
SET I=J
+2 SET $PIECE(^PRCS(410,Y,"CO",0),"^",3,4)=J_"^"_J
+3 QUIT
