PRCHSP1 ;WOIFO/TKW,RHD/DL-TRANSFER 2237 TO PO ; 6/8/99 11:01am
V ;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Entered from 2^PRCHNPO3.
; Entered from ^PRCHSP.
;
; First lets check if any 2237 entries have Item Master File
; pointers.
; Next lets see if any of the IMF records do not have the P.O.
; record Vendor.
; Last lets a. tell user of Vendor difference and
; b. find out if user wants to add Vender to IMF records.
; If YES, proceed with transferring 2237 Items to P.O.
; If NO, go back and see if user wants to add any other 2237
; records to this P.O.
;
CHECK ;
S (PRCHX,FLG)=0
K DIRUT
S PRCHCV=$P($G(^PRC(442,PRCHPO,1)),U,1)
F S PRCHX=$O(^PRCS(410,PRCHSY,"IT",PRCHX)) Q:PRCHX=""!(PRCHX'>0) D Q:FLG>0!($D(DIRUT))
. S N0=$G(^PRCS(410,PRCHSY,"IT",PRCHX,0))
. S IMF=+$P(N0,U,5)
. Q:IMF'>0
. I $D(^PRC(441,IMF,2,PRCHCV,0)) Q
. S DIR("A",1)="This 2237 entry will update some ITEM MASTER FILE records"
. S DIR("A",2)="with a new vendor, "_$P(^PRC(440,PRCHCV,0),U)_"."
. S DIR("A",3)=" "
. S DIR("A")="Do you want to do this"
. S DIR("B")="NO"
. S DIR(0)="Y"
. D ^DIR
. K DIR
. Q:$D(DIRUT)
. S:Y=1 FLG=1 ; YES
. S:Y=0 FLG=2 ; NO
. Q
;
I FLG=2!($D(DIRUT)) S PRCHSY=-2 K DIRUT Q
K DIRUT
;
;Moves 2237,PRCHSY, into PO,PRCHPO
;
S (J,K,PRCHX)=0 I $D(^PRC(442,PRCHPO,2,0)) S I=0 F S I=$O(^PRC(442,PRCHPO,2,I)) Q:I=""!(I'>0) S J=J+1,K=I
S PRCHJ=J,PRCHK=K F PRCHJ=PRCHJ+1:1 S PRCHX=$O(^PRCS(410,PRCHSY,"IT",PRCHX)) Q:PRCHX=""!(PRCHX'>0) D
.S PRCHK=PRCHK+1,PRCHSN=^PRCS(410,PRCHSY,"IT",PRCHX,0) D IT
.K ^PRCS(410,PRCHSY,"IT","AB",PRCHX)
.S $P(^PRCS(410,PRCHSY,"IT",PRCHX,0),U,10)=PRCHPO
.Q
S PRCHJ=PRCHJ-1,^PRC(442,PRCHPO,2,0)="^442.01IA^"_PRCHK_U_PRCHJ
;
MV1 S X=$P($P(^PRC(442,PRCHPO,0),U,1),"-",2),$P(^PRCS(410,PRCHSY,4),U,5)=X,$P(^(10),U,3)=PRCHPO,^PRCS(410,"D",X,PRCHSY)=""
S Y=^PRCS(410,PRCHSY,3),X=$G(^PRC(420,PRC("SITE"),1,+Y,0))
I $P(^PRC(442,PRCHPO,0),U,3)="" S $P(^(0),U,3,5)=$P(Y,U,1,2)_U_+$P(Y,U,3),$P(^(0),U,19)=$P(X,U,12),$P(^(17),U,1)=$E($P(X,U,18),1,3),^PRC(442,"E",$P($P(Y,U,1)," ",1),PRCHPO)=""
S $P(^PRC(442,PRCHPO,0),U,14)=PRCHJ,$P(^(1),U,2)=$P(Y,U,5) S:$P(^(1),U,9)="" $P(^PRC(442,PRCHPO,1),U,9)=$P(^PRCS(410,PRCHSY,1),U,3)
I '$D(PRCHNRQ) S:$D(^PRCS(410,PRCHSY,9)) $P(^PRC(442,PRCHPO,0),U,13)=$P(^PRCS(410,PRCHSY,9),U,4)
S:$D(^PRCS(410,PRCHSY,9)) $P(^PRC(442,PRCHPO,1),U,11)=$P(^PRCS(410,PRCHSY,9),U,1)
I $D(^PRC(443,PRCHSY,0)) S $P(^PRC(442,PRCHPO,1),U,18)=$P(^(0),U,12),DA=PRCHSY,DIK="^PRC(443," D ^DIK K DIK
I PRCHS,$D(^PRC(443,PRCHS,0)),'$D(^PRCS(410,PRCHS,"IT","AB")) S $P(^PRCS(410,PRCHS,0),U,12)="O" S DA=PRCHS,DIK="^PRC(443," D ^DIK K DIK,PRCHRBST
K ^PRCS(410,PRCHSY,"IT","AB"),T,PRCHSN
S X=^PRC(442,PRCHPO,0),X1=$P(^(1),U,15)
S PRC("FY")=$E(100+$E(X1,2,3)+$E(X1,4),2,3)
I '$D(PRC("BBFY")) S PRC("BBFY")=$$BBFY^PRCSUT(+$P(X,U),PRC("FY"),+$P(X,U,3))
S PRC("BBFY")=PRC("BBFY")-1700_"0000"
S $P(^PRC(442,PRCHPO,23),U,2)=PRC("BBFY")
Q
;
IT ; CALLED FROM CHECK+25^PRCHSP1 (THIS ROUTINE). CALLED FOR EACH
; LINE ITEM TO COPY 2237 LINE ITEM INTO P.O.
;
S ^PRC(442,PRCHPO,2,PRCHK,0)=PRCHJ_U_$P(PRCHSN,U,2,99),$P(^(0),U,10)=PRCHSY,$P(^(2),U,13)=PRCHX,^PRC(442,PRCHPO,2,"B",PRCHJ,PRCHK)="",^PRC(442,PRCHPO,2,"C",PRCHJ,PRCHK)=""
S X=$P(PRCHSN,U,6) I X?4N1"-"2N1"-"3N1"-"4N.UN S $P(^PRC(442,PRCHPO,2,PRCHK,0),U,13)=X,$P(^(0),U,6)="" S:$D(^PRC(441.2,+X,0)) $P(^PRC(442,PRCHPO,2,PRCHK,2),U,3)=+X
; PRC*5.1*81 move DM DOC ID to new 2237
S:$D(^PRCS(410,PRCHSY,"IT",PRCHX,4))#10=1 $P(^PRC(442,PRCHPO,2,PRCHK,2),U,15)=$P(^PRCS(410,PRCHSY,"IT",PRCHX,4),"^",1) ; DM DOC ID
;
D MDEL
I $D(^PRC(441,+$P(PRCHSN,U,5),0)) G CRD
S %X="^PRCS(410,PRCHSY,""IT"",PRCHX,1,",%Y="^PRC(442,PRCHPO,2,PRCHK,1," D %XY^%RCR
Q
;
CRD N DA
S PRCHCCP=$P($P(^PRCS(410,PRCHSY,3),U,1)," ",1)
S PRCHCI=+$P(PRCHSN,U,5)
S PRCHCV=$S($P(^PRC(442,PRCHPO,1),U,1)]"":+$P(^(1),U,1),1:0)
S PRCHCPD=+$P(^PRC(442,PRCHPO,1),U,15)
S PRCHCPO=PRCHPO
S:$P(^PRC(442,PRCHPO,0),U,3)]"" PRCHCCP=$P($P(^(0),U,3)," ",1)
I $D(^PRCP(445,+$P(^PRCS(410,PRCHSY,0),U,6),1,PRCHCI,0)) S X=^(0),$P(^PRC(442,PRCHPO,2,PRCHK,4),U,2)=$P(X,U,9),$P(^(4),U,4,5)=$P(X,U,18)_"^"_$P(X,U,13) S:$P(X,U,18)=1 $P(^(4),U,7)="-"
I '$D(^PRC(441,PRCHCI,2,PRCHCV,0)) W !,"For item, ",$P(^PRC(441,PRCHCI,0),U,2),!?5,"Enter the following information: " D G CRDQ
. ;
. ; Suggested list of variables to New to make DIE and maybe DIC
. ; recursive.
. ;
. N DIC,DIE,DO,DA,DR,DD,DL,DP,I,J,X,DC,DE,D,D1,D2,D3,D4,D5,D6,DI
. N DH,DIA,DICR,DIK,DLAYGO,DM,DQ,DU,DW,DIEL,DOV,DIOV,DIEC,DB,DV
. N DK,DIFLD,DIADD,D0,DG
. S DIC="^PRC(441,PRCHCI,2,"
. S DIC(0)="LZ"
. S DLAYGO=441
. S DA(1)=PRCHCI
. S (DA,X)=PRCHCV
. D ^DIC
. S DIE=DIC
. S DR="1;1.5;2;3;4;1.6;10"
. S DIE("NO^")=""
. D ^DIE
. K DIC,DIE("NO^")
. S ^PRC(442,PRCHPO,2,"AE",PRCHCI,PRCHK)=""
. S DA(1)=PRCHPO
. S DA=PRCHK
. D EN3^PRCHCRD
. S DA=PRCHPO
. K DA(1)
. Q
;
S (DA(1),PRCHCPO)=PRCHPO
S DA=PRCHK
S ^PRC(442,PRCHPO,2,"AE",PRCHCI,DA)=""
D EN3^PRCHCRD
;
CRDQ K PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCPD,DA
Q
;
MDEL ; MOVE DELIVERY SCHEDULE INFO FROM 2237 TO P.O. FOR ONE LINE ITEM
; ENTRY. MDEL WILL BE CALLED FOR EACH LINE ITEM.
;
; CALLED FROM IT+2^PRCHSP1 (THIS ROUTINE).
;
; PRCHSY=410 INTERNAL RECORD NUMBER
; PRCHX=410 ITEM MULTIPLE INTERNAL RECORD NUMBER
; PRCHPO=442 INTERNAL RECORD NUMBER
; PRCHK=442 ITEM MULTIPLE INTERNAL RECORD NUMBER
;
NEW DIC,DR
K ^TMP("PRCHSP1",$J)
S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1)
S PRCHITM=$P(^PRC(442,PRCHPO,2,PRCHK,0),U,1)
W "."
S PRCHZ1=0
D RD
G:'$D(^TMP("PRCHSP1",$J)) Q
S PRCHZ1=""
F S PRCHZ1=$O(^TMP("PRCHSP1",$J,PRCHZ1)) Q:PRCHZ1="" S PRCHZ2="" F S PRCHZ2=$O(^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2)) Q:PRCHZ2="" S PRCHZ3="" D ADDS
;
Q K ^TMP("PRCHSP1",$J),PRCHITM,PRCHZ,PRCHZ0,PRCHZ1,PRCHZ2,PRCHZ3
Q
;
RD S PRCHZ1=$O(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1))
;
; PRCHZ1=DELIVERY SCHEDULE INTERNAL RECORD MULTIPLE NUMBER
;
Q:PRCHZ1'>0
S PRCHZ0=$G(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1,0))
;
; PRCHZ0 PIECE 2=DELIVERY REFERENCE NUMBER POINTER
;
G:+$P(PRCHZ0,U,2)'>0 RD
G:'$D(^PRCS(410.6,+$P(PRCHZ0,U,2),0)) RD
S PRCHZ2=^PRCS(410.6,+$P(PRCHZ0,U,2),0)
;
; PRCHZ2 PIECE 4=QTY TO BE DELIVERED
;
G:'$P(PRCHZ2,U,4) RD
;
; PRCHZ2 PIECE 3=LOCATION (OF FILE 410.8 RECORD)
;
G:+$P(PRCHZ2,U,3)'>0 RD
S X=$P($G(^PRCS(410.8,+$P(PRCHZ2,U,3),0)),U,1)
S:X="" X=" "
;
; PRCHZ2 PIECE 2=DELIVERY DATE
;
S ^TMP("PRCHSP1",$J,+$P(PRCHZ2,U,2),X,PRCHZ1)=PRCHZ2
G RD
;
ADDS S PRCHZ3=$O(^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2,PRCHZ3))
Q:'PRCHZ3
S PRCHZ=^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2,PRCHZ3)
S DIC="^PRC(442.8,"
S DLAYGO=442.8
S DIC(0)="L"
S DIC("DR")="1///"_PRCHITM_";2///"_$P(PRCHZ,U,2)_";3////"_$P(PRCHZ,U,3)_";4///"_$P(PRCHZ,U,4),X=""""_PRCHPONO_""""
D ^DIC
G ADDS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHSP1 6997 printed Oct 16, 2024@18:11:29 Page 2
PRCHSP1 ;WOIFO/TKW,RHD/DL-TRANSFER 2237 TO PO ; 6/8/99 11:01am
V ;;5.1;IFCAP;**81**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ; Entered from 2^PRCHNPO3.
+4 ; Entered from ^PRCHSP.
+5 ;
+6 ; First lets check if any 2237 entries have Item Master File
+7 ; pointers.
+8 ; Next lets see if any of the IMF records do not have the P.O.
+9 ; record Vendor.
+10 ; Last lets a. tell user of Vendor difference and
+11 ; b. find out if user wants to add Vender to IMF records.
+12 ; If YES, proceed with transferring 2237 Items to P.O.
+13 ; If NO, go back and see if user wants to add any other 2237
+14 ; records to this P.O.
+15 ;
CHECK ;
+1 SET (PRCHX,FLG)=0
+2 KILL DIRUT
+3 SET PRCHCV=$PIECE($GET(^PRC(442,PRCHPO,1)),U,1)
+4 FOR
SET PRCHX=$ORDER(^PRCS(410,PRCHSY,"IT",PRCHX))
if PRCHX=""!(PRCHX'>0)
QUIT
Begin DoDot:1
+5 SET N0=$GET(^PRCS(410,PRCHSY,"IT",PRCHX,0))
+6 SET IMF=+$PIECE(N0,U,5)
+7 if IMF'>0
QUIT
+8 IF $DATA(^PRC(441,IMF,2,PRCHCV,0))
QUIT
+9 SET DIR("A",1)="This 2237 entry will update some ITEM MASTER FILE records"
+10 SET DIR("A",2)="with a new vendor, "_$PIECE(^PRC(440,PRCHCV,0),U)_"."
+11 SET DIR("A",3)=" "
+12 SET DIR("A")="Do you want to do this"
+13 SET DIR("B")="NO"
+14 SET DIR(0)="Y"
+15 DO ^DIR
+16 KILL DIR
+17 if $DATA(DIRUT)
QUIT
+18 ; YES
if Y=1
SET FLG=1
+19 ; NO
if Y=0
SET FLG=2
+20 QUIT
End DoDot:1
if FLG>0!($DATA(DIRUT))
QUIT
+21 ;
+22 IF FLG=2!($DATA(DIRUT))
SET PRCHSY=-2
KILL DIRUT
QUIT
+23 KILL DIRUT
+24 ;
+25 ;Moves 2237,PRCHSY, into PO,PRCHPO
+26 ;
+27 SET (J,K,PRCHX)=0
IF $DATA(^PRC(442,PRCHPO,2,0))
SET I=0
FOR
SET I=$ORDER(^PRC(442,PRCHPO,2,I))
if I=""!(I'>0)
QUIT
SET J=J+1
SET K=I
+28 SET PRCHJ=J
SET PRCHK=K
FOR PRCHJ=PRCHJ+1:1
SET PRCHX=$ORDER(^PRCS(410,PRCHSY,"IT",PRCHX))
if PRCHX=""!(PRCHX'>0)
QUIT
Begin DoDot:1
+29 SET PRCHK=PRCHK+1
SET PRCHSN=^PRCS(410,PRCHSY,"IT",PRCHX,0)
DO IT
+30 KILL ^PRCS(410,PRCHSY,"IT","AB",PRCHX)
+31 SET $PIECE(^PRCS(410,PRCHSY,"IT",PRCHX,0),U,10)=PRCHPO
+32 QUIT
End DoDot:1
+33 SET PRCHJ=PRCHJ-1
SET ^PRC(442,PRCHPO,2,0)="^442.01IA^"_PRCHK_U_PRCHJ
+34 ;
MV1 SET X=$PIECE($PIECE(^PRC(442,PRCHPO,0),U,1),"-",2)
SET $PIECE(^PRCS(410,PRCHSY,4),U,5)=X
SET $PIECE(^(10),U,3)=PRCHPO
SET ^PRCS(410,"D",X,PRCHSY)=""
+1 SET Y=^PRCS(410,PRCHSY,3)
SET X=$GET(^PRC(420,PRC("SITE"),1,+Y,0))
+2 IF $PIECE(^PRC(442,PRCHPO,0),U,3)=""
SET $PIECE(^(0),U,3,5)=$PIECE(Y,U,1,2)_U_+$PIECE(Y,U,3)
SET $PIECE(^(0),U,19)=$PIECE(X,U,12)
SET $PIECE(^(17),U,1)=$EXTRACT($PIECE(X,U,18),1,3)
SET ^PRC(442,"E",$PIECE($PIECE(Y,U,1)," ",1),PRCHPO)=""
+3 SET $PIECE(^PRC(442,PRCHPO,0),U,14)=PRCHJ
SET $PIECE(^(1),U,2)=$PIECE(Y,U,5)
if $PIECE(^(1),U,9)=""
SET $PIECE(^PRC(442,PRCHPO,1),U,9)=$PIECE(^PRCS(410,PRCHSY,1),U,3)
+4 IF '$DATA(PRCHNRQ)
if $DATA(^PRCS(410,PRCHSY,9))
SET $PIECE(^PRC(442,PRCHPO,0),U,13)=$PIECE(^PRCS(410,PRCHSY,9),U,4)
+5 if $DATA(^PRCS(410,PRCHSY,9))
SET $PIECE(^PRC(442,PRCHPO,1),U,11)=$PIECE(^PRCS(410,PRCHSY,9),U,1)
+6 IF $DATA(^PRC(443,PRCHSY,0))
SET $PIECE(^PRC(442,PRCHPO,1),U,18)=$PIECE(^(0),U,12)
SET DA=PRCHSY
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK
+7 IF PRCHS
IF $DATA(^PRC(443,PRCHS,0))
IF '$DATA(^PRCS(410,PRCHS,"IT","AB"))
SET $PIECE(^PRCS(410,PRCHS,0),U,12)="O"
SET DA=PRCHS
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK,PRCHRBST
+8 KILL ^PRCS(410,PRCHSY,"IT","AB"),T,PRCHSN
+9 SET X=^PRC(442,PRCHPO,0)
SET X1=$PIECE(^(1),U,15)
+10 SET PRC("FY")=$EXTRACT(100+$EXTRACT(X1,2,3)+$EXTRACT(X1,4),2,3)
+11 IF '$DATA(PRC("BBFY"))
SET PRC("BBFY")=$$BBFY^PRCSUT(+$PIECE(X,U),PRC("FY"),+$PIECE(X,U,3))
+12 SET PRC("BBFY")=PRC("BBFY")-1700_"0000"
+13 SET $PIECE(^PRC(442,PRCHPO,23),U,2)=PRC("BBFY")
+14 QUIT
+15 ;
IT ; CALLED FROM CHECK+25^PRCHSP1 (THIS ROUTINE). CALLED FOR EACH
+1 ; LINE ITEM TO COPY 2237 LINE ITEM INTO P.O.
+2 ;
+3 SET ^PRC(442,PRCHPO,2,PRCHK,0)=PRCHJ_U_$PIECE(PRCHSN,U,2,99)
SET $PIECE(^(0),U,10)=PRCHSY
SET $PIECE(^(2),U,13)=PRCHX
SET ^PRC(442,PRCHPO,2,"B",PRCHJ,PRCHK)=""
SET ^PRC(442,PRCHPO,2,"C",PRCHJ,PRCHK)=""
+4 SET X=$PIECE(PRCHSN,U,6)
IF X?4N1"-"2N1"-"3N1"-"4N.UN
SET $PIECE(^PRC(442,PRCHPO,2,PRCHK,0),U,13)=X
SET $PIECE(^(0),U,6)=""
if $DATA(^PRC(441.2,+X,0))
SET $PIECE(^PRC(442,PRCHPO,2,PRCHK,2),U,3)=+X
+5 ; PRC*5.1*81 move DM DOC ID to new 2237
+6 ; DM DOC ID
if $DATA(^PRCS(410,PRCHSY,"IT",PRCHX,4))#10=1
SET $PIECE(^PRC(442,PRCHPO,2,PRCHK,2),U,15)=$PIECE(^PRCS(410,PRCHSY,"IT",PRCHX,4),"^",1)
+7 ;
+8 DO MDEL
+9 IF $DATA(^PRC(441,+$PIECE(PRCHSN,U,5),0))
GOTO CRD
+10 SET %X="^PRCS(410,PRCHSY,""IT"",PRCHX,1,"
SET %Y="^PRC(442,PRCHPO,2,PRCHK,1,"
DO %XY^%RCR
+11 QUIT
+12 ;
CRD NEW DA
+1 SET PRCHCCP=$PIECE($PIECE(^PRCS(410,PRCHSY,3),U,1)," ",1)
+2 SET PRCHCI=+$PIECE(PRCHSN,U,5)
+3 SET PRCHCV=$SELECT($PIECE(^PRC(442,PRCHPO,1),U,1)]"":+$PIECE(^(1),U,1),1:0)
+4 SET PRCHCPD=+$PIECE(^PRC(442,PRCHPO,1),U,15)
+5 SET PRCHCPO=PRCHPO
+6 if $PIECE(^PRC(442,PRCHPO,0),U,3)]""
SET PRCHCCP=$PIECE($PIECE(^(0),U,3)," ",1)
+7 IF $DATA(^PRCP(445,+$PIECE(^PRCS(410,PRCHSY,0),U,6),1,PRCHCI,0))
SET X=^(0)
SET $PIECE(^PRC(442,PRCHPO,2,PRCHK,4),U,2)=$PIECE(X,U,9)
SET $PIECE(^(4),U,4,5)=$PIECE(X,U,18)_"^"_$PIECE(X,U,13)
if $PIECE(X,U,18)=1
SET $PIECE(^(4),U,7)="-"
+8 IF '$DATA(^PRC(441,PRCHCI,2,PRCHCV,0))
WRITE !,"For item, ",$PIECE(^PRC(441,PRCHCI,0),U,2),!?5,"Enter the following information: "
Begin DoDot:1
+9 ;
+10 ; Suggested list of variables to New to make DIE and maybe DIC
+11 ; recursive.
+12 ;
+13 NEW DIC,DIE,DO,DA,DR,DD,DL,DP,I,J,X,DC,DE,D,D1,D2,D3,D4,D5,D6,DI
+14 NEW DH,DIA,DICR,DIK,DLAYGO,DM,DQ,DU,DW,DIEL,DOV,DIOV,DIEC,DB,DV
+15 NEW DK,DIFLD,DIADD,D0,DG
+16 SET DIC="^PRC(441,PRCHCI,2,"
+17 SET DIC(0)="LZ"
+18 SET DLAYGO=441
+19 SET DA(1)=PRCHCI
+20 SET (DA,X)=PRCHCV
+21 DO ^DIC
+22 SET DIE=DIC
+23 SET DR="1;1.5;2;3;4;1.6;10"
+24 SET DIE("NO^")=""
+25 DO ^DIE
+26 KILL DIC,DIE("NO^")
+27 SET ^PRC(442,PRCHPO,2,"AE",PRCHCI,PRCHK)=""
+28 SET DA(1)=PRCHPO
+29 SET DA=PRCHK
+30 DO EN3^PRCHCRD
+31 SET DA=PRCHPO
+32 KILL DA(1)
+33 QUIT
End DoDot:1
GOTO CRDQ
+34 ;
+35 SET (DA(1),PRCHCPO)=PRCHPO
+36 SET DA=PRCHK
+37 SET ^PRC(442,PRCHPO,2,"AE",PRCHCI,DA)=""
+38 DO EN3^PRCHCRD
+39 ;
CRDQ KILL PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCPD,DA
+1 QUIT
+2 ;
MDEL ; MOVE DELIVERY SCHEDULE INFO FROM 2237 TO P.O. FOR ONE LINE ITEM
+1 ; ENTRY. MDEL WILL BE CALLED FOR EACH LINE ITEM.
+2 ;
+3 ; CALLED FROM IT+2^PRCHSP1 (THIS ROUTINE).
+4 ;
+5 ; PRCHSY=410 INTERNAL RECORD NUMBER
+6 ; PRCHX=410 ITEM MULTIPLE INTERNAL RECORD NUMBER
+7 ; PRCHPO=442 INTERNAL RECORD NUMBER
+8 ; PRCHK=442 ITEM MULTIPLE INTERNAL RECORD NUMBER
+9 ;
+10 NEW DIC,DR
+11 KILL ^TMP("PRCHSP1",$JOB)
+12 SET PRCHPONO=$PIECE(^PRC(442,PRCHPO,0),U,1)
+13 SET PRCHITM=$PIECE(^PRC(442,PRCHPO,2,PRCHK,0),U,1)
+14 WRITE "."
+15 SET PRCHZ1=0
+16 DO RD
+17 if '$DATA(^TMP("PRCHSP1",$JOB))
GOTO Q
+18 SET PRCHZ1=""
+19 FOR
SET PRCHZ1=$ORDER(^TMP("PRCHSP1",$JOB,PRCHZ1))
if PRCHZ1=""
QUIT
SET PRCHZ2=""
FOR
SET PRCHZ2=$ORDER(^TMP("PRCHSP1",$JOB,PRCHZ1,PRCHZ2))
if PRCHZ2=""
QUIT
SET PRCHZ3=""
DO ADDS
+20 ;
Q KILL ^TMP("PRCHSP1",$JOB),PRCHITM,PRCHZ,PRCHZ0,PRCHZ1,PRCHZ2,PRCHZ3
+1 QUIT
+2 ;
RD SET PRCHZ1=$ORDER(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1))
+1 ;
+2 ; PRCHZ1=DELIVERY SCHEDULE INTERNAL RECORD MULTIPLE NUMBER
+3 ;
+4 if PRCHZ1'>0
QUIT
+5 SET PRCHZ0=$GET(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1,0))
+6 ;
+7 ; PRCHZ0 PIECE 2=DELIVERY REFERENCE NUMBER POINTER
+8 ;
+9 if +$PIECE(PRCHZ0,U,2)'>0
GOTO RD
+10 if '$DATA(^PRCS(410.6,+$PIECE(PRCHZ0,U,2),0))
GOTO RD
+11 SET PRCHZ2=^PRCS(410.6,+$PIECE(PRCHZ0,U,2),0)
+12 ;
+13 ; PRCHZ2 PIECE 4=QTY TO BE DELIVERED
+14 ;
+15 if '$PIECE(PRCHZ2,U,4)
GOTO RD
+16 ;
+17 ; PRCHZ2 PIECE 3=LOCATION (OF FILE 410.8 RECORD)
+18 ;
+19 if +$PIECE(PRCHZ2,U,3)'>0
GOTO RD
+20 SET X=$PIECE($GET(^PRCS(410.8,+$PIECE(PRCHZ2,U,3),0)),U,1)
+21 if X=""
SET X=" "
+22 ;
+23 ; PRCHZ2 PIECE 2=DELIVERY DATE
+24 ;
+25 SET ^TMP("PRCHSP1",$JOB,+$PIECE(PRCHZ2,U,2),X,PRCHZ1)=PRCHZ2
+26 GOTO RD
+27 ;
ADDS SET PRCHZ3=$ORDER(^TMP("PRCHSP1",$JOB,PRCHZ1,PRCHZ2,PRCHZ3))
+1 if 'PRCHZ3
QUIT
+2 SET PRCHZ=^TMP("PRCHSP1",$JOB,PRCHZ1,PRCHZ2,PRCHZ3)
+3 SET DIC="^PRC(442.8,"
+4 SET DLAYGO=442.8
+5 SET DIC(0)="L"
+6 SET DIC("DR")="1///"_PRCHITM_";2///"_$PIECE(PRCHZ,U,2)_";3////"_$PIECE(PRCHZ,U,3)_";4///"_$PIECE(PRCHZ,U,4)
SET X=""""_PRCHPONO_""""
+7 DO ^DIC
+8 GOTO ADDS
