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