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

PRCHSP1.m

Go to the documentation of this file.
  1. PRCHSP1 ;WOIFO/TKW,RHD/DL-TRANSFER 2237 TO PO ; 6/8/99 11:01am
  1. V ;;5.1;IFCAP;**81**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ; Entered from 2^PRCHNPO3.
  1. ; Entered from ^PRCHSP.
  1. ;
  1. ; First lets check if any 2237 entries have Item Master File
  1. ; pointers.
  1. ; Next lets see if any of the IMF records do not have the P.O.
  1. ; record Vendor.
  1. ; Last lets a. tell user of Vendor difference and
  1. ; b. find out if user wants to add Vender to IMF records.
  1. ; If YES, proceed with transferring 2237 Items to P.O.
  1. ; If NO, go back and see if user wants to add any other 2237
  1. ; records to this P.O.
  1. ;
  1. CHECK ;
  1. S (PRCHX,FLG)=0
  1. K DIRUT
  1. S PRCHCV=$P($G(^PRC(442,PRCHPO,1)),U,1)
  1. F S PRCHX=$O(^PRCS(410,PRCHSY,"IT",PRCHX)) Q:PRCHX=""!(PRCHX'>0) D Q:FLG>0!($D(DIRUT))
  1. . S N0=$G(^PRCS(410,PRCHSY,"IT",PRCHX,0))
  1. . S IMF=+$P(N0,U,5)
  1. . Q:IMF'>0
  1. . I $D(^PRC(441,IMF,2,PRCHCV,0)) Q
  1. . S DIR("A",1)="This 2237 entry will update some ITEM MASTER FILE records"
  1. . S DIR("A",2)="with a new vendor, "_$P(^PRC(440,PRCHCV,0),U)_"."
  1. . S DIR("A",3)=" "
  1. . S DIR("A")="Do you want to do this"
  1. . S DIR("B")="NO"
  1. . S DIR(0)="Y"
  1. . D ^DIR
  1. . K DIR
  1. . Q:$D(DIRUT)
  1. . S:Y=1 FLG=1 ; YES
  1. . S:Y=0 FLG=2 ; NO
  1. . Q
  1. ;
  1. I FLG=2!($D(DIRUT)) S PRCHSY=-2 K DIRUT Q
  1. K DIRUT
  1. ;
  1. ;Moves 2237,PRCHSY, into PO,PRCHPO
  1. ;
  1. 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
  1. S PRCHJ=J,PRCHK=K F PRCHJ=PRCHJ+1:1 S PRCHX=$O(^PRCS(410,PRCHSY,"IT",PRCHX)) Q:PRCHX=""!(PRCHX'>0) D
  1. .S PRCHK=PRCHK+1,PRCHSN=^PRCS(410,PRCHSY,"IT",PRCHX,0) D IT
  1. .K ^PRCS(410,PRCHSY,"IT","AB",PRCHX)
  1. .S $P(^PRCS(410,PRCHSY,"IT",PRCHX,0),U,10)=PRCHPO
  1. .Q
  1. S PRCHJ=PRCHJ-1,^PRC(442,PRCHPO,2,0)="^442.01IA^"_PRCHK_U_PRCHJ
  1. ;
  1. 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)=""
  1. S Y=^PRCS(410,PRCHSY,3),X=$G(^PRC(420,PRC("SITE"),1,+Y,0))
  1. 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)=""
  1. 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)
  1. I '$D(PRCHNRQ) S:$D(^PRCS(410,PRCHSY,9)) $P(^PRC(442,PRCHPO,0),U,13)=$P(^PRCS(410,PRCHSY,9),U,4)
  1. S:$D(^PRCS(410,PRCHSY,9)) $P(^PRC(442,PRCHPO,1),U,11)=$P(^PRCS(410,PRCHSY,9),U,1)
  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
  1. 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
  1. K ^PRCS(410,PRCHSY,"IT","AB"),T,PRCHSN
  1. S X=^PRC(442,PRCHPO,0),X1=$P(^(1),U,15)
  1. S PRC("FY")=$E(100+$E(X1,2,3)+$E(X1,4),2,3)
  1. I '$D(PRC("BBFY")) S PRC("BBFY")=$$BBFY^PRCSUT(+$P(X,U),PRC("FY"),+$P(X,U,3))
  1. S PRC("BBFY")=PRC("BBFY")-1700_"0000"
  1. S $P(^PRC(442,PRCHPO,23),U,2)=PRC("BBFY")
  1. Q
  1. ;
  1. IT ; CALLED FROM CHECK+25^PRCHSP1 (THIS ROUTINE). CALLED FOR EACH
  1. ; LINE ITEM TO COPY 2237 LINE ITEM INTO P.O.
  1. ;
  1. 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)=""
  1. 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
  1. ; PRC*5.1*81 move DM DOC ID to new 2237
  1. 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
  1. ;
  1. D MDEL
  1. I $D(^PRC(441,+$P(PRCHSN,U,5),0)) G CRD
  1. S %X="^PRCS(410,PRCHSY,""IT"",PRCHX,1,",%Y="^PRC(442,PRCHPO,2,PRCHK,1," D %XY^%RCR
  1. Q
  1. ;
  1. CRD N DA
  1. S PRCHCCP=$P($P(^PRCS(410,PRCHSY,3),U,1)," ",1)
  1. S PRCHCI=+$P(PRCHSN,U,5)
  1. S PRCHCV=$S($P(^PRC(442,PRCHPO,1),U,1)]"":+$P(^(1),U,1),1:0)
  1. S PRCHCPD=+$P(^PRC(442,PRCHPO,1),U,15)
  1. S PRCHCPO=PRCHPO
  1. S:$P(^PRC(442,PRCHPO,0),U,3)]"" PRCHCCP=$P($P(^(0),U,3)," ",1)
  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)="-"
  1. 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
  1. . ;
  1. . ; Suggested list of variables to New to make DIE and maybe DIC
  1. . ; recursive.
  1. . ;
  1. . N DIC,DIE,DO,DA,DR,DD,DL,DP,I,J,X,DC,DE,D,D1,D2,D3,D4,D5,D6,DI
  1. . N DH,DIA,DICR,DIK,DLAYGO,DM,DQ,DU,DW,DIEL,DOV,DIOV,DIEC,DB,DV
  1. . N DK,DIFLD,DIADD,D0,DG
  1. . S DIC="^PRC(441,PRCHCI,2,"
  1. . S DIC(0)="LZ"
  1. . S DLAYGO=441
  1. . S DA(1)=PRCHCI
  1. . S (DA,X)=PRCHCV
  1. . D ^DIC
  1. . S DIE=DIC
  1. . S DR="1;1.5;2;3;4;1.6;10"
  1. . S DIE("NO^")=""
  1. . D ^DIE
  1. . K DIC,DIE("NO^")
  1. . S ^PRC(442,PRCHPO,2,"AE",PRCHCI,PRCHK)=""
  1. . S DA(1)=PRCHPO
  1. . S DA=PRCHK
  1. . D EN3^PRCHCRD
  1. . S DA=PRCHPO
  1. . K DA(1)
  1. . Q
  1. ;
  1. S (DA(1),PRCHCPO)=PRCHPO
  1. S DA=PRCHK
  1. S ^PRC(442,PRCHPO,2,"AE",PRCHCI,DA)=""
  1. D EN3^PRCHCRD
  1. ;
  1. CRDQ K PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCPD,DA
  1. Q
  1. ;
  1. MDEL ; MOVE DELIVERY SCHEDULE INFO FROM 2237 TO P.O. FOR ONE LINE ITEM
  1. ; ENTRY. MDEL WILL BE CALLED FOR EACH LINE ITEM.
  1. ;
  1. ; CALLED FROM IT+2^PRCHSP1 (THIS ROUTINE).
  1. ;
  1. ; PRCHSY=410 INTERNAL RECORD NUMBER
  1. ; PRCHX=410 ITEM MULTIPLE INTERNAL RECORD NUMBER
  1. ; PRCHPO=442 INTERNAL RECORD NUMBER
  1. ; PRCHK=442 ITEM MULTIPLE INTERNAL RECORD NUMBER
  1. ;
  1. NEW DIC,DR
  1. K ^TMP("PRCHSP1",$J)
  1. S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1)
  1. S PRCHITM=$P(^PRC(442,PRCHPO,2,PRCHK,0),U,1)
  1. W "."
  1. S PRCHZ1=0
  1. D RD
  1. G:'$D(^TMP("PRCHSP1",$J)) Q
  1. S PRCHZ1=""
  1. 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
  1. ;
  1. Q K ^TMP("PRCHSP1",$J),PRCHITM,PRCHZ,PRCHZ0,PRCHZ1,PRCHZ2,PRCHZ3
  1. Q
  1. ;
  1. RD S PRCHZ1=$O(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1))
  1. ;
  1. ; PRCHZ1=DELIVERY SCHEDULE INTERNAL RECORD MULTIPLE NUMBER
  1. ;
  1. Q:PRCHZ1'>0
  1. S PRCHZ0=$G(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1,0))
  1. ;
  1. ; PRCHZ0 PIECE 2=DELIVERY REFERENCE NUMBER POINTER
  1. ;
  1. G:+$P(PRCHZ0,U,2)'>0 RD
  1. G:'$D(^PRCS(410.6,+$P(PRCHZ0,U,2),0)) RD
  1. S PRCHZ2=^PRCS(410.6,+$P(PRCHZ0,U,2),0)
  1. ;
  1. ; PRCHZ2 PIECE 4=QTY TO BE DELIVERED
  1. ;
  1. G:'$P(PRCHZ2,U,4) RD
  1. ;
  1. ; PRCHZ2 PIECE 3=LOCATION (OF FILE 410.8 RECORD)
  1. ;
  1. G:+$P(PRCHZ2,U,3)'>0 RD
  1. S X=$P($G(^PRCS(410.8,+$P(PRCHZ2,U,3),0)),U,1)
  1. S:X="" X=" "
  1. ;
  1. ; PRCHZ2 PIECE 2=DELIVERY DATE
  1. ;
  1. S ^TMP("PRCHSP1",$J,+$P(PRCHZ2,U,2),X,PRCHZ1)=PRCHZ2
  1. G RD
  1. ;
  1. ADDS S PRCHZ3=$O(^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2,PRCHZ3))
  1. Q:'PRCHZ3
  1. S PRCHZ=^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2,PRCHZ3)
  1. S DIC="^PRC(442.8,"
  1. S DLAYGO=442.8
  1. S DIC(0)="L"
  1. S DIC("DR")="1///"_PRCHITM_";2///"_$P(PRCHZ,U,2)_";3////"_$P(PRCHZ,U,3)_";4///"_$P(PRCHZ,U,4),X=""""_PRCHPONO_""""
  1. D ^DIC
  1. G ADDS