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

PRCH442A.m

Go to the documentation of this file.
  1. PRCH442A ;WISC/KMB/CR/DXH/DGL-CREATE PURCHASE CARD ORDER FROM RIL ;4/13/00 1:32pm
  1. ;;5.1;IFCAP;**8,35,26,57,81,106**;Oct 20, 2000
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. SETUP ; create 442 entry
  1. D ENPO^PRCHUTL
  1. ;
  1. ; PRC*5.1*81 - If this is a DynaMed RIL, double dare users who try to exit before all items on the RIL are transferred to purchase card orders
  1. I '$D(DA),'PRCVDYN S OUTRIL=1 W !,"Unable to create 442 entry. Try later." Q
  1. I '$D(DA) D G SETUP:Y=0 S OUTRIL=1 Q
  1. . N DIR
  1. . S DIR(0)="Y",DIR("B")="NO"
  1. . S DIR("A",1)=" "
  1. . S DIR("A",2)="NOTE: This RIL Contains DynaMed Orders!!!"
  1. . S DIR("A",3)="-----------------------------------------"
  1. . S DIR("A",4)="You must enter a valid PURCHASE ORDER NUMBER to continue. If no valid"
  1. . S DIR("A",5)="PURCHASE ORDER is entered, all items remaining on the RIL will be deleted."
  1. . S DIR("A",6)=" "
  1. . S DIR("A")="Do you want to exit and delete the RIL?"
  1. . S DIR("?")="Enter 'NO' or <return> to go back to the PURCHASE ORDER prompt"
  1. . D ^DIR Q:Y=0
  1. . S DIR("A")="Are you sure that you want to cancel ALL DynaMed Orders on this RIL?"
  1. . D ^DIR
  1. ;
  1. I '$G(^PRCS(410.3,XDA,0)) D S OUTRIL=1 W !!,"Another user has deleted this RIL, Purchase Order will now be deleted.",!! Q
  1. . S DIK="^PRC(442,",DA=DA
  1. . D ^DIK
  1. N PRCHCPD,CP1
  1. S PDA=DA L +^PRC(442,PDA):15 Q:'$T
  1. S DIE="^PRC(442,",DR=".5////1"_";"_"1.4////"_APP D ^DIE ;LIT-0400-70331
  1. I $G(RLFLAG)'=1 S DR=".02///25"_";"_"48///P" D ^DIE
  1. I $G(RLFLAG)=1 S DR=".02///1"_";"_"47///Y"_";"_"48///D" D ^DIE
  1. S $P(^PRC(442,PDA,1),"^")=VENDOR,$P(^(0),"^",3)=FCP,$P(^(0),"^",5)=CCEN,$P(^(23),"^",7)=PRC("SST"),$P(^(23),"^",14)=VENDOR
  1. S DIE="^PRC(442,",DR=".03///"_SPEC_";"_".1////"_TDATE D ^DIE
  1. ;
  1. ; PRC*5.1*81
  1. I PRCVDYN S DR="7///"_PRCVDATE_";"_"54///Y" D ^DIE ; save earliest Need By Date in RIL for vendor in PC order delivery date, force 'Requested Receipt?' to Yes
  1. ;
  1. ;BUT-0701-21784 & WAS-0498-22000
  1. S CP1=$P($P(^PRCS(410.3,XDA,0),U),"-",4)
  1. S ^PRC(442,"E",CP1,PDA)=""
  1. ;
  1. S $P(^PRC(442,PDA,1),"^",10)=DUZ,^PRC(442,"D",$E(VENDOR,1,30),PDA)=""
  1. I NCOST'=0 F II=1:1:CNNT D SETIT
  1. I NCOST'=0 S ^PRC(442,PDA,2,0)="^442.01IA^"_CNNT_"^"_CNNT
  1. S EE($J,PDA)=""
  1. ;
  1. N NCST,NLP,NCNT,NQTY,NSUB
  1. LOOP S %=1 W !,"Edit request ",$P(^PRC(442,PDA,0),"^")
  1. D YN^DICN G:%=0 LOOP G:%=2 LQ
  1. S (PRCHPO,DA)=PDA,PRC("PER")=DUZ,X=1
  1. D ^PRCHNPO,LOOPA
  1. K PRC("PER"),X,PRCHPO
  1. LQ L -^PRC(442,PDA) Q
  1. ;
  1. LOOPA Q:$G(^PRC(442,PDA,2,0))="" S NCNT=$P($G(^PRC(442,PDA,2,0)),U,4) Q:NCNT="" S NSUB=0 F NLP=1:1:NCNT D
  1. .S NQTY=$P($G(^PRC(442,PDA,2,NLP,0)),U,2),NCST=$P($G(^PRC(442,PDA,2,NLP,0)),U,9),NSUB=NSUB+(NQTY*NCST)
  1. S CNNT=NCNT,NCOST=NSUB Q
  1. ;
  1. SETIT ;set item data on 442 record
  1. S ^PRC(442,PDA,2,II,0)=AA(II)
  1. I CNNT1'="" F J=1:1:CNNT1 S ^PRC(442,PDA,2,II,1,J,0)=$G(BB(II,J))
  1. S ^PRC(442,PDA,2,II,2)=CC(II)
  1. ;
  1. ; PRC*5.1*81
  1. I PRCVDYN D
  1. . N PRCV S PRCV=0
  1. . I $P(CC(II),"^",15)]"" S PRCV=$O(^PRCV(414.02,"B",$P(CC(II),"^",15),"")) ; get ien of DM DOC ID
  1. . I +PRCV=0 D Q ; if not in audit file update ^TMP to alert user
  1. . . S ^TMP($J,"PRCVHMSG",YDA,ITEM)=$P(CC(II),"^",15)_"^"_$P(^PRC(442,PDA,0),"^",1) Q ; update msg to user to show DM, DOC ID & PO#
  1. . S $P(^PRCV(414.02,PRCV,0),"^",11)=$P(^PRC(442,PDA,0),"^",1) ; SET PO Number into Audit file
  1. ;
  1. S ^PRC(442,PDA,2,II,1,0)="^^"_CNNT1_"^"_CNNT1_"^"_TDATE_"^"
  1. S ^PRC(442,PDA,2,"B",II,II)="",^PRC(442,PDA,2,"C",II,II)=""
  1. S ^PRC(442,PDA,2,"AE",ITEM,II)="" S:BOC'="" ^PRC(442,PDA,2,"AH",+BOC,II,II)="",^PRC(442,PDA,2,"D",+BOC,II)=""
  1. I $G(PRCSIP) D
  1. . N DIC,DIE,DA,DLAYGO
  1. . S DIC="^PRC(442,"_PDA_",2,"_II_",5,",DA(1)=II,DA(2)=PDA,X=PRCSIP
  1. . S DIC(0)="L",DIC("P")=$P(^DD(442.01,47,0),U,2),DLAYGO=442
  1. . D FILE^DICN
  1. K DIE
  1. ;
  1. ; PRC*5.1*81 - delete items from RIL as they are moved to a PC order
  1. I PRCVDYN D
  1. . N DA,DIK
  1. . S DA=GG(II),DA(1)=YDA,DIK="^PRCS(410.3,"_DA(1)_",1,"
  1. . D ^DIK
  1. ;
  1. S PRCHCPD=TDATE,PRCHCV=VENDOR,(DA(1),PRCHCPO)=PDA,PRCHCCP=CP1,(PRCHCI,PRCHCII,X)=$P(AA(II),"^",5),DA=II
  1. I PRCHCI'="" D EN3^PRCHCRD S ^PRC(442,PDA,2,"AE",PRCHCII,II)=""
  1. K PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCII
  1. QUIT
  1. ;
  1. INCOM1 S FLAG=0
  1. INCOM2 S:$G(FLAG)="" FLAG=1
  1. INCOM ;
  1. K ^TMP($J)
  1. N ZP,LABEL,PC1,PONUM,PODATE,STAT,PANAME,ADATE,Y,XXZ,EX,P,P1,P12,P2,P23,STR,TIMEDATE
  1. S:$G(FLAG)="" LABEL="INCOM" S:$G(FLAG)=0 LABEL="INCOM1" S:$G(FLAG)=1 LABEL="INCOM2"
  1. W @IOF
  1. S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(PRC("SITE"))="^"
  1. W !,"Please select a device for printing this report."
  1. S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
  1. I $D(IO("Q")) S ZTSAVE("*")="",ZTRTN="DETAIL^PRCH442A" D ^%ZTLOAD,^%ZISC K FLAG Q
  1. D DETAIL,^%ZISC K FLAG
  1. Q
  1. ;
  1. DETAIL ;
  1. S X=DT D NOW^%DTC,YX^%DTC S TIMEDATE=Y,CNT=0
  1. S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
  1. .Q:$P($G(^PRC(442,ZP,7)),"^")=45
  1. .Q:$D(^PRC(442,ZP,11))
  1. .Q:$P($G(^PRC(442,ZP,12)),"^",2)'=""
  1. .S P1=$G(^PRC(442,ZP,0)),PONUM=$P(P1,"^")
  1. .I $D(PRC("SITE")) Q:$P(P1,"-")'=PRC("SITE")
  1. .S PC1=$P($G(^PRC(442,ZP,23)),"^",8) I PC1="" D DETAIL1
  1. .Q:PC1=""
  1. .I $G(FLAG)=0 Q:$P($G(^PRC(440.5,PC1,0)),"^",8)'=DUZ
  1. .I $G(FLAG)=1 I $P($G(^PRC(440.5,PC1,0)),"^",10)'=DUZ,$P($G(^PRC(440.5,PC1,0)),"^",9)'=DUZ Q
  1. .S P2=$G(^PRC(442,ZP,1)),PA=$P($G(^PRC(440.5,PC1,0)),"^",8) Q:PA=""
  1. .S PANAME=$P($G(^VA(200,PA,0)),"^") Q:PANAME=""
  1. .S Y=$P(P2,"^",15) D DD^%DT S PODATE=Y
  1. .S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
  1. .S Y=$P($G(^PRC(442,ZP,12)),"^",5) D DD^%DT S ADATE=Y
  1. .S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
  1. D WRTE
  1. W:$D(^TMP($J)) !!!,?10,"Total number of orders found: "_CNT
  1. K ^TMP($J),CNT
  1. Q
  1. ;
  1. DETAIL1 ;Get tally for the PC user and exclude the Approving Official.
  1. Q:$G(FLAG)=1
  1. ;if the PC Coordinator is asking for the report, get the orders.
  1. I $G(FLAG)="" D DETAIL2
  1. Q:$P($G(^PRC(442,ZP,12)),"^",4)'=DUZ!($G(FLAG)'=0)
  1. S PA=$P(^PRC(442,ZP,12),"^",4),PANAME=$P(^VA(200,PA,0),"^") Q:PANAME=""
  1. S Y=$P(^PRC(442,ZP,12),"^",5) D DD^%DT S ADATE=Y,PODATE=$P(Y,"@",1)
  1. S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
  1. S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
  1. Q
  1. ;
  1. DETAIL2 ;Get tally for the PC Coordinator.
  1. S PA=$P(^PRC(442,ZP,12),"^",4),PANAME=$P(^VA(200,PA,0),"^") Q:PANAME=""
  1. S Y=$P(^PRC(442,ZP,12),"^",5) D DD^%DT S ADATE=Y,PODATE=$P(Y,"@",1)
  1. S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
  1. S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
  1. Q
  1. ;
  1. WRTE ;
  1. U IO S (P,EX)=1
  1. I '$D(^TMP($J)) D HDR W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
  1. S ZP="" F S ZP=$O(^TMP($J,ZP)) Q:ZP="" Q:EX="^" D
  1. .D:P=1 HDR
  1. .W !,$P(^TMP($J,ZP),"^"),?21,$P(^TMP($J,ZP),"^",2),?40,$P(^TMP($J,ZP),"^",3),!,?10,$P(^TMP($J,ZP),"^",4),?40,$P(^TMP($J,ZP),"^",5),!
  1. .I (IOSL-$Y)<6 D HLD Q:EX="^"
  1. QUIT
  1. ;
  1. C2237 ;cancel 2237 from PC order
  1. N I,N,T,X,ZX,PRCVIEN
  1. Q:'$D(DA) S YDA=DA,PRCVIEN=DA,XDA=$P($G(^PRC(442,DA,23)),"^",23) Q:XDA="" L +^PRCS(410,XDA):15 Q:'$T
  1. S PRC("CP")=$P($G(^PRC(442,YDA,0)),"^",3) Q:+PRC("CP")=""
  1. S T=$P(^PRCS(410,XDA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0 K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),XDA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),XDA),^PRCS(410,"AQ",1,XDA)
  1. K ZX I $D(^PRCS(410,XDA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
  1. I $D(ZX) S ^PRCS(410,XDA,4)=ZX K ZX
  1. I $D(^PRCS(410,XDA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,XDA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=XDA,DA=N D TRANK^PRCSEZZ S XDA=DA(1)
  1. D ERS410^PRC0G(XDA_"^C")
  1. L -^PRCS(410,XDA)
  1. I $D(^PRC(443,XDA,0)) S DA=XDA,DIK="^PRC(443," D ^DIK K DIK
  1. S DA=YDA
  1. ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D DEL^PRCV442A(PRCVIEN)
  1. QUIT
  1. ;
  1. RENUM ; delete delivery order items from repetitive item list
  1. Q:$G(^PRCS(410.3,YDA,0))=""
  1. L +^PRCS(410.3,YDA):15 Q:'$T
  1. S IJ="" F S IJ=$O(^PRCS(410.3,YDA,1,IJ)) Q:IJ="" D
  1. .I $P($G(^PRCS(410.3,YDA,1,IJ,0)),"^",6)="O" S DA=IJ,DA(1)=YDA,DIK="^PRCS(410.3,"_DA(1)_",1," D ^DIK
  1. L -^PRCS(410.3,YDA)
  1. I $P($G(^PRCS(410.3,YDA,1,0)),"^",4)=0 W !,"This Repetitive Item List has no more items, and will be deleted." S DA=YDA,DIK="^PRCS(410.3," D ^DIK
  1. K DIK QUIT
  1. ;
  1. HDR W @IOF
  1. W !,"INCOMPLETE PURCHASE CARD ORDERS REPORT",?45,TIMEDATE,?70,"PAGE ",P
  1. W !,"PURCHASE CARD ORDER",?21,"PO DATE",?40,"SUPPLY STATUS",!,?10,"BUYER",?40,"DATE PO ASSIGNED"
  1. W ! F I=1:1:8 W "----------"
  1. S P=P+1
  1. QUIT
  1. ;
  1. HLD G HDR:$P(IOST,"-")="P" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" D:EX'["^" HDR QUIT