Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHSP

PRCHSP.m

Go to the documentation of this file.
  1. PRCHSP ;WISC/PLT,ID/RSD/THD-SPLIT 2237 ;9/27/95 15:41 [1/28/99 3:00pm]
  1. V ;;5.1;IFCAP;**186**;Oct 20, 2000;Build 10
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;PRC*5.1*186 Fix duplicate entries in file 443 by changing
  1. ; the direct field 1.5 and x-ref 'AC' set to
  1. ; Fileman update of status field.
  1. ;
  1. 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
  1. I X="" S PRCHSY=-1 Q
  1. 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
  1. 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")
  1. S $P(^PRCS(410,PRCHSY,0),U,1)=PRCHSX
  1. N PRCHY0,PRCHQD,PRCHXREF
  1. S PRCHY0=$G(^PRCS(410,PRCHSY,0))
  1. S PRCHQD=$P(PRCHY0,U,11),PRCHXREF=PRCHQD_"-"_+PRCHY0_"-"_$P(PRCHY0,"-",4)_"-"_$P(PRCHY0,"-",2)_"-"_$P($P(PRCHY0,"-",5),"^")
  1. S ^PRCS(410,"RB",PRCHXREF,PRCHSY)=""
  1. 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)=""
  1. 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)=""
  1. S X=$P($G(^PRCS(410,PRCHSY,11)),U,1) S:X]"" ^PRCS(410,"J",$E(X,1,30),PRCHSY)=""
  1. 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)=""
  1. S PRCHINVP=+$P(^PRCS(410,PRCHS,0),U,6)
  1. 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
  1. K PRCHINVP,PRCHINVI S PRCHSIT=PRCHJ-1
  1. S DA(1)=PRCHS,DA=PRCHX X ^DD(410.02,7,1,1,1)
  1. N PRCA,PRCHRFQT
  1. S PRCA=^PRCS(410,DA(1),0),PRCHRFQT=$$DATE^PRC0C($P(PRCA,"^",11),"I")
  1. S PRCA=+PRCA_"^"_$P(PRCA,"-",4)_"^"_$E($P(PRCHRFQT,"^"),3,4)_"^"_$P(PRCHRFQT,"^",2)_"^"_-$P(^PRCS(410,DA(1),4),"^",8)
  1. D EBAL^PRCSEZ(PRCA,"C")
  1. S DA(1)=PRCHSY,DA=PRCHJ X ^DD(410.02,7,1,1,1)
  1. S PRCA=^PRCS(410,DA(1),0),PRCHRFQT=$$DATE^PRC0C($P(PRCA,"^",11),"I")
  1. S PRCA=+PRCA_"^"_$P(PRCA,"-",4)_"^"_$E($P(PRCHRFQT,"^"),3,4)_"^"_$P(PRCHRFQT,"^",2)_"^"_-$P(^PRCS(410,DA(1),4),"^",8)
  1. D EBAL^PRCSEZ(PRCA,"C")
  1. 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
  1. ;Add code to create array, send to bulletin routine at SENDIT2^PRCSEB1
  1. N PSCT,PRCSAR S PSCT=1
  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)))
  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)))
  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)))
  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_"^^"
  1. S PSCT=PSCT+2,PRCSAR(PSCT)="ARE IN TRANSACTION "_PRCHSX_"." D SENDIT2^PRCSEB1
  1. 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)=""
  1. 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
  1. 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
  1. S DIC="^PRC(443,",DIC(0)="L",DLAYGO=443,X=PRCHSX D ^DIC K DIC,DLAYGO
  1. ;PRC*5.1*186
  1. I PRCHSY=+Y D
  1. . S PRCHHDA=DA
  1. . D:$P(PRCHSY(0),U,3)]"" WS
  1. . S ^PRC(443,PRCHSY,0)=PRCHSY(0)
  1. . S DIK="^PRC(443,",DA=PRCHSY D IX^DIK K DIK
  1. . S DA=PRCHHDA K PRCHHDA
  1. Q:$D(PRCHG)
  1. G ^PRCHSP1
  1. ;
  1. OT S %X="^PRCS(410,PRCHS,""IT"",PRCHX,",%Y="^PRCS(410,PRCHSY,""IT"",PRCHJ," D %XY^%RCR
  1. S $P(^PRCS(410,PRCHS,"IT",PRCHX,0),U,7)=0,Y=$E($P(^(0),U,4),1,30)
  1. K ^PRCS(410,PRCHS,"IT","AB",PRCHK) S $P(^PRCS(410,PRCHS,"IT",PRCHX,0),U,10)=PRCHPO
  1. 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
  1. ;MOVE DELIVERY SCHEDULE (IF ANY) TO NEW ITEM
  1. D ^PRCSUT41
  1. ;IF ORDERED BY INVENTORY SYSTEM, MOVE ORDER DATA FOR NEW REQUEST TO INVENTORY FILE
  1. 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)
  1. Q
  1. ;
  1. 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
  1. Q
  1. ;
  1. TRY ;MAKE MULTIPLE TRIES TO GET A TRANSACTION NUMBER (IN CASE FILE IS LOCKED BY ANOTHER USER).
  1. S:'$D(PRCHTRY) PRCHTRY=0 S PRCHTRY=PRCHTRY+1 Q
  1. ;
  1. 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
  1. Q