62 lines
4.8 KiB
Mathematica
62 lines
4.8 KiB
Mathematica
PRCHSP ;WISC/PLT,ID/RSD/THD-SPLIT 2237 ;9/27/95 15:41 [1/28/99 3:00pm]
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
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 I PRCHSY=+Y D:$P(PRCHSY(0),U,3)]"" WS S ^PRC(443,PRCHSY,0)=PRCHSY(0),X=$P(PRCHSY(0),U,7) S:X ^PRC(443,"AC",X,PRCHSY)=""
|
|
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
|