source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSP.m@ 1156

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