- 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 Feb 18, 2025@23:37:06 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