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