PRCHSP ;WISC/PLT,ID/RSD/THD-SPLIT 2237 ;9/27/95 15:41 [1/28/99 3:00pm]
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.
;
EN1 S Z=$P($G(^PRCS(410,PRCHS,0)),"-",1,4) S:Z="" PRCHSY=-3 Q:Z="" S X=$P(Z,"-",1,2)_"-"_$P(Z,"-",4) D EN1^PRCSUT3
I X="" S PRCHSY=-1 Q
EN11 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="FLZ" D ^DIC K DLAYGO S PRCHSY=+Y I PRCHSY=-1 D TRY G:PRCHTRY<4 EN11 K PRCHTRY Q
S PRCHSX=$P(Y(0),U,1),$P(PRCHSY(0),U,1)=+Y,%X="^PRCS(410,PRCHS,",%Y="^PRCS(410,PRCHSY," D %XY^%RCR K ^PRCS(410,PRCHSY,"IT")
S $P(^PRCS(410,PRCHSY,0),U,1)=PRCHSX
N PRCHY0,PRCHQD,PRCHXREF
S PRCHY0=$G(^PRCS(410,PRCHSY,0))
S PRCHQD=$P(PRCHY0,U,11),PRCHXREF=PRCHQD_"-"_+PRCHY0_"-"_$P(PRCHY0,"-",4)_"-"_$P(PRCHY0,"-",2)_"-"_$P($P(PRCHY0,"-",5),"^")
S ^PRCS(410,"RB",PRCHXREF,PRCHSY)=""
S X=$P(^PRCS(410,PRCHSY,0),U,3) S:X]"" ^PRCS(410,"H",$E(X,1,30),PRCHSY)=$P($G(^PRCS(410,PRCHSY,11)),U,2) S X=$P($G(^PRCS(410,PRCHSY,2)),U,1) S:X]"" ^PRCS(410,"E",$E(X,1,30),PRCHSY)=""
S Y=$G(^PRCS(410,PRCHSY,3)) I Y]"" S X=$P(Y,U,1) S:X]"" ^PRCS(410,"AN",$E(X,1,30),PRCHSY)="" S X=$P(Y,U,3) S:X]"" ^PRCS(410,"AC",$E(X,1,30),PRCHSY)=""
S X=$P($G(^PRCS(410,PRCHSY,11)),U,1) S:X]"" ^PRCS(410,"J",$E(X,1,30),PRCHSY)=""
F I=0:0 S I=$O(^PRCS(410,PRCHSY,12,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,1) S:X]"" ^PRCS(410,"C",$E(X,1,30),PRCHSY,I)=""
S PRCHINVP=+$P(^PRCS(410,PRCHS,0),U,6)
S PRCHJ=0 F PRCHK=0:0 S PRCHK=$O(^TMP($J,"PRCHS",PRCHK)),PRCHJ=PRCHJ+1 Q:'PRCHK!(PRCHJ>PRCHSIT) S PRCHX=$S($D(^PRCS(410,PRCHS,"IT","B",PRCHK)):$O(^(PRCHK,0)),1:-1) D:PRCHX'=""&(PRCHX'<0) OT
K PRCHINVP,PRCHINVI S PRCHSIT=PRCHJ-1
S DA(1)=PRCHS,DA=PRCHX X ^DD(410.02,7,1,1,1)
N PRCA,PRCHRFQT
S PRCA=^PRCS(410,DA(1),0),PRCHRFQT=$$DATE^PRC0C($P(PRCA,"^",11),"I")
S PRCA=+PRCA_"^"_$P(PRCA,"-",4)_"^"_$E($P(PRCHRFQT,"^"),3,4)_"^"_$P(PRCHRFQT,"^",2)_"^"_-$P(^PRCS(410,DA(1),4),"^",8)
D EBAL^PRCSEZ(PRCA,"C")
S DA(1)=PRCHSY,DA=PRCHJ X ^DD(410.02,7,1,1,1)
S PRCA=^PRCS(410,DA(1),0),PRCHRFQT=$$DATE^PRC0C($P(PRCA,"^",11),"I")
S PRCA=+PRCA_"^"_$P(PRCA,"-",4)_"^"_$E($P(PRCHRFQT,"^"),3,4)_"^"_$P(PRCHRFQT,"^",2)_"^"_-$P(^PRCS(410,DA(1),4),"^",8)
D EBAL^PRCSEZ(PRCA,"C")
S ^PRCS(410,PRCHSY,"IT",0)=$P(^PRCS(410,PRCHS,"IT",0),U,1,2)_U_PRCHSIT_U_PRCHSIT,J=0 S:'$D(^PRCS(410,PRCHS,"CO",0)) ^(0)="^^^^"_DT S I=0 F S I=$O(^PRCS(410,PRCHS,"CO",I)) Q:I="" S J=J+1
;Add code to create array, send to bulletin routine at SENDIT2^PRCSEB1
N PSCT,PRCSAR S PSCT=1
S J=J+1,K=1,^PRCS(410,PRCHS,"CO",J,0)=" THIS REQUEST HAS BEEN SPLIT. ITEMS: "_($E(PRCHSIT(K),1,($L(PRCHSIT(K))-1)))
S PRCSAR(PSCT)=" REQUEST "_$P(^PRCS(410,PRCHS,0),"^")_" HAS BEEN SPLIT.",PRCSAR(PSCT+1)="ITEMS: "_($E(PRCHSIT(K),1,($L(PRCHSIT(K))-1)))
I $O(PRCHSIT(K)) F K=K:0 S K=$O(PRCHSIT(K)) Q:'K S J=J+1,PSCT=PSCT+1,(PRCSAR(PSCT),^PRCS(410,PRCHS,"CO",J,0))=","_($E(PRCHSIT(K),1,($L(PRCHSIT(K))-1)))
S ^PRCS(410,PRCHS,"CO",J,0)=^PRCS(410,PRCHS,"CO",J,0)_" ARE IN TRANSACTION "_PRCHSX,^PRCS(410,PRCHS,"CO",0)="^^"_J_U_J_U_DT_"^^"
S PSCT=PSCT+2,PRCSAR(PSCT)="ARE IN TRANSACTION "_PRCHSX_"." D SENDIT2^PRCSEB1
S X=$P(^PRCS(410,PRCHS,0),U,1),$P(^PRCS(410,PRCHSY,10),U,1,2)=PRCHSIT_U_X,^PRCS(410,"AG",$E(X,1,30),PRCHSY)=""
S DA=PRCHSY,P=$P($G(^PRCS(410,DA,7)),"^",3) S:P<1 P=DUZ D REMOVE^PRCSC1(DA),ENCODE^PRCSC1(DA,P,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ
S DA=PRCHS,P=$P($G(^PRCS(410,DA,7)),"^",3) S:P<1 P=DUZ D REMOVE^PRCSC1(DA),ENCODE^PRCSC1(DA,P,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ
S DIC="^PRC(443,",DIC(0)="L",DLAYGO=443,X=PRCHSX D ^DIC K DIC,DLAYGO
;PRC*5.1*186
I PRCHSY=+Y D
. S PRCHHDA=DA
. D:$P(PRCHSY(0),U,3)]"" WS
. S ^PRC(443,PRCHSY,0)=PRCHSY(0)
. S DIK="^PRC(443,",DA=PRCHSY D IX^DIK K DIK
. S DA=PRCHHDA K PRCHHDA
Q:$D(PRCHG)
G ^PRCHSP1
;
OT S %X="^PRCS(410,PRCHS,""IT"",PRCHX,",%Y="^PRCS(410,PRCHSY,""IT"",PRCHJ," D %XY^%RCR
S $P(^PRCS(410,PRCHS,"IT",PRCHX,0),U,7)=0,Y=$E($P(^(0),U,4),1,30)
K ^PRCS(410,PRCHS,"IT","AB",PRCHK) S $P(^PRCS(410,PRCHS,"IT",PRCHX,0),U,10)=PRCHPO
S ^PRCS(410,PRCHSY,"IT","AB",PRCHJ,PRCHJ)="",^PRCS(410,PRCHSY,"IT","B",PRCHJ,PRCHJ)="",$P(^PRCS(410,PRCHSY,"IT",PRCHJ,0),U,10)=PRCHPO,$P(^PRCS(410,PRCHSY,"IT",PRCHJ,0),U,1)=PRCHJ
;MOVE DELIVERY SCHEDULE (IF ANY) TO NEW ITEM
D ^PRCSUT41
;IF ORDERED BY INVENTORY SYSTEM, MOVE ORDER DATA FOR NEW REQUEST TO INVENTORY FILE
S PRCHINVI=+$P(^PRCS(410,PRCHS,"IT",PRCHX,0),U,5) I $D(^PRCP(445,PRCHINVP,1,PRCHINVI,0)) D SPLIT^PRCPWI(PRCHINVP,PRCHINVI,PRCHS,PRCHSY)
Q
;
WS S P=$P(PRCHSY(0),U,2),X=$P(PRCHSY(0),U,3),DA=PRCHS,Y="",Y=$$DECODE^PRCHES11(DA) S DA=PRCHSY,PRCSIG="" D ENCODE^PRCHES11(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ S X=$P(^PRC(443,DA,0),U,3),$P(PRCHSY(0),U,3)=X
Q
;
TRY ;MAKE MULTIPLE TRIES TO GET A TRANSACTION NUMBER (IN CASE FILE IS LOCKED BY ANOTHER USER).
S:'$D(PRCHTRY) PRCHTRY=0 S PRCHTRY=PRCHTRY+1 Q
;
QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR K ROUTINE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHSP 5257 printed Dec 13, 2024@02:10:43 Page 2
PRCHSP ;WISC/PLT,ID/RSD/THD-SPLIT 2237 ;9/27/95 15:41 [1/28/99 3:00pm]
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 ;
EN1 SET Z=$PIECE($GET(^PRCS(410,PRCHS,0)),"-",1,4)
if Z=""
SET PRCHSY=-3
if Z=""
QUIT
SET X=$PIECE(Z,"-",1,2)_"-"_$PIECE(Z,"-",4)
DO EN1^PRCSUT3
+1 IF X=""
SET PRCHSY=-1
QUIT
EN11 SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="FLZ"
DO ^DIC
KILL DLAYGO
SET PRCHSY=+Y
IF PRCHSY=-1
DO TRY
if PRCHTRY<4
GOTO EN11
KILL PRCHTRY
QUIT
+1 SET PRCHSX=$PIECE(Y(0),U,1)
SET $PIECE(PRCHSY(0),U,1)=+Y
SET %X="^PRCS(410,PRCHS,"
SET %Y="^PRCS(410,PRCHSY,"
DO %XY^%RCR
KILL ^PRCS(410,PRCHSY,"IT")
+2 SET $PIECE(^PRCS(410,PRCHSY,0),U,1)=PRCHSX
+3 NEW PRCHY0,PRCHQD,PRCHXREF
+4 SET PRCHY0=$GET(^PRCS(410,PRCHSY,0))
+5 SET PRCHQD=$PIECE(PRCHY0,U,11)
SET PRCHXREF=PRCHQD_"-"_+PRCHY0_"-"_$PIECE(PRCHY0,"-",4)_"-"_$PIECE(PRCHY0,"-",2)_"-"_$PIECE($PIECE(PRCHY0,"-",5),"^")
+6 SET ^PRCS(410,"RB",PRCHXREF,PRCHSY)=""
+7 SET X=$PIECE(^PRCS(410,PRCHSY,0),U,3)
if X]""
SET ^PRCS(410,"H",$EXTRACT(X,1,30),PRCHSY)=$PIECE($GET(^PRCS(410,PRCHSY,11)),U,2)
SET X=$PIECE($GET(^PRCS(410,PRCHSY,2)),U,1)
if X]""
SET ^PRCS(410,"E",$EXTRACT(X,1,30),PRCHSY)=""
+8 SET Y=$GET(^PRCS(410,PRCHSY,3))
IF Y]""
SET X=$PIECE(Y,U,1)
if X]""
SET ^PRCS(410,"AN",$EXTRACT(X,1,30),PRCHSY)=""
SET X=$PIECE(Y,U,3)
if X]""
SET ^PRCS(410,"AC",$EXTRACT(X,1,30),PRCHSY)=""
+9 SET X=$PIECE($GET(^PRCS(410,PRCHSY,11)),U,1)
if X]""
SET ^PRCS(410,"J",$EXTRACT(X,1,30),PRCHSY)=""
+10 FOR I=0:0
SET I=$ORDER(^PRCS(410,PRCHSY,12,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET X=$PIECE(^(0),U,1)
if X]""
SET ^PRCS(410,"C",$EXTRACT(X,1,30),PRCHSY,I)=""
+11 SET PRCHINVP=+$PIECE(^PRCS(410,PRCHS,0),U,6)
+12 SET PRCHJ=0
FOR PRCHK=0:0
SET PRCHK=$ORDER(^TMP($JOB,"PRCHS",PRCHK))
SET PRCHJ=PRCHJ+1
if 'PRCHK!(PRCHJ>PRCHSIT)
QUIT
SET PRCHX=$SELECT($DATA(^PRCS(410,PRCHS,"IT","B",PRCHK)):$ORDER(^(PRCHK,0)),1:-1)
if PRCHX'=""&(PRCHX'<0)
DO OT
+13 KILL PRCHINVP,PRCHINVI
SET PRCHSIT=PRCHJ-1
+14 SET DA(1)=PRCHS
SET DA=PRCHX
XECUTE ^DD(410.02,7,1,1,1)
+15 NEW PRCA,PRCHRFQT
+16 SET PRCA=^PRCS(410,DA(1),0)
SET PRCHRFQT=$$DATE^PRC0C($PIECE(PRCA,"^",11),"I")
+17 SET PRCA=+PRCA_"^"_$PIECE(PRCA,"-",4)_"^"_$EXTRACT($PIECE(PRCHRFQT,"^"),3,4)_"^"_$PIECE(PRCHRFQT,"^",2)_"^"_-$PIECE(^PRCS(410,DA(1),4),"^",8)
+18 DO EBAL^PRCSEZ(PRCA,"C")
+19 SET DA(1)=PRCHSY
SET DA=PRCHJ
XECUTE ^DD(410.02,7,1,1,1)
+20 SET PRCA=^PRCS(410,DA(1),0)
SET PRCHRFQT=$$DATE^PRC0C($PIECE(PRCA,"^",11),"I")
+21 SET PRCA=+PRCA_"^"_$PIECE(PRCA,"-",4)_"^"_$EXTRACT($PIECE(PRCHRFQT,"^"),3,4)_"^"_$PIECE(PRCHRFQT,"^",2)_"^"_-$PIECE(^PRCS(410,DA(1),4),"^",8)
+22 DO EBAL^PRCSEZ(PRCA,"C")
+23 SET ^PRCS(410,PRCHSY,"IT",0)=$PIECE(^PRCS(410,PRCHS,"IT",0),U,1,2)_U_PRCHSIT_U_PRCHSIT
SET J=0
if '$DATA(^PRCS(410,PRCHS,"CO",0))
SET ^(0)="^^^^"_DT
SET I=0
FOR
SET I=$ORDER(^PRCS(410,PRCHS,"CO",I))
if I=""
QUIT
SET J=J+1
+24 ;Add code to create array, send to bulletin routine at SENDIT2^PRCSEB1
+25 NEW PSCT,PRCSAR
SET PSCT=1
+26 SET J=J+1
SET K=1
SET ^PRCS(410,PRCHS,"CO",J,0)=" THIS REQUEST HAS BEEN SPLIT. ITEMS: "_($EXTRACT(PRCHSIT(K),1,($LENGTH(PRCHSIT(K))-1)))
+27 SET PRCSAR(PSCT)=" REQUEST "_$PIECE(^PRCS(410,PRCHS,0),"^")_" HAS BEEN SPLIT."
SET PRCSAR(PSCT+1)="ITEMS: "_($EXTRACT(PRCHSIT(K),1,($LENGTH(PRCHSIT(K))-1)))
+28 IF $ORDER(PRCHSIT(K))
FOR K=K:0
SET K=$ORDER(PRCHSIT(K))
if 'K
QUIT
SET J=J+1
SET PSCT=PSCT+1
SET (PRCSAR(PSCT),^PRCS(410,PRCHS,"CO",J,0))=","_($EXTRACT(PRCHSIT(K),1,($LENGTH(PRCHSIT(K))-1)))
+29 SET ^PRCS(410,PRCHS,"CO",J,0)=^PRCS(410,PRCHS,"CO",J,0)_" ARE IN TRANSACTION "_PRCHSX
SET ^PRCS(410,PRCHS,"CO",0)="^^"_J_U_J_U_DT_"^^"
+30 SET PSCT=PSCT+2
SET PRCSAR(PSCT)="ARE IN TRANSACTION "_PRCHSX_"."
DO SENDIT2^PRCSEB1
+31 SET X=$PIECE(^PRCS(410,PRCHS,0),U,1)
SET $PIECE(^PRCS(410,PRCHSY,10),U,1,2)=PRCHSIT_U_X
SET ^PRCS(410,"AG",$EXTRACT(X,1,30),PRCHSY)=""
+32 SET DA=PRCHSY
SET P=$PIECE($GET(^PRCS(410,DA,7)),"^",3)
if P<1
SET P=DUZ
DO REMOVE^PRCSC1(DA)
DO ENCODE^PRCSC1(DA,P,.PRCSIG)
SET ROUTINE=$TEXT(+0)
if PRCSIG<1
GOTO QQ
+33 SET DA=PRCHS
SET P=$PIECE($GET(^PRCS(410,DA,7)),"^",3)
if P<1
SET P=DUZ
DO REMOVE^PRCSC1(DA)
DO ENCODE^PRCSC1(DA,P,.PRCSIG)
SET ROUTINE=$TEXT(+0)
if PRCSIG<1
GOTO QQ
+34 SET DIC="^PRC(443,"
SET DIC(0)="L"
SET DLAYGO=443
SET X=PRCHSX
DO ^DIC
KILL DIC,DLAYGO
+35 ;PRC*5.1*186
+36 IF PRCHSY=+Y
Begin DoDot:1
+37 SET PRCHHDA=DA
+38 if $PIECE(PRCHSY(0),U,3)]""
DO WS
+39 SET ^PRC(443,PRCHSY,0)=PRCHSY(0)
+40 SET DIK="^PRC(443,"
SET DA=PRCHSY
DO IX^DIK
KILL DIK
+41 SET DA=PRCHHDA
KILL PRCHHDA
End DoDot:1
+42 if $DATA(PRCHG)
QUIT
+43 GOTO ^PRCHSP1
+44 ;
OT SET %X="^PRCS(410,PRCHS,""IT"",PRCHX,"
SET %Y="^PRCS(410,PRCHSY,""IT"",PRCHJ,"
DO %XY^%RCR
+1 SET $PIECE(^PRCS(410,PRCHS,"IT",PRCHX,0),U,7)=0
SET Y=$EXTRACT($PIECE(^(0),U,4),1,30)
+2 KILL ^PRCS(410,PRCHS,"IT","AB",PRCHK)
SET $PIECE(^PRCS(410,PRCHS,"IT",PRCHX,0),U,10)=PRCHPO
+3 SET ^PRCS(410,PRCHSY,"IT","AB",PRCHJ,PRCHJ)=""
SET ^PRCS(410,PRCHSY,"IT","B",PRCHJ,PRCHJ)=""
SET $PIECE(^PRCS(410,PRCHSY,"IT",PRCHJ,0),U,10)=PRCHPO
SET $PIECE(^PRCS(410,PRCHSY,"IT",PRCHJ,0),U,1)=PRCHJ
+4 ;MOVE DELIVERY SCHEDULE (IF ANY) TO NEW ITEM
+5 DO ^PRCSUT41
+6 ;IF ORDERED BY INVENTORY SYSTEM, MOVE ORDER DATA FOR NEW REQUEST TO INVENTORY FILE
+7 SET PRCHINVI=+$PIECE(^PRCS(410,PRCHS,"IT",PRCHX,0),U,5)
IF $DATA(^PRCP(445,PRCHINVP,1,PRCHINVI,0))
DO SPLIT^PRCPWI(PRCHINVP,PRCHINVI,PRCHS,PRCHSY)
+8 QUIT
+9 ;
WS SET P=$PIECE(PRCHSY(0),U,2)
SET X=$PIECE(PRCHSY(0),U,3)
SET DA=PRCHS
SET Y=""
SET Y=$$DECODE^PRCHES11(DA)
SET DA=PRCHSY
SET PRCSIG=""
DO ENCODE^PRCHES11(DA,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
if PRCSIG<1
GOTO QQ
SET X=$PIECE(^PRC(443,DA,0),U,3)
SET $PIECE(PRCHSY(0),U,3)=X
+1 QUIT
+2 ;
TRY ;MAKE MULTIPLE TRIES TO GET A TRANSACTION NUMBER (IN CASE FILE IS LOCKED BY ANOTHER USER).
+1 if '$DATA(PRCHTRY)
SET PRCHTRY=0
SET PRCHTRY=PRCHTRY+1
QUIT
+2 ;
QQ if '$DATA(ROUTINE)
SET ROUTINE=$TEXT(+0)
WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
if PRCSIG=0!(PRCSIG=-3)
WRITE !,"Notify Application Coordinator!",$CHAR(7)
SET DIR(0)="EAO"
SET DIR("A")="Press <return> to continue"
DO ^DIR
KILL ROUTINE
+1 QUIT
