source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSP.m@ 1420

Last change on this file since 1420 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1PRCHSP ;WISC/PLT,ID/RSD/THD-SPLIT 2237 ;9/27/95 15:41 [1/28/99 3:00pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN1 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
5 I X="" S PRCHSY=-1 Q
6EN11 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
7 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")
8 S $P(^PRCS(410,PRCHSY,0),U,1)=PRCHSX
9 N PRCHY0,PRCHQD,PRCHXREF
10 S PRCHY0=$G(^PRCS(410,PRCHSY,0))
11 S PRCHQD=$P(PRCHY0,U,11),PRCHXREF=PRCHQD_"-"_+PRCHY0_"-"_$P(PRCHY0,"-",4)_"-"_$P(PRCHY0,"-",2)_"-"_$P($P(PRCHY0,"-",5),"^")
12 S ^PRCS(410,"RB",PRCHXREF,PRCHSY)=""
13 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)=""
14 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)=""
15 S X=$P($G(^PRCS(410,PRCHSY,11)),U,1) S:X]"" ^PRCS(410,"J",$E(X,1,30),PRCHSY)=""
16 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)=""
17 S PRCHINVP=+$P(^PRCS(410,PRCHS,0),U,6)
18 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
19 K PRCHINVP,PRCHINVI S PRCHSIT=PRCHJ-1
20 S DA(1)=PRCHS,DA=PRCHX X ^DD(410.02,7,1,1,1)
21 N PRCA,PRCHRFQT
22 S PRCA=^PRCS(410,DA(1),0),PRCHRFQT=$$DATE^PRC0C($P(PRCA,"^",11),"I")
23 S PRCA=+PRCA_"^"_$P(PRCA,"-",4)_"^"_$E($P(PRCHRFQT,"^"),3,4)_"^"_$P(PRCHRFQT,"^",2)_"^"_-$P(^PRCS(410,DA(1),4),"^",8)
24 D EBAL^PRCSEZ(PRCA,"C")
25 S DA(1)=PRCHSY,DA=PRCHJ X ^DD(410.02,7,1,1,1)
26 S PRCA=^PRCS(410,DA(1),0),PRCHRFQT=$$DATE^PRC0C($P(PRCA,"^",11),"I")
27 S PRCA=+PRCA_"^"_$P(PRCA,"-",4)_"^"_$E($P(PRCHRFQT,"^"),3,4)_"^"_$P(PRCHRFQT,"^",2)_"^"_-$P(^PRCS(410,DA(1),4),"^",8)
28 D EBAL^PRCSEZ(PRCA,"C")
29 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
30 ;Add code to create array, send to bulletin routine at SENDIT2^PRCSEB1
31 N PSCT,PRCSAR S PSCT=1
32 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)))
33 S PRCSAR(PSCT)=" REQUEST "_$P(^PRCS(410,PRCHS,0),"^")_" HAS BEEN SPLIT.",PRCSAR(PSCT+1)="ITEMS: "_($E(PRCHSIT(K),1,($L(PRCHSIT(K))-1)))
34 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)))
35 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_"^^"
36 S PSCT=PSCT+2,PRCSAR(PSCT)="ARE IN TRANSACTION "_PRCHSX_"." D SENDIT2^PRCSEB1
37 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)=""
38 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
39 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
40 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)=""
41 Q:$D(PRCHG)
42 G ^PRCHSP1
43 ;
44OT S %X="^PRCS(410,PRCHS,""IT"",PRCHX,",%Y="^PRCS(410,PRCHSY,""IT"",PRCHJ," D %XY^%RCR
45 S $P(^PRCS(410,PRCHS,"IT",PRCHX,0),U,7)=0,Y=$E($P(^(0),U,4),1,30)
46 K ^PRCS(410,PRCHS,"IT","AB",PRCHK) S $P(^PRCS(410,PRCHS,"IT",PRCHX,0),U,10)=PRCHPO
47 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
48 ;MOVE DELIVERY SCHEDULE (IF ANY) TO NEW ITEM
49 D ^PRCSUT41
50 ;IF ORDERED BY INVENTORY SYSTEM, MOVE ORDER DATA FOR NEW REQUEST TO INVENTORY FILE
51 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)
52 Q
53 ;
54WS 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
55 Q
56 ;
57TRY ;MAKE MULTIPLE TRIES TO GET A TRANSACTION NUMBER (IN CASE FILE IS LOCKED BY ANOTHER USER).
58 S:'$D(PRCHTRY) PRCHTRY=0 S PRCHTRY=PRCHTRY+1 Q
59 ;
60QQ 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
61 Q
Note: See TracBrowser for help on using the repository browser.