Changeset 623 for WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN
- Files:
-
- 17 edited
-
PRCFACPS.m (modified) (1 diff)
-
PRCFALOG.m (modified) (1 diff)
-
PRCHEF.m (modified) (1 diff)
-
PRCHMA.m (modified) (1 diff)
-
PRCHNPO3.m (modified) (1 diff)
-
PRCHNPO5.m (modified) (1 diff)
-
PRCHNPO8.m (modified) (1 diff)
-
PRCHPCAR.m (modified) (1 diff)
-
PRCHQ4.m (modified) (1 diff)
-
PRCPLO2A.m (modified) (1 diff)
-
PRCPUSEL.m (modified) (1 diff)
-
PRCSD122.m (modified) (1 diff)
-
PRCSP122.m (modified) (1 diff)
-
PRCSRIG1.m (modified) (1 diff)
-
PRCVRC2.m (modified) (1 diff)
-
PRCVRE1.m (modified) (1 diff)
-
PRCVREA.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACPS.m
r613 r623 1 PRCFACPS 2 V ;;5.1;IFCAP;**114**;Oct 20, 2000;Build 43 ;Per VHA Directive 2004-038, this routine should not be modified.4 DQ 5 6 S PRCFNAME=$S(PRCFASYS["CLMCLIRRLOG":"FEE/FEN, Receiving Reports & LOG",PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG")7 8 9 10 11 12 13 14 15 16 XREF 17 18 19 20 KILLCS 21 22 23 24 25 26 27 28 29 30 31 32 33 K 34 35 36 1 PRCFACPS ;WISC@ALTOONA/CTB/DL-PURGE CODE SHEET CONTINUATION ;1/29/98 1300 2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 DQ ;;PURGE CODE SHEETS AND TRANSMISSION RECORDS 5 D:$D(ZTQUEUED) KILL^%ZTLOAD 6 S PRCFNAME=$S(PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG") 7 L +^PRCF(423,0):5 I '$T S X="Code Sheet file unavailable - File lock timeout.*" D MSG^PRCFQ Q 8 W:$D(IOF) @IOF W PRCFNAME_" CODE SHEET & TRANSMISSION RECORD DELETION TRANSCRIPT" D NOW^PRCFQ W ?IOM-$L(%X),%X 9 S $P(LINE,"-",IOM-2)="" W !,LINE,!!,"Option queued by: ",$S($D(DUZ):$P(^VA(200,DUZ,0),"^"),1:"Menu Manager"),!,"Date/Time queued: ",PRCFA("QTIME"),!,"From Device: ",PRCFA("QION") 10 W !!!,PRCFNAME_" code sheet deletion has begun for station ",PRC("SITE"),!,"I am deleting all "_PRCFNAME_" code sheets created or transmitted on or before ",PRCFA("DATE"),".",! 11 S (DA,J)=0,U="^" F K=1:1 S DA=$O(^PRCF(423,DA)) Q:'DA D KILLCS 12 W !!,"Done - deleted ",J," ",PRCFNAME," code sheets. ",$P(^PRCF(423,0),"^",4)," code sheets remaining." 13 W !!,"I will now begin cleaning up the Log Transmission Record file.",!,"I will delete all "_PRCFNAME_" batches and transmission records created on or before ",PRCFA("DATE"),! 14 S (DA,JX)=0,DIK="^PRCF(421.2," F K=1:1 S DA=$O(^PRCF(421.2,DA)) Q:'DA I $D(^(DA,0)) S X=^(0) I +$P(X,"-",2)>0!(PRCFASYS[$P(X,"-",2)),$P(X,"^",10)<PRCFA("KDATE"),(+X=PRC("SITE")!(+X="")) D ^DIK S JX=JX+1 W:JX#50=0 "." 15 W !!,"Done - Deleted ",JX," Batch and Transmission records. ",$P(^PRCF(421.2,0),"^",4)," transmission/batch records remaining.",!! Q 16 XREF ;CLEAN UP OF XREF'S IN FILE 423 17 S XREF="A" F ZI=1:1 S XREF=$O(^PRCF(423,XREF)) Q:XREF="" S VAL="" F ZJ=1:1 S VAL=$O(^PRCF(423,XREF,VAL)) Q:VAL="" S DA=0 F ZK=1:1 S DA=$O(^PRCF(423,XREF,VAL,DA)) Q:DA="" K:'$D(^PRCF(423,DA)) ^PRCF(423,XREF,VAL,DA) 18 S XREF="C",VAL="" F ZJ=1:1 S VAL=$O(^PRCF(423,XREF,VAL)) Q:VAL="" I VAL["^" S DA=0,VAL1=$P(VAL,"^") F ZK=1:1 S DA=$O(^PRCF(423,XREF,VAL,DA)) Q:DA="" K ^PRCF(423,XREF,VAL,DA) S ^PRCF(423,XREF,VAL1,DA)="" 19 K XREF,VAL,DA,ZI,ZJ,ZK Q 20 KILLCS S ZERO=$S($D(^PRCF(423,DA,0)):^(0),1:""),TRANS=$S($D(^("TRANS")):^("TRANS"),1:""),ZLOG=$S($D(^(300)):^(300),1:""),ONE=$S($D(^(1)):^(1),1:"") 21 I ZERO="",TRANS="",ZLOG="",ONE G K 22 I $P(ZERO,"^",2)'=PRC("SITE"),$P(ZERO,"^",2)]"" Q 23 I PRCFASYS'[$P(ZERO,"^",10),$P(ZERO,"^",10)]"" Q 24 I +$P(TRANS,U,3)>PRCFA("KDATE")!(+$P(TRANS,U,9)>PRCFA("KDATE")) Q 25 S J=J+1 W:J#50=0 "." 26 I $P(ZERO,U,6)'="" K ^PRCF(423,"C",$P(ZERO,U,6),DA) 27 K:$P(ZERO,U,1)'="" ^PRCF(423,"B",$P(ZERO,U),DA) 28 K:$P(TRANS,U,5)'="" ^PRCF(423,"AD",$P(TRANS,U,5),DA) 29 K:$P(TRANS,U,6)]"" ^PRCF(423,"AE",$P(TRANS,U,6),DA) 30 K:$P(ZLOG,U,24)]"" ^PRCF(423,"D",$P(ZLOG,U,24),DA) 31 K:$P(ZLOG,U,25)]"" ^PRCF(423,"AN",$P(ZLOG,U,25),DA) 32 K:$P(ONE,U,29)]"" ^PRCF(423,"AI",$P(ONE,U,29),DA) 33 K K ONE,ZERO,TRANS,ZLOG,^PRCF(423,"AC","N",DA) 34 F ZX="AJ","AK","AL","AM" K ^PRCF(423,ZX,"Y",DA) 35 K ^PRCF(423,DA),ZX S:$P(^PRCF(423,0),"^",4)>0 $P(^(0),U,4)=$P(^(0),U,4)-1 Q 36 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m
r613 r623 1 PRCFALOG ;WISC/CTB-LOG CODE SHEETS ;11-27-92/08:20 2 V ;;5.1;IFCAP;**114**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 A S PRCHLOG="",PRCFASYS="LOGDLA" Q 5 B K PRCHLOG,PRCFASYS Q 6 CCS ;CREATE A CODE SHEET 7 D A,EN1^PRCFAC,B Q 8 DCS ;DELETE A CODE SHEET 9 D A,EN9^PRCFAC2,B Q 10 ECS ;EDIT A CODE SHEET 11 D A,EN2^PRCFAC,B Q 12 EKCS ;EDIT A KEY PUNCHED CODE SHEET 13 D A,EDIT^PRCFACR4,B Q 14 KCS ;KEY PUNCH A CODE SHEET 15 D A,^PRCFACR3,B Q 16 GRAB ;GRAB A BATCH NUMBER 17 D A,^PRCFACG,B Q 18 MBP ;MODIFY PRIORITY OF CODE SHEET WITHIN ITS BATCH 19 D A,EN1^PRCFAC2,B Q 20 BATCH ;BATCH AND PRINT CODE SHEETS 21 D A,EN^PRCFACP,B Q 22 REPRINT ;REPRINT A BATCH 23 D A,EN^PRCFAC5,B Q 24 PURGE ;PURGE CODE SHEETS 25 D A S PRCFASYS=PRCFASYS_"PHA" D EN^PRCFACPR,B Q 26 PURGE2 ;PURGE ALL CODE SHEETS 27 W !!,"** YOU MUST SELECT A DESIGNATED PRINTER FOR PURGE TO FUNCTION PROPERLY." 28 W !,"** DEFAULTING TO HOME DEVICE (0) WILL NOT PURGE DATA SINCE THE OPTION WILL BE " 29 W !,"** TASKED.",! 30 S PRCFASYS="CLMCLIRRLOGDLAPHAGSA" D EN^PRCFACPR,B Q 31 ADD ;ADD CODE SHEET TO PRINTED BATCH 32 D A,ADD^PRCFACR2,B Q 33 DELETE ;DELETE CODE SHEET FROM PRINTED BATCH 34 D A,REMOV^PRCFACR2,B Q 35 TRANSMIT ;TRANSMIT CODE SHEETS 36 D A,SE^PRCFACR,B Q 37 RETRANS ;RETRANSMIT CODE SHEET BATCH 38 D A,RT^PRCFACR5,B Q 39 INQUIRY ;BATCH/TRANSMISSION/RECEIVING REPORT INQUIRY 40 D A,E14^PRCFAC3,B Q 1 PRCFALOG ;WISC/CTB-LOG CODE SHEETS ;11-27-92/08:20 2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 A S PRCHLOG="",PRCFASYS="LOGDLA" Q 5 B K PRCHLOG,PRCFASYS Q 6 CCS ;CREATE A CODE SHEET 7 D A,EN1^PRCFAC,B Q 8 DCS ;DELETE A CODE SHEET 9 D A,EN9^PRCFAC2,B Q 10 ECS ;EDIT A CODE SHEET 11 D A,EN2^PRCFAC,B Q 12 EKCS ;EDIT A KEY PUNCHED CODE SHEET 13 D A,EDIT^PRCFACR4,B Q 14 KCS ;KEY PUNCH A CODE SHEET 15 D A,^PRCFACR3,B Q 16 GRAB ;GRAB A BATCH NUMBER 17 D A,^PRCFACG,B Q 18 MBP ;MODIFY PRIORITY OF CODE SHEET WITHIN ITS BATCH 19 D A,EN1^PRCFAC2,B Q 20 BATCH ;BATCH AND PRINT CODE SHEETS 21 D A,EN^PRCFACP,B Q 22 REPRINT ;REPRINT A BATCH 23 D A,EN^PRCFAC5,B Q 24 PURGE ;PURGE CODE SHEETS 25 D A S PRCFASYS=PRCFASYS_"PHA" D EN^PRCFACPR,B Q 26 ADD ;ADD CODE SHEET TO PRINTED BATCH 27 D A,ADD^PRCFACR2,B Q 28 DELETE ;DELETE CODE SHEET FROM PRINTED BATCH 29 D A,REMOV^PRCFACR2,B Q 30 TRANSMIT ;TRANSMIT CODE SHEETS 31 D A,SE^PRCFACR,B Q 32 RETRANS ;RETRANSMIT CODE SHEET BATCH 33 D A,RT^PRCFACR5,B Q 34 INQUIRY ;BATCH/TRANSMISSION/RECEIVING REPORT INQUIRY 35 D A,E14^PRCFAC3,B Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m
r613 r623 1 PRCHEF 2 V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 133 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 EN80 6 7 8 9 I X<25!(X>33) W $C(7)," Receiving Report cannot be deleted, please create an adjustment voucher." G EN8010 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 1 PRCHEF ;ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;6/10/97 9:34 2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 EN80 ;DELETE A RECEIVING REPORT (CONT.FROM PRCHE) 6 K PRCHNRQ D PO^PRCHE G:'$D(PRCHPO) Q^PRCHE 7 I $P($G(^PRC(442,PRCHPO,23)),U,11)="S"!($P($G(^(23)),U,11)="P") W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for purchase card orders.",! G EN80 8 I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for delivery orders.",! G EN80 9 I X<25!(X>33) W $C(7)," ??" G EN80 10 I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"Order has no Receiving Reports !",$C(7) G EN80 11 D LCK1^PRCHE G:'$D(DA) EN80 S:$P(^PRC(442,PRCHPO,0),U,2)=8 PRCHNRQ=1 12 S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ" D ^DIC I Y<0 L G EN80 13 I $P(Y(0),U,6)="Y" W !?3,"Receiving Report has already been processed by Fiscal.",!?3,"You must create an Adjustment Voucher to edit this Receiving Report.",! L G EN80 14 S (PRCHRPT,PRCHDPT)=+Y,(PRCHRD,PRCHDRD)=$P(Y(0),U,1),(PRCHRDEL,PRCHDTP)=1,PRCHEX=$P(Y(0),U,3)+$P(Y(0),U,5) 15 D ^PRCHDP3,DEL^PRCHREC2 K PRCHRDEL I $D(PRCHRD) L D Q^PRCHE G EN80 16 ;S PRCHREC=$S($O(^PRC(442,PRCHPO,11,0)):1,1:0),X=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,2),1:"") 17 S PRCHREC=$S($O(^PRC(442,PRCHPO,11,0)):1,1:0),X=$P($G(^PRC(442,PRCHPO,7)),U,2) 18 I PRCHREC S Y=$S(X=30:"25,30",X=31:"26,31",X=33:"28,33",1:X) 19 I 'PRCHREC S Y=$S(X=25:"22,20",X=27:22,X=30:"20,22",X=26:"23,21",X=31:"23,21",X=28:10,X=33:10,1:X) 20 W !! 21 K DIC S DIC("S")="I "_""""_Y_""""_"[($P(^(0),U,2)),$L($P(^(0),U,2))=""2""" 22 ;S DIC="^PRCD(442.3,",DIC(0)="AEQMZ",DIC("B")=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,1),1:""),DIC("A")="Update SUPPLY STATUS: " D ^DIC K DIC S PRCHX=+Y I PRCHX'>0 S PRCHX=$S($D(^PRC(442,PRCHPO,7)):$P(^(7),U,1),1:"") 23 S DIC="^PRCD(442.3,",DIC(0)="AEQMZ",DIC("B")=$P($G(^PRC(442,PRCHPO,7)),U,1),DIC("A")="Update SUPPLY STATUS: " D ^DIC K DIC S PRCHX=+Y I PRCHX'>0 S PRCHX=$P($G(^PRC(442,PRCHPO,7)),U,1) 24 S X=$P(^PRC(442,PRCHPO,0),U,17),X=X-PRCHEX,$P(^(0),U,17)=X,DR=".5////"_PRCHX,DIE="^PRC(442,",DA=PRCHPO K PRCHX D ^DIE,Q^PRCHE 25 G EN80 -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m
r613 r623 1 PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96 14:07 2 ;;5.1;IFCAP;**21,79,100,113**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 REQ N PRCHREQ 5 S PRCHREQ=1 6 PO N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT 7 N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J 8 N PRCFL,MSG 9 LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0 10 ; See routine PRCHAMXA for information on variable PRCHNORE and undefined DIK, var PRCHPO is the basic premise of locks applied to amendments 11 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) 12 ; Lock simultaneous entry of users in amend. module for the same record. Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start 13 ; the process(AMENDNO) of amending the record we must have var PRCHPO. 14 S PRCFL=0 15 W !! D GETPO^PRCHAMU 16 ; If no record is selected or time-out or up-arrow out then exit without unlocking a record. 17 I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1 18 I PRCFL=1 G LOOP 19 I '$G(PRCHPO)!$D(FIS) G EXIT 20 I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT 21 D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT 22 S PRCHAMT=0,FL=0 23 D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT 24 S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB 25 I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX 26 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 27 I PRCHNEW=111&($G(CAN)=0) D REV 28 I $G(CAN)>0 D ENC G:ER EXIT I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX G CAN1 29 ASK K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU 30 G:$D(REPONUM)=1 CAN1 31 I ER=0 D G:'$D(REPO)&($G(CAN)=0) ASK 32 . D @ROU 33 . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q 34 . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q 35 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 36 I $D(DTOUT)!($D(DUOUT)) G EXIT 37 I $G(NOCAN)=1 G ASK 38 G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT 39 CAN1 S BFLAG=0 40 S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)'=6 BFLAG=1 41 I $P($G(^PRC(443.6,PRCHPO,1)),U,7)=6 D 42 .S THISHLD=0 43 .F S THISHLD=$O(^PRC(443.6,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D 44 ..S:$P($G(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1 45 .Q:BFLAG=1 46 .S THISHLD=0 47 .F S THISHLD=$O(^PRC(442,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1) D 48 ..S:$P($G(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1 49 W:BFLAG=0 !,"This is now a contract order. You must add a contract to this orders item(s)",!,"before approving the amendment.",! 50 G:BFLAG=0 EXIT 51 D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT 52 CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT 53 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D 54 .S POSTAT=+$G(^PRC(443.6,PRCHPO,7)) 55 .S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT) 56 .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U) 57 .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT" 58 .D ^DIE K DIE,AMSTAT,POSTAT 59 K PRCHER S LCNT=1 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status.",! S PRCHER="" 60 I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D G:$D(PRCHER) ERR 61 .N END S END=IOSL-3 62 .S PRCH=0 F S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D 63 ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D Q 64 ...I $P(PRCHLN,U,4)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing BOC !",$C(7) S PRCHER="",LCNT=LCNT+2 65 ...I $G(PRCHAUTH)'=1,$G(PRCHREQ) I $P(PRCHLN,U,13)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing NSN!",$C(7) S PRCHER="",LCNT=LCNT+2 66 ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2 67 ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2 68 ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered 69 ...D PCD^PRCHMA1 70 ...Q 71 ..Q 72 .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1 73 .Q 74 D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT 75 I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER="" 76 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1 77 I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER) 78 I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D I $G(ERROR) S PRCHER="" K ERROR,FILE 79 .D ^PRCHSF3 80 .D ADJ1^PRCHCD0 81 .D LIMIT^PRCHCD0 82 ; 83 ERR I $D(PRCHER) W !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days." D:LCNT>20 G EXIT 84 .N DIR S DIR(0)="E" D ^DIR 85 .Q 86 D REV:'$G(PRCPROST),APP G:%'=1 EXIT 87 S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT 88 S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN) 89 G:RETURN'=1 EXIT 90 S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE 91 D ^PRCHSF3 92 I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 93 I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D 94 . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 95 . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH 96 . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q 97 . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q 98 I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT 99 .S MTOPDA=1 100 .D SUPP^PRCFFM2M ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !! 101 .S PPTEMP=0,PP410=$P($G(^PRC(442,PRCHPO,0)),"^",12),PPAMT=$P($G(^PRC(442,PRCHPO,0)),"^",16) I PP410'="" S PPTEMP=$P($G(^PRCS(410,PP410,4)),"^",8),PPTEMP=-(PPAMT-PPTEMP) 102 .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0 103 .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0 104 .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT 105 .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2),$P(PRCOAMT,"^",5)=PPTEMP D EBAL^PRCSEZ(PRCOAMT,"O") 106 .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C") 107 .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE 108 .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 109 .; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either 110 .; cancels the order or enters other type of amendment that changes the final amount of the order. No credit is given for orders from a 111 .; previous month and year. DT is the current date, system-supplied. 112 .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8) 113 .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3) 114 .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3) 115 .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2) 116 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D 117 ..I $G(PPAMT)<0 Q 118 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG) 119 ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 120 .; 121 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D 122 ..I $G(PPTEMP)<0 Q 123 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP) 124 ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 125 .; 126 .; Update file #440.5 only if the amendment is for non-cancellation 127 .; of an order from a previous month regardless of the year. 128 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D 129 ..I $G(PPAMT)<0 Q 130 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT) 131 .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410 132 S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1 133 I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 134 D SOURCE^PRCHAMU:$G(SCE) 135 G EXIT 136 ENC S ER=0 137 D CAN^PRCHMA3 138 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q 139 I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D S ER=1 Q 140 . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7) 141 S %="",%A=" SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN 142 I %'=1 W ?40," <NOTHING CANCELLED>" D Q 143 .I $D(PRCHAU) D 144 ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU 145 ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)="" 146 .S NOCAN=1 147 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))" 148 D ^DIE K DIE,DA,DR S CAN=1 149 S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W ! 150 QUIT 151 APP S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN 152 Q 153 REV N PRCH 154 S %=1,%B="",%A=" Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN 155 I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM 156 Q 157 EXIT L -^PRC(442,PRCENTRY) 158 EXIT1 K ERROR,FIS,REPO,DEL 159 QUIT:$G(PRCPROST) 160 I $G(OUT)'=1 G LOOP 161 QUIT 162 FLAG I $G(FLAG)=1 K FLAG Q 163 Q 164 NOSIGN S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU 165 NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@" 166 D ^DIE K DIE,DA,DR 167 Q 168 TOP ;PAUSE AT BOTTOM OF SCREEN 169 N DIR S DIR(0)="E" 170 D ^DIR 171 S LCNT=1 172 Q 1 PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96 14:07 2 ;;5.1;IFCAP;**21,79,100**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 REQ ;Req. 5 N PRCHREQ 6 S PRCHREQ=1 7 PO ;PO 8 N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON 9 N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT 10 N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND 11 N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J 12 N PRCFL,MSG 13 LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0 14 ; 15 ; See routine PRCHAMXA for information on variable PRCHNORE and for 16 ; incidence of undefined DIK variable errors. 17 ; The var PRCHPO is the basic premise of locks applied to amendments. 18 ; Anytime amend module is accessed add +lock & save po# in PRCENTRY. 19 ; 20 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) 21 ; 22 ; Lock simultaneous entry of users in amend. module for the same record. 23 ; Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start 24 ; the process(AMENDNO) of amending the record we must have var PRCHPO. 25 ; 26 S PRCFL=0 27 W !! D GETPO^PRCHAMU 28 ; If no record is selected or time-out or up-arrow out then exit 29 ; without unlocking a record. 30 I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1 31 I PRCFL=1 G LOOP 32 I '$G(PRCHPO)!$D(FIS) G EXIT 33 I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT 34 D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT 35 S PRCHAMT=0,FL=0 36 D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT 37 S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB 38 I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX 39 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 40 I PRCHNEW=111&($G(CAN)=0) D REV 41 I $G(CAN)>0 D ENC G:ER EXIT I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX G CAN1 42 ASK K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU 43 G:$D(REPONUM)=1 CAN1 44 I ER=0 D G:'$D(REPO)&($G(CAN)=0) ASK 45 . D @ROU 46 . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q 47 . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q 48 ; 49 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1 50 I $D(DTOUT)!($D(DUOUT)) G EXIT 51 I $G(NOCAN)=1 G ASK 52 G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT 53 CAN1 D UPDATE^PRCHAMU G:$D(Y) EXIT 54 CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT 55 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D 56 .S POSTAT=+$G(^PRC(443.6,PRCHPO,7)) 57 .S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT) 58 .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U) 59 .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT" 60 .D ^DIE K DIE,AMSTAT,POSTAT 61 K PRCHER S LCNT=1 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status.",! S PRCHER="" 62 I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D G:$D(PRCHER) ERR 63 .N END S END=IOSL-3 64 .S PRCH=0 F S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D 65 ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D Q 66 ...I $P(PRCHLN,U,4)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing BOC !",$C(7) S PRCHER="",LCNT=LCNT+2 67 ...I $G(PRCHAUTH)'=1,$G(PRCHREQ) I $P(PRCHLN,U,13)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing NSN!",$C(7) S PRCHER="",LCNT=LCNT+2 68 ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2 69 ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2 70 ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to 71 ...; make sure that a contract number is entered 72 ...D PCD^PRCHMA1 73 ...Q 74 ..Q 75 .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1 76 .Q 77 ;PRC*5.1*100: check line items without an FSC or PSC 78 D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT 79 I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER="" 80 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1 81 I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER) 82 ; 83 ; Change below to allow checks for monthly limits in file #440.5 before 84 ; completion of the amendment. 85 ; 86 I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D I $G(ERROR) S PRCHER="" K ERROR,FILE 87 .D ^PRCHSF3 88 .D ADJ1^PRCHCD0 89 .D LIMIT^PRCHCD0 90 ; 91 ERR I $D(PRCHER) W !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days." D:LCNT>20 G EXIT 92 .N DIR S DIR(0)="E" D ^DIR 93 .Q 94 D REV:'$G(PRCPROST),APP G:%'=1 EXIT 95 S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT 96 S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN) 97 G:RETURN'=1 EXIT 98 S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE 99 D ^PRCHSF3 100 I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 101 I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D 102 . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 103 . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH 104 . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q 105 . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q 106 I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT 107 .S MTOPDA=1 108 .D SUPP^PRCFFM2M ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !! 109 .S PPTEMP=0,PP410=$P($G(^PRC(442,PRCHPO,0)),"^",12),PPAMT=$P($G(^PRC(442,PRCHPO,0)),"^",16) I PP410'="" S PPTEMP=$P($G(^PRCS(410,PP410,4)),"^",8),PPTEMP=-(PPAMT-PPTEMP) 110 .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0 111 .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0 112 .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT 113 .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2),$P(PRCOAMT,"^",5)=PPTEMP D EBAL^PRCSEZ(PRCOAMT,"O") 114 .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C") 115 .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE 116 .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 117 .; 118 .; Update file #440.5 after amendment has been approved. Consider orders 119 .; created and amended in the same month and year and the user either 120 .; cancels the order or enters other type of amendment that changes the 121 .; final amount of the order. No credit is given for orders from a 122 .; previous month and year. DT is the current date, system-supplied. 123 .; 124 .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8) 125 .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3) 126 .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3) 127 .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2) 128 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D 129 ..I $G(PPAMT)<0 Q 130 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG) 131 ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 132 .; 133 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D 134 ..I $G(PPTEMP)<0 Q 135 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP) 136 ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0 137 .; 138 .; Update file #440.5 only if the amendment is for non-cancellation 139 .; of an order from a previous month regardless of the year. 140 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D 141 ..I $G(PPAMT)<0 Q 142 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT) 143 .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410 144 S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1 145 I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE 146 ; 147 D SOURCE^PRCHAMU:$G(SCE) 148 G EXIT 149 ; 150 ENC ;Can 151 S ER=0 152 D CAN^PRCHMA3 153 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q 154 I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D S ER=1 Q 155 . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7) 156 S %="",%A=" SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN 157 I %'=1 W ?40," <NOTHING CANCELLED>" D Q 158 .I $D(PRCHAU) D 159 ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU 160 ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)="" 161 .S NOCAN=1 162 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))" 163 D ^DIE K DIE,DA,DR S CAN=1 164 S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W ! 165 QUIT 166 APP ;App,pr 167 S %A=" Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN 168 Q 169 REV ;Rev 170 N PRCH 171 S %=1,%B="",%A=" Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN 172 I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM 173 Q 174 EXIT ;Ex 175 L -^PRC(442,PRCENTRY) 176 EXIT1 K ERROR,FIS,REPO,DEL 177 QUIT:$G(PRCPROST) 178 I $G(OUT)'=1 G LOOP 179 QUIT 180 ; 181 FLAG ; 182 I $G(FLAG)=1 K FLAG Q 183 Q 184 NOSIGN ; 185 S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU 186 NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@" 187 D ^DIE K DIE,DA,DR 188 Q 189 TOP ;PAUSE AT BOTTOM OF SCREEN 190 N DIR S DIR(0)="E" 191 D ^DIR 192 S LCNT=1 193 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m
r613 r623 1 PRCHNPO3 ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm 2 V ;;5.1;IFCAP;*112*;Oct 20, 2000;Build 2 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 S PRCHSZ=1 6 ; 7 EN0 W !,"Enter a 2237 reference number. The FCP,Cost Center,Service,Delivery",!?3,"Location" W:PRCHSZ " and Line Items" W " will be transferred into this Purchase Order." 8 W !!,?10,"The 2237 Fiscal Year and Quarter must be earlier or same",!,?10,"as the P.O. Date Fiscal Year and Quarter.",! 9 I $O(^PRC(442,PRCHPO,13,0)) W !?3,"This Purchase Order already contains:" F I=0:0 S I=$O(^PRC(442,PRCHPO,13,I)) Q:'I I $D(^PRCS(410,I,0)) W !?3,$P(^(0),U,1) 10 I '$D(^PRC(442,PRCHPO,1)),$P(^(1),U,15)="" W !!,"Cannot precede without a P.O. DATE" G Q 11 ; 12 EN K PRCHSY S PRCHD=$P(^PRC(442,PRCHPO,1),U,15),PRCHSP=$P(^(0),U,12) 13 ;screen-out the Issue Book order if status is 65--Assigned to PPM Clerk, for nois MWV-0293-20011 14 S DIC="^PRC(443," 15 S DIC(0)="AQEMZ" 16 I $G(PRCHZZZ9)'=1 S DIC("S")="I $P(^(0),U,3)]"""",""65,72""'[$P(^(0),U,7),$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" 17 I $G(PRCHZZZ9)=1 S DIC("S")="I $P(^(0),U,3)]"""",$P(^(0),U,7)=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" 18 D ^DIC K DIC G:Y<0 Q S PRCHSY=+Y,PRCHSY(0)=Y(0),Y(0)=^PRCS(410,+Y,0),PRCHSX=$P(Y(0),U,1) I $D(^(1)),$P(^(1),U,3)="EM" W $C(7),!,"*** EMERGENCY ***" 19 ;I $D(^PRCS(410,+Y,0)),$P(^(0),U,4)=5 W !?3,"This is an Issue Book Order, and it can't be processed into a Purchase Order." Q 20 ; 21 EN1 S PRCHRFQT=$$DATE^PRC0C($P(Y(0),"^",11),"I"),PRCHRFQT=$P(PRCHRFQT,U,1,2) 22 S PRC("BBFY")=+$$DATE^PRC0C($P(^PRCS(410,+Y,3),"^",11),"I") 23 ;S PRCHCFQT=$$DATE^PRC0C($P(^PRC(420,PRC("SITE"),0),U,9),"I"),PRCHCFQT=$P(PRCHCFQT,U,1,2) 24 S PRCHPFQT=$$DATE^PRC0C($P(^PRC(442,PRCHPO,1),"^",15),"I"),PRCHPFQT=$P(PRCHPFQT,U,1,2) 25 I PRCHRFQT'=PRCHPFQT W !,?10,"The Fiscal Year and Quarter on this 2237 is not",!,?10,"compatible with the PO Date.",!,$C(7) K PRCHRFQT,PRCHPFQT G EN 26 K PRCHRFQT,PRCHPFQT 27 I $P(^PRC(442,PRCHPO,0),U,3)]"",+$P(^PRC(442,PRCHPO,0),U,3)'=+$P(^PRCS(410,PRCHSY,3),U,1) W !?3,"Fund Control Point for this 2237 doesn't match the existing FCP in P.O.",$C(7) G EN 28 I $P(^PRC(442,PRCHPO,0),U,5)]"",+$P(^PRC(442,PRCHPO,0),U,5)'=+$P(^PRCS(410,PRCHSY,3),U,3) W !?3,"Cost Center for this 2237 doesn't match the Cost Center in P.O.",$C(7) G EN 29 S X="",Z="" I $D(^PRC(420,PRC("SITE"),1,+^PRCS(410,PRCHSY,3),0)) S X=$P(^(0),U,12),Z=$P(^(0),U,18) 30 I X'=2 S:Z'="" $P(^PRC(442,PRCHPO,17),U,1)=$E(Z,1,3) I Z="" W $C(7),!?3,"Fund Control point is missing LOG Department Number!!" G EN 31 I X I PRCHN("MP")=4!((X=3)&(PRCHN("MP")=3)) S Y=$P(^PRCD(442.5,PRCHN("MP"),0),U,1) W $C(7),!?3,"This Fund Control Point is not valid for a "_Y_" order." G EN 32 S EN=0 I $D(^PRC(411,"UP",PRC("SITE"))) D G EN:EN=1 33 .I $P($G(^PRCS(410,+Y,0)),U,10)="" W $C(7),!!?3,"This 2237 does not have a substation.",! S EN=1 Q 34 .I $P($G(^PRCS(410,+Y,0)),U,10)'=$P($G(^PRC(442,PRCHPO,23)),U,7) W $C(7),!!?3,"The substation on this 2237 does not match the substation entered",!?3,"on this "_$S($D(PRCHNRQ):"requisition.",1:"purchase order."),! S EN=1 35 D SPRMK^PRCHNPO6 36 ; 37 N Q:'PRCHSZ K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 38 W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX) 39 F Q:'$F(PRCHX,",,") S PRCHX=$P(PRCHX,",,",1)_","_$P(PRCHX,",,",2,99) ; *112 remove consecutive commas 40 S:$E(PRCHX)="," PRCHX=$E(PRCHX,2,$L(PRCHX)) ; *112 remove leading comma 41 S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) ; *112 remove trailing comma 42 F I=1:1 S X=$P(PRCHX,",",I) Q:X="" I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)<X(2)) PRCHX Q:'$D(PRCHX) S $P(PRCHX,",",I)=X(1)_":1:"_X(2) 43 I '$D(PRCHX) W " ??",$C(7) G N 44 X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J 45 ; 46 3 G 2:J=+^PRCS(410,PRCHSY,10),Q:'$O(^TMP($J,"PRCHS",0)) W !,"A new 2237 will now be created with the following items: " F K=0:0 S K=$O(PRCHSIT(K)) Q:'K W !?3,PRCHSIT(K) 47 S %A=" Do you wish to proceed",%B="",%=1 D ^PRCFYN I %'=1 G N 48 Q:$D(PRCHG) S PRCHSIT=J,PRCHS=PRCHSY D WAIT^DICD,^PRCHSP D:PRCHSY=-1 ERR D:PRCHSY=-3 ERR1 D:PRCHSY=-2 ERR2 G:PRCHSY<0 EN D EN4^PRCHNPO2 49 G EN 50 ; 51 1 S I=0 F S I=$O(^PRCS(410,PRCHSY,"IT","AB",I)) Q:I="" D IT 52 S:$O(^TMP($J,"PRCHS",0)) ^(0)=J 53 G 3 54 ; 55 2 Q:$D(PRCHG) S PRCHSIT=J,PRCHS="" D WAIT^DICD,^PRCHSP1 56 D:PRCHSY=-1 ERR 57 D:PRCHSY=-2 ERR2 58 D:PRCHSY=-3 ERR1 59 G:PRCHSY<0 EN 60 D EN4^PRCHNPO2 61 G EN 62 ; 63 IT I $D(^PRCS(410,PRCHSY,"IT","AB",I)),$D(^PRCS(410,PRCHSY,"IT",$O(^(I,0)),0)) S ^TMP($J,"PRCHS",I)="",J=J+1 S:$L(PRCHSIT(K))>72 K=K+1,PRCHSIT(K)="" S PRCHSIT(K)=PRCHSIT(K)_I_"," Q 64 W !?5,"** ",I," IS AN INVALID LINE ITEM NUMBER",$C(7) K ^TMP($J,"PRCHS") 65 Q 66 ; 67 HLP W !?3,"ENTER A LINE ITEM NUMBER IN THE FOLLOWING FORMAT: 1,2,3,4 OR 1:4 ",!?5," OR ENTER 'A' FOR ALL LINE ITEMS " S DIC="^PRCS(410,+PRCHSY,""IT"",",DIC(0)="E",X="??",D="AB" D IX^DIC K DIC G N 68 Q 69 ; 70 Q S (DA,D0)=PRCHPO K C,DIC,X,PRCH,PRCHD,PRCHS,PRCHSP,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHSZ,PRCHX,^TMP($J,"PRCHS"),EN,Y 71 S:0 Y="@1" ;<<< Removed the SET Y="@1" from this routine and put it into the template PRCH2138. <<< 72 Q 73 ; 74 DT S X="T" D ^%DT S DT=Y 75 Q 76 ; 77 EN2 ;CHECKS FCP PARAMETERS & SET Y, CALLED FROM PRCH2138,PRCHIFREG 78 S PRCHN("SFC")=+$P(^PRC(442,DA,0),"^",19) 79 S $P(^PRC(442,DA,18),U,2)=$S((PRCHN("SFC")=2)&(PRCHN("MP")=12):"B",PRCHN("SFC")=2:"A",PRCHN("SFC")=3:"J",1:"") 80 Q 81 ; 82 ERR W !,$C(7),"Cannot get a transaction number at this time for the new transaction being split",!,"out. Try again later!" 83 Q 84 ; 85 ERR1 W !,$C(7),"Cannot find the 2237 you selected in file 410." 86 Q 87 ; 88 ERR2 W !,$C(7),"Not continuing with this 2237." 89 Q 90 ; 91 VENMSG ;message to alert users that vendors don't match and that IMF will 92 ;be updated. 93 W !!,"NOTE-Vendors on PO and 2237 don't match. If you proceed IMF info"," will be used. If there is no IMF entry for the item for this vendor one will ","be created." 94 N % S %=0 95 W !,"Would you like to proceed" D YN^DICN W !! I %'=1 S PRCHFLG=1 96 Q 1 PRCHNPO3 ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm 2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 S PRCHSZ=1 6 ; 7 EN0 W !,"Enter a 2237 reference number. The FCP,Cost Center,Service,Delivery",!?3,"Location" W:PRCHSZ " and Line Items" W " will be transferred into this Purchase Order." 8 W !!,?10,"The 2237 Fiscal Year and Quarter must be earlier or same",!,?10,"as the P.O. Date Fiscal Year and Quarter.",! 9 I $O(^PRC(442,PRCHPO,13,0)) W !?3,"This Purchase Order already contains:" F I=0:0 S I=$O(^PRC(442,PRCHPO,13,I)) Q:'I I $D(^PRCS(410,I,0)) W !?3,$P(^(0),U,1) 10 I '$D(^PRC(442,PRCHPO,1)),$P(^(1),U,15)="" W !!,"Cannot precede without a P.O. DATE" G Q 11 ; 12 EN K PRCHSY S PRCHD=$P(^PRC(442,PRCHPO,1),U,15),PRCHSP=$P(^(0),U,12) 13 ;screen-out the Issue Book order if status is 65--Assigned to PPM Clerk, for nois MWV-0293-20011 14 S DIC="^PRC(443," 15 S DIC(0)="AQEMZ" 16 I $G(PRCHZZZ9)'=1 S DIC("S")="I $P(^(0),U,3)]"""",""65,72""'[$P(^(0),U,7),$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" 17 I $G(PRCHZZZ9)=1 S DIC("S")="I $P(^(0),U,3)]"""",$P(^(0),U,7)=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6" 18 D ^DIC K DIC G:Y<0 Q S PRCHSY=+Y,PRCHSY(0)=Y(0),Y(0)=^PRCS(410,+Y,0),PRCHSX=$P(Y(0),U,1) I $D(^(1)),$P(^(1),U,3)="EM" W $C(7),!,"*** EMERGENCY ***" 19 ;I $D(^PRCS(410,+Y,0)),$P(^(0),U,4)=5 W !?3,"This is an Issue Book Order, and it can't be processed into a Purchase Order." Q 20 ; 21 EN1 S PRCHRFQT=$$DATE^PRC0C($P(Y(0),"^",11),"I"),PRCHRFQT=$P(PRCHRFQT,U,1,2) 22 S PRC("BBFY")=+$$DATE^PRC0C($P(^PRCS(410,+Y,3),"^",11),"I") 23 ;S PRCHCFQT=$$DATE^PRC0C($P(^PRC(420,PRC("SITE"),0),U,9),"I"),PRCHCFQT=$P(PRCHCFQT,U,1,2) 24 S PRCHPFQT=$$DATE^PRC0C($P(^PRC(442,PRCHPO,1),"^",15),"I"),PRCHPFQT=$P(PRCHPFQT,U,1,2) 25 I PRCHRFQT'=PRCHPFQT W !,?10,"The Fiscal Year and Quarter on this 2237 is not",!,?10,"compatible with the PO Date.",!,$C(7) K PRCHRFQT,PRCHPFQT G EN 26 K PRCHRFQT,PRCHPFQT 27 I $P(^PRC(442,PRCHPO,0),U,3)]"",+$P(^PRC(442,PRCHPO,0),U,3)'=+$P(^PRCS(410,PRCHSY,3),U,1) W !?3,"Fund Control Point for this 2237 doesn't match the existing FCP in P.O.",$C(7) G EN 28 I $P(^PRC(442,PRCHPO,0),U,5)]"",+$P(^PRC(442,PRCHPO,0),U,5)'=+$P(^PRCS(410,PRCHSY,3),U,3) W !?3,"Cost Center for this 2237 doesn't match the Cost Center in P.O.",$C(7) G EN 29 S X="",Z="" I $D(^PRC(420,PRC("SITE"),1,+^PRCS(410,PRCHSY,3),0)) S X=$P(^(0),U,12),Z=$P(^(0),U,18) 30 I X'=2 S:Z'="" $P(^PRC(442,PRCHPO,17),U,1)=$E(Z,1,3) I Z="" W $C(7),!?3,"Fund Control point is missing LOG Department Number!!" G EN 31 I X I PRCHN("MP")=4!((X=3)&(PRCHN("MP")=3)) S Y=$P(^PRCD(442.5,PRCHN("MP"),0),U,1) W $C(7),!?3,"This Fund Control Point is not valid for a "_Y_" order." G EN 32 S EN=0 I $D(^PRC(411,"UP",PRC("SITE"))) D G EN:EN=1 33 .I $P($G(^PRCS(410,+Y,0)),U,10)="" W $C(7),!!?3,"This 2237 does not have a substation.",! S EN=1 Q 34 .I $P($G(^PRCS(410,+Y,0)),U,10)'=$P($G(^PRC(442,PRCHPO,23)),U,7) W $C(7),!!?3,"The substation on this 2237 does not match the substation entered",!?3,"on this "_$S($D(PRCHNRQ):"requisition.",1:"purchase order."),! S EN=1 35 D SPRMK^PRCHNPO6 36 ; 37 N Q:'PRCHSZ K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX) 38 F I=1:1 S X=$P(PRCHX,",",I) Q:X="" I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)<X(2)) PRCHX Q:'$D(PRCHX) S $P(PRCHX,",",I)=X(1)_":1:"_X(2) 39 I '$D(PRCHX) W " ??",$C(7) G N 40 S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J 41 ; 42 3 G 2:J=+^PRCS(410,PRCHSY,10),Q:'$O(^TMP($J,"PRCHS",0)) W !,"A new 2237 will now be created with the following items: " F K=0:0 S K=$O(PRCHSIT(K)) Q:'K W !?3,PRCHSIT(K) 43 S %A=" Do you wish to proceed",%B="",%=1 D ^PRCFYN I %'=1 G N 44 Q:$D(PRCHG) S PRCHSIT=J,PRCHS=PRCHSY D WAIT^DICD,^PRCHSP D:PRCHSY=-1 ERR D:PRCHSY=-3 ERR1 D:PRCHSY=-2 ERR2 G:PRCHSY<0 EN D EN4^PRCHNPO2 45 G EN 46 ; 47 1 S I=0 F S I=$O(^PRCS(410,PRCHSY,"IT","AB",I)) Q:I="" D IT 48 S:$O(^TMP($J,"PRCHS",0)) ^(0)=J 49 G 3 50 ; 51 2 Q:$D(PRCHG) S PRCHSIT=J,PRCHS="" D WAIT^DICD,^PRCHSP1 52 D:PRCHSY=-1 ERR 53 D:PRCHSY=-2 ERR2 54 D:PRCHSY=-3 ERR1 55 G:PRCHSY<0 EN 56 D EN4^PRCHNPO2 57 G EN 58 ; 59 IT I $D(^PRCS(410,PRCHSY,"IT","AB",I)),$D(^PRCS(410,PRCHSY,"IT",$O(^(I,0)),0)) S ^TMP($J,"PRCHS",I)="",J=J+1 S:$L(PRCHSIT(K))>72 K=K+1,PRCHSIT(K)="" S PRCHSIT(K)=PRCHSIT(K)_I_"," Q 60 W !?5,"** ",I," IS AN INVALID LINE ITEM NUMBER",$C(7) K ^TMP($J,"PRCHS") 61 Q 62 ; 63 HLP W !?3,"ENTER A LINE ITEM NUMBER IN THE FOLLOWING FORMAT: 1,2,3,4 OR 1:4 ",!?5," OR ENTER 'A' FOR ALL LINE ITEMS " S DIC="^PRCS(410,+PRCHSY,""IT"",",DIC(0)="E",X="??",D="AB" D IX^DIC K DIC G N 64 Q 65 ; 66 Q S (DA,D0)=PRCHPO K C,DIC,X,PRCH,PRCHD,PRCHS,PRCHSP,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHSZ,PRCHX,^TMP($J,"PRCHS"),EN,Y 67 S:0 Y="@1" ;<<< Removed the SET Y="@1" from this routine and put it into the template PRCH2138. <<< 68 Q 69 ; 70 DT S X="T" D ^%DT S DT=Y 71 Q 72 ; 73 EN2 ;CHECKS FCP PARAMETERS & SET Y, CALLED FROM PRCH2138,PRCHIFREG 74 S PRCHN("SFC")=+$P(^PRC(442,DA,0),"^",19) 75 S $P(^PRC(442,DA,18),U,2)=$S((PRCHN("SFC")=2)&(PRCHN("MP")=12):"B",PRCHN("SFC")=2:"A",PRCHN("SFC")=3:"J",1:"") 76 Q 77 ; 78 ERR W !,$C(7),"Cannot get a transaction number at this time for the new transaction being split",!,"out. Try again later!" 79 Q 80 ; 81 ERR1 W !,$C(7),"Cannot find the 2237 you selected in file 410." 82 Q 83 ; 84 ERR2 W !,$C(7),"Not continuing with this 2237." 85 Q 86 ; 87 VENMSG ;mesasge to alert users that vendors don't match and that IMF will 88 ;be updated. 89 W !!,"NOTE-Vendors on PO and 2237 don't match. If you proceed IMF info"," will be used. If there is no IMF entry for the item for this vendor one will ","be created." 90 N % S %=0 91 W !,"Would you like to proceed" D YN^DICN W !! I %'=1 S PRCHFLG=1 92 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m
r613 r623 1 PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;9/5/00 10:59 2 V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 EN1 ;FILE 442, FCP #1 6 I '$D(PRCHAMND),$D(^PRCS(410,+$P(^PRC(442,DA,0),U,12),0)),+$P(^(0),"-",4)'=+X W !,"Fund Control Point cannot be changed since 2237 has been selected." K X Q 7 S Z0=$E($P(^PRC(442,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q 8 S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ" 9 S:$D(PRCHPUSH) DIC("S")="I $P(^(0),U,12)=2" 10 I $G(PRCHPC)!$G(PRCHDELV) S DIC("S")="I $D(^PRC(420,""C"",DUZ,PRC(""SITE""),+Y))" 11 S D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,PRCHCPO,Z0,Z1 Q:'$D(X) 12 N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",!,$P(Y,U,2) K X Q 13 I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q 14 S Z0=$P(^PRC(442,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I ((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q 15 S Z0=$P(Y(0),U,1),PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) 16 I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) 17 S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q 18 S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 19 I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q 20 Q 21 ; 22 EN2 ;FILE 442, COST CENTER #2 23 S PRCFA("ALL")=1,DIC="^PRCD(420.1,",DIC(0)="QEMZ" D ^DIC K DIC,PRCFA("ALL") I Y'>0 W !,"The Cost Center entered by you is not in the COST CENTER FILE.",! K X,Y,Z0 Q 24 I $P(Y(0),U,2)=1 W !,"The Cost Center entered by you has been DEACTIVATED.",! K X,Y,Z0 Q 25 S X=+Y(0) 26 S Z1=$G(^PRC(420,PRC("SITE"),1,Z0,2,+Y(0),0)) I Z1'>0!(Z1="") W !,"This Cost Center isn't found in FCP "_$P(^PRC(420,PRC("SITE"),1,Z0,0),U,1)_".",! K X,Y,Z0,Z1 Q 27 N BOCNOD S BOCNOD=$G(^PRCD(420.1,+Y,1,0)) I $P(BOCNOD,U,4)'>0!(BOCNOD="") W !,"The Cost Center selected by you, does not have any BOCs listed",!,"under it.",! K X 28 K Y,Z0,Z1 Q 29 ; 30 EN3 ;FILE 442, VENDOR #5 31 N REP,REP1 32 I DIE["PRC(442,",$D(DA),$D(^PRC(442,DA,2,"AE")) K X 33 Q:'$D(X)!$G(PRCHPC) 34 I '$G(PRCHDELV) D Q:'$G(X) 35 . S DIC("S")="S Z0=+$P($G(^(2)),U,2) I "_$E("'",'$D(PRCHNRQ))_"Z0,'$D(^PRC(440,""AC"",""S"",Y))" I $D(PRCHPUSH) S DIC("S")=DIC("S")_",(Z0=1!(Z0=3))" 36 . D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q:'$D(X) S PRCHNVF=Y 37 Q:'$D(^PRC(440,X,2)) S Z0=^(2) I $P(^PRC(442,DA,0),U,2)=4,$P(Z0,U,11)'="Y" W $C(7),!,"This Vendor is not set up as a GUARANTEED DELIVERY Vendor!." K X,Z0 Q 38 ; 39 ; SEE IF VENDOR IS INACTIVE. 40 ; 41 I $P($G(^PRC(440,X,10)),U,5)=1 K X Q 42 ; 43 ; 44 ; 45 K PRCHEDI I $P($G(^PRC(440,X,3)),U,2)="Y" S PRCHEDI="" ;CHECK FOR EDI VENDOR 46 I $D(^PRCD(420.8,+$P(Z0,U,2),0)) S PRCHN("SC")=$P(^(0),U,1) 47 K Z0 48 Q 49 ; 50 EN4 ;FILE 442, EST. SHIPPING AND/OR HANDLING #13 51 S %A=" FOB is Destination, Are you sure you want Handling Charges ",%B="",%=1 D ^PRCFYN I %'=1 K X W !?3,"<DELETED>",$C(7) 52 Q 53 ; 54 EN5 ;FILE 442, REPETITIVE (PR CARD) NO. #1.5 55 I $P(^PRC(442,DA(1),0),U,3)=""!($P(^(1),U,1)="") W !!,"Fund Control Point and Vendor must be entered before items !",$C(7) K X Q 56 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) D LCK^PRCHCRD 57 Q 58 ; 59 EN6 ;FILE 442, UNIT OF PURCHASE #3 60 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 61 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN0^PRCHCRD 62 Q 63 ; 64 EN8 ;FILE 442, CONTRACT FIELD #4 65 D VEN Q:'$D(X) K DIC("S") 66 S Z0=$P(^PRC(442,DA(1),1),U,1),ZA=DA,ZA(1)=DA(1) 67 S DA(1)=Z0,DIC="^PRC(440,Z0,4,",DIC(0)="QELMZ",DLAYGO=440 68 I $G(PRCHPC)!$G(PRCHDELV) S DIC(0)="QEMZ" 69 D EN10,^DIC S X=$P(Y,U,2),DA=ZA,DA(1)=ZA(1) K ZA K:Y'>0 X 70 I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X,DLAYGO Q 71 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) I $P(^PRC(442,DA(1),2,DA,0),U,5)]"" S PRCHCI=$P(^(0),U,5),PRCHCV=Z0,PRCHCPO=DA(1) D EN2^PRCHCRD 72 K DLAYGO 73 Q 74 ; 75 EN9 ;FILE 442, ACTUAL UNIT COST #5 76 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 77 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN1^PRCHCRD 78 Q 79 ; 80 EN10 ;FILE 440 CONTRACT NUMBER 81 I $D(Z0) S:'$D(^PRC(440,Z0,4,0)) ^PRC(440,Z0,4,0)="^440.03I^^" 82 Q 83 ; 84 EN11 ;FILE 441 CONTRACT 85 D EN10 S DIC="^PRC(440,Z0,4,",DIC(0)="QEMLZ",DLAYGO=440,ZD=DA(1),DA(1)=Z0 D ^DIC S X=+Y K:Y'>0 X S DA(1)=ZD K ZD,Z0,DIC 86 I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X 87 K DLAYGO 88 Q 89 ; 90 EN12 ;FILE 442, VENDOR STOCK NO.#9 91 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 92 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN6^PRCHCRD 93 Q 94 ; 95 EN13 ;DIC("S") for a look-up in CONTRACT field (File 442.01,4) 96 S PRCHSCOD=$P($G(^PRC(442,D0,1)),U,7) 97 I $E(X)="?" S DIC("S")=$S(PRCHSCOD=2:"I $P(^PRC(440,Z0,4,+Y,0),U,6)'=""B""",1:"I 1") 98 Q 99 ; 100 EN14 ;input transform of Contract Flag field 5, file 440 101 ;If PO exists, if source code=2 & contract flag is not 'C' set it 'C' 102 I $G(PRCHPO)>0 D 103 . S PRCHNOD1=$G(^PRC(442,PRCHPO,1)) 104 . S PRCHSOCO=$P(PRCHNOD1,U,7) 105 . I PRCHSOCO=2 Q:X="C" D Q 106 . . S X="C" 107 . . S ARR(1)="" 108 . . S ARR(2)=" Note: " 109 . . S ARR(3)=" This PO's Source Code is Open Market, only Contract # is a valid entry." 110 . . S ARR(4)=" 'C' has been entered for the Contract Flag prompt." 111 . . S ARR(5)=" 'B' is not allowed, system allows only 'C'." 112 . . S ARR(6)="" 113 . . D EN^DDIOL(.ARR) 114 . . S XQH="PRCH CONTRACT FLAG HELP" D:$E(X)="??" EN^XQH 115 . . Q 116 . Q 117 ; If Source code is not equal to 2, C or B is ok for contr. flag 118 S MSG(1)="" 119 S MSG(2)="Enter 'C' if the Contract Number field is a Contract #." 120 S MSG(2,"F")="!,?5" 121 S MSG(3)="Otherwise enter 'B' if it is a Basic Ordering Agreement(BOA) #." 122 S MSG(3,"F")="!,?5" 123 S MSG(4)="" 124 ;I PRCHSOCO'=2 D EN^DDIOL(.MSG) H 2 125 ;any other route than via po 126 I X="B" D 127 . S Z=$P(^PRC(440,DA(1),4,DA,0),U) 128 . K:'(Z?.UN) X 129 . I '$D(X) S XQH="PRCH BOA" D EN^XQH 130 . K Z,XQH 131 . Q 132 Q 133 ; 134 VEN I $S('$D(^PRC(442,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X 135 Q 1 PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;9/5/00 10:59 2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 EN1 ;FILE 442, FCP #1 6 I '$D(PRCHAMND),$D(^PRCS(410,+$P(^PRC(442,DA,0),U,12),0)),+$P(^(0),"-",4)'=+X W !,"Fund Control Point cannot be changed since 2237 has been selected." K X Q 7 S Z0=$E($P(^PRC(442,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q 8 S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ" 9 S:$D(PRCHPUSH) DIC("S")="I $P(^(0),U,12)=2" 10 I $G(PRCHPC)!$G(PRCHDELV) S DIC("S")="I $D(^PRC(420,""C"",DUZ,PRC(""SITE""),+Y))" 11 S D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,PRCHCPO,Z0,Z1 Q:'$D(X) 12 N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",!,$P(Y,U,2) K X Q 13 I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q 14 S Z0=$P(^PRC(442,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I ((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q 15 S Z0=$P(Y(0),U,1),PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) 16 I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) 17 S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q 18 S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 19 Q 20 ; 21 EN2 ;FILE 442, COST CENTER #2 22 S PRCFA("ALL")=1,DIC="^PRCD(420.1,",DIC(0)="QEMZ" D ^DIC K DIC,PRCFA("ALL") I Y'>0 W !,"The Cost Center entered by you is not in the COST CENTER FILE.",! K X,Y,Z0 Q 23 I $P(Y(0),U,2)=1 W !,"The Cost Center entered by you has been DEACTIVATED.",! K X,Y,Z0 Q 24 S X=+Y(0) 25 S Z1=$G(^PRC(420,PRC("SITE"),1,Z0,2,+Y(0),0)) I Z1'>0!(Z1="") W !,"This Cost Center isn't found in FCP "_$P(^PRC(420,PRC("SITE"),1,Z0,0),U,1)_".",! K X,Y,Z0,Z1 Q 26 N BOCNOD S BOCNOD=$G(^PRCD(420.1,+Y,1,0)) I $P(BOCNOD,U,4)'>0!(BOCNOD="") W !,"The Cost Center selected by you, does not have any BOCs listed",!,"under it.",! K X 27 K Y,Z0,Z1 Q 28 ; 29 EN3 ;FILE 442, VENDOR #5 30 N REP,REP1 31 I DIE["PRC(442,",$D(DA),$D(^PRC(442,DA,2,"AE")) K X 32 Q:'$D(X)!$G(PRCHPC) 33 I '$G(PRCHDELV) D Q:'$G(X) 34 . S DIC("S")="S Z0=+$P($G(^(2)),U,2) I "_$E("'",'$D(PRCHNRQ))_"Z0,'$D(^PRC(440,""AC"",""S"",Y))" I $D(PRCHPUSH) S DIC("S")=DIC("S")_",(Z0=1!(Z0=3))" 35 . D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q:'$D(X) S PRCHNVF=Y 36 Q:'$D(^PRC(440,X,2)) S Z0=^(2) I $P(^PRC(442,DA,0),U,2)=4,$P(Z0,U,11)'="Y" W $C(7),!,"This Vendor is not set up as a GUARANTEED DELIVERY Vendor!." K X,Z0 Q 37 ; 38 ; SEE IF VENDOR IS INACTIVE. 39 ; 40 I $P($G(^PRC(440,X,10)),U,5)=1 K X Q 41 ; 42 ; 43 ; 44 K PRCHEDI I $P($G(^PRC(440,X,3)),U,2)="Y" S PRCHEDI="" ;CHECK FOR EDI VENDOR 45 I $D(^PRCD(420.8,+$P(Z0,U,2),0)) S PRCHN("SC")=$P(^(0),U,1) 46 K Z0 47 Q 48 ; 49 EN4 ;FILE 442, EST. SHIPPING AND/OR HANDLING #13 50 S %A=" FOB is Destination, Are you sure you want Handling Charges ",%B="",%=1 D ^PRCFYN I %'=1 K X W !?3,"<DELETED>",$C(7) 51 Q 52 ; 53 EN5 ;FILE 442, REPETITIVE (PR CARD) NO. #1.5 54 I $P(^PRC(442,DA(1),0),U,3)=""!($P(^(1),U,1)="") W !!,"Fund Control Point and Vendor must be entered before items !",$C(7) K X Q 55 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) D LCK^PRCHCRD 56 Q 57 ; 58 EN6 ;FILE 442, UNIT OF PURCHASE #3 59 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 60 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN0^PRCHCRD 61 Q 62 ; 63 EN8 ;FILE 442, CONTRACT FIELD #4 64 D VEN Q:'$D(X) K DIC("S") 65 S Z0=$P(^PRC(442,DA(1),1),U,1),ZA=DA,ZA(1)=DA(1) 66 S DA(1)=Z0,DIC="^PRC(440,Z0,4,",DIC(0)="QELMZ",DLAYGO=440 67 I $G(PRCHPC)!$G(PRCHDELV) S DIC(0)="QEMZ" 68 D EN10,^DIC S X=$P(Y,U,2),DA=ZA,DA(1)=ZA(1) K ZA K:Y'>0 X 69 I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X,DLAYGO Q 70 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) I $P(^PRC(442,DA(1),2,DA,0),U,5)]"" S PRCHCI=$P(^(0),U,5),PRCHCV=Z0,PRCHCPO=DA(1) D EN2^PRCHCRD 71 K DLAYGO 72 Q 73 ; 74 EN9 ;FILE 442, ACTUAL UNIT COST #5 75 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 76 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN1^PRCHCRD 77 Q 78 ; 79 EN10 ;FILE 440 CONTRACT NUMBER 80 I $D(Z0) S:'$D(^PRC(440,Z0,4,0)) ^PRC(440,Z0,4,0)="^440.03I^^" 81 Q 82 ; 83 EN11 ;FILE 441 CONTRACT 84 D EN10 S DIC="^PRC(440,Z0,4,",DIC(0)="QEMLZ",DLAYGO=440,ZD=DA(1),DA(1)=Z0 D ^DIC S X=+Y K:Y'>0 X S DA(1)=ZD K ZD,Z0,DIC 85 I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X 86 K DLAYGO 87 Q 88 ; 89 EN12 ;FILE 442, VENDOR STOCK NO.#9 90 D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 91 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN6^PRCHCRD 92 Q 93 ; 94 EN13 ;DIC("S") for a look-up in CONTRACT field (File 442.01,4) 95 S PRCHSCOD=$P($G(^PRC(442,D0,1)),U,7) 96 I $E(X)="?" S DIC("S")=$S(PRCHSCOD=2:"I $P(^PRC(440,Z0,4,+Y,0),U,6)'=""B""",1:"I 1") 97 Q 98 ; 99 EN14 ;input transform of Contract Flag field 5, file 440 100 ;If PO exists, if source code=2 & contract flag is not 'C' set it 'C' 101 I $G(PRCHPO)>0 D 102 . S PRCHNOD1=$G(^PRC(442,PRCHPO,1)) 103 . S PRCHSOCO=$P(PRCHNOD1,U,7) 104 . I PRCHSOCO=2 Q:X="C" D Q 105 . . S X="C" 106 . . S ARR(1)="" 107 . . S ARR(2)=" Note: " 108 . . S ARR(3)=" This PO's Source Code is Open Market, only Contract # is a valid entry." 109 . . S ARR(4)=" 'C' has been entered for the Contract Flag prompt." 110 . . S ARR(5)=" 'B' is not allowed, system allows only 'C'." 111 . . S ARR(6)="" 112 . . D EN^DDIOL(.ARR) 113 . . S XQH="PRCH CONTRACT FLAG HELP" D:$E(X)="??" EN^XQH 114 . . Q 115 . Q 116 ; If Source code is not equal to 2, C or B is ok for contr. flag 117 S MSG(1)="" 118 S MSG(2)="Enter 'C' if the Contract Number field is a Contract #." 119 S MSG(2,"F")="!,?5" 120 S MSG(3)="Otherwise enter 'B' if it is a Basic Ordering Agreement(BOA) #." 121 S MSG(3,"F")="!,?5" 122 S MSG(4)="" 123 ;I PRCHSOCO'=2 D EN^DDIOL(.MSG) H 2 124 ;any other route than via po 125 I X="B" D 126 . S Z=$P(^PRC(440,DA(1),4,DA,0),U) 127 . K:'(Z?.UN) X 128 . I '$D(X) S XQH="PRCH BOA" D EN^XQH 129 . K Z,XQH 130 . Q 131 Q 132 ; 133 VEN I $S('$D(^PRC(442,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X 134 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m
r613 r623 1 PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00 12:30 2 V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 EN1 ;FILE 443.6, FCP #1 6 N Y 7 S Z0=$E($P(^PRC(443.6,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q 8 S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ",D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,Z0,Z1 Q:'$D(X) 9 N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",! K X Q 10 I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q 11 S Z0=$P(^PRC(443.6,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I Z0=4!((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q 12 S Z0=$P(Y(0),U,1) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) 13 S PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) 14 I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) 15 S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q 16 S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 17 I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q 18 Q 19 ; 20 EN2 ;UPDATE BOC #3.5 21 D VEN^PRCHNPO7 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 22 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) 23 S PRCHCV=$P(^PRC(442,DA(1),1),U),PRCHCI=$P(^(2,DA,0),U,5) 24 D EN13^PRCHCRD1 25 Q 26 ; 27 BBFY(PO) ;BEGINING BUDGET FISCAL YEAR CHECK/UPDATE 28 ; ENTERED: 29 ; PO = FILE 442 INTERNAL RECORD NUMBER 30 ; 31 ; RETURNED: 32 ; PRC("BBFY") = FOUR DIGIT YEAR (1995) 33 ; 34 ; PO IS UNCHANGED BY THIS CALL 35 ; 36 N BBFY,N0,N1,FY,P2237,SFCP,DIE,DA,DR,X,FLAG 37 S N0=$G(^PRC(442,PO,0)),N1=$G(^PRC(442,PO,1)) 38 S FY=$P(N1,U,15),FY=$E(100+$E(FY,2,3)+$E(FY,4),2,3) 39 S FLAG="",P2237=$P(N0,U,12) I P2237>0 D G:FLAG=1 T1 40 .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",3,11) 41 .I FY?2N S FY=1700+$E(FY,1,3),PRC("BBFY")=FY,FLAG=1 Q 42 .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",0,1) 43 .S FY=$P(FY,"-",2) 44 .Q 45 S FY=$$BBFY^PRCSUT(+N0,FY,+$P(N0,U,3),1) 46 T1 S SFCP=$P(N0,U,19) I SFCP=1!(SFCP=2) S (PRC("BBFY"),FY)=1994 47 I FY?2N S DIE="^PRC(442,",DA=PO,DR="26///^S X=FY" D ^DIE 48 Q 1 PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00 12:30 2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 EN1 ;FILE 443.6, FCP #1 6 N Y 7 S Z0=$E($P(^PRC(443.6,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q 8 S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ",D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,Z0,Z1 Q:'$D(X) 9 N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",! K X Q 10 I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q 11 S Z0=$P(^PRC(443.6,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I Z0=4!((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q 12 S Z0=$P(Y(0),U,1) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1) 13 S PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) 14 I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1) 15 S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q 16 S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1 17 Q 18 ; 19 EN2 ;UPDATE BOC #3.5 20 D VEN^PRCHNPO7 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="") 21 S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) 22 S PRCHCV=$P(^PRC(442,DA(1),1),U),PRCHCI=$P(^(2,DA,0),U,5) 23 D EN13^PRCHCRD1 24 Q 25 ; 26 BBFY(PO) ;BEGINING BUDGET FISCAL YEAR CHECK/UPDATE 27 ; ENTERED: 28 ; PO = FILE 442 INTERNAL RECORD NUMBER 29 ; 30 ; RETURNED: 31 ; PRC("BBFY") = FOUR DIGIT YEAR (1995) 32 ; 33 ; PO IS UNCHANGED BY THIS CALL 34 ; 35 N BBFY,N0,N1,FY,P2237,SFCP,DIE,DA,DR,X,FLAG 36 S N0=$G(^PRC(442,PO,0)),N1=$G(^PRC(442,PO,1)) 37 S FY=$P(N1,U,15),FY=$E(100+$E(FY,2,3)+$E(FY,4),2,3) 38 S FLAG="",P2237=$P(N0,U,12) I P2237>0 D G:FLAG=1 T1 39 .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",3,11) 40 .I FY?2N S FY=1700+$E(FY,1,3),PRC("BBFY")=FY,FLAG=1 Q 41 .S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",0,1) 42 .S FY=$P(FY,"-",2) 43 .Q 44 S FY=$$BBFY^PRCSUT(+N0,FY,+$P(N0,U,3),1) 45 T1 S SFCP=$P(N0,U,19) I SFCP=1!(SFCP=2) S (PRC("BBFY"),FY)=1994 46 I FY?2N S DIE="^PRC(442,",DA=PO,DR="26///^S X=FY" D ^DIE 47 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m
r613 r623 1 PRCHPCAR ;WISC/AKS-Front End questions for Purchase Card processes ;6/9/96 21:40 2 ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ASKPO ;Ask If they are processing a purchase or a requisition 5 N DIR,Y,PRCHPR,PRCHNE 6 S DIR(0)="SO^P:PURCHASE ORDER;R:REQUISITION" 7 S DIR("A")="Select THE TYPE OF ORDER" 8 D ^DIR Q:Y']""!(Y["^") S PRCHPR=Y 9 ENTED ;Ask if they are entering or editting 10 S DIR(0)="SO^N:NEW;E:EDIT AN EXISTING ORDER" 11 S DIR("A")="Select TYPE OF PROCESSING" 12 D ^DIR G:Y']"" ASKPO Q:Y["^" S PRCHNE=Y 13 I $G(PRCHPR)="P"&(PRCHNE="N") D EN5^PRCHE Q 14 I $G(PRCHPR)="P"&(PRCHNE="E") D EN6^PRCHE Q 15 I $G(PRCHPR)="R"&(PRCHNE="N") D EN3^PRCHEA Q 16 I $G(PRCHPR)="R"&(PRCHNE="E") D EN4^PRCHEA Q 17 I '$D(PRCHPR)&(PRCHNE="N") D EN5^PRCHE Q 18 I '$D(PRCHPR)&(PRCHNE="E") D EN6^PRCHE Q 19 QUIT 20 AMPO ;ask if they are amending a po or a requisition 21 N DIR,Y 22 S DIR(0)="SO^P:AMEND A PURCHASE ORDER;R:AMEND A REQUISITION" 23 S DIR("A")="Select THE TYPE OF ORDER" 24 D ^DIR 25 I Y="P" D PO^PRCHMA Q 26 I Y="R" D REQ^PRCHMA Q 27 QUIT 28 ADJPO ;ask if they are adjusting a po or requisition 29 N DIR,Y 30 S DIR(0)="SO^P:Adjustment Voucher to a PO;R:Adjustment Voucher to a Requisition" 31 S DIR("A")="Select THE TYPE OF ORDER" 32 D ^DIR 33 I Y="P" D EN14^PRCHE Q 34 I Y="R" D EN2^PRCHEB Q 35 QUIT 36 DIRPO ;Ask type of amendments for purchase card and delivery orders 37 ; 38 N PRCHTYPE,DIR 39 S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) 40 Q:PRCHTYPE="" 41 S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Edit" 42 S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Add;5:LINE ITEM Delete;6:LINE ITEM Edit;7:F.O.B. Point" 43 S:PRCHTYPE="D" DIR(0)="SO^1:Change VENDOR;2:AUTHORITY Edit;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit;6:F.O.B. Point;7:SHIP TO Edit;8:Edit MAIL INVOICE TO;9:EST. SHIPPING Edit;10:PROMPT PAYMENT Edit" 44 S DIR("A")="Select TYPE OF AMENDMENT NUMBER" 45 D ^DIR 46 I PRCHTYPE="S" S:$G(Y)=4 Y=6 47 I PRCHTYPE="D",$G(Y) S Y=Y+1 48 S Y=$S(Y=1:30,Y=2:31,Y=3:34,Y=4:21,Y=5:22,Y=6:23,Y=7:35,Y=8:20,Y=9:25,Y=10:29,Y=11:33,1:-1) 49 QUIT 50 DIRREQ ;Ask type of amendments for purchase card and delivery orders 51 ; 52 N PRCHTYPE,DIR 53 S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) 54 Q:PRCHTYPE="" 55 S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR" 56 S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit" 57 S:PRCHTYPE="D" DIR(0)="SO^1:Change FEDERAL VENDOR;2:LINE ITEM Add;3:LINE ITEM Delete;4:LINE ITEM Edit;5:SHIP TO Edit;6:Edit MAIL INVOICE TO;7:EST. SHIPPING Edit" 58 S DIR("A")="Select TYPE OF AMENDMENT NUMBER" 59 D ^DIR 60 I PRCHTYPE="D",$G(Y) S Y=Y+1 61 S Y=$S(Y=1:30,Y=2:31,Y=3:21,Y=4:22,Y=5:23,Y=6:20,Y=7:25,Y=8:29,1:-1) 62 QUIT 63 CANPC ;Cancel a purchase card order 64 W ! S DIC="^PRC(442,",DIC(0)="AEQM" 65 S DIC("A")="Select PURCHASE CARD ORDER NUMBER: " 66 S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))" 67 D ^DIC Q:+Y<0 K DIC 68 S %A="Are sure you want to cancel this order",%B="",%=2 69 D ^PRCFYN I %<1!(%=2) K %A,%B,% Q 70 S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR 71 D C2237^PRCH442A 72 K DA,%A,%B,% 73 QUIT 74 CANDO ;Cancel a delivery order 75 W ! S DIC="^PRC(442,",DIC(0)="AEQM" 76 S DIC("A")="Select DELIVERY ORDER NUMBER: " 77 S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(23)),U,11)=""D""" 78 D ^DIC Q:+Y<0 K DIC 79 S %A="Are sure you want to cancel this order",%B="",%=2 80 D ^PRCFYN I %<1!(%=2) K %A,%B,% Q 81 S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR 82 D C2237^PRCH442A 83 K DA,%A,%B,% 84 QUIT 85 AOCANPC ;Approving Official Cancel a purchase card order 86 N DIC,Y,NREC,X 87 W ! S DIC="^PRC(442,",DIC(0)="AEQM" 88 S DIC("A")="Select PURCHASE CARD ORDER NUMBER: " 89 S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))" 90 D ^DIC Q:+Y<0 K DIC 91 S %A="Are sure you want to cancel this order",%B="",%=2 92 D ^PRCFYN I %<1!(%=2) K %A,%B,% Q 93 S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR 94 D C2237^PRCH442A 95 K DA,%A,%B,% 96 QUIT 1 PRCHPCAR ;WISC/AKS-Front End questions for Purchase Card processes ;6/9/96 21:40 2 ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ASKPO ;Ask If they are processing a purchase or a requisition 5 N DIR,Y,PRCHPR,PRCHNE 6 S DIR(0)="SO^P:PURCHASE ORDER;R:REQUISITION" 7 S DIR("A")="Select THE TYPE OF ORDER" 8 D ^DIR Q:Y']""!(Y["^") S PRCHPR=Y 9 ENTED ;Ask if they are entering or editting 10 S DIR(0)="SO^N:NEW;E:EDIT AN EXISTING ORDER" 11 S DIR("A")="Select TYPE OF PROCESSING" 12 D ^DIR G:Y']"" ASKPO Q:Y["^" S PRCHNE=Y 13 I $G(PRCHPR)="P"&(PRCHNE="N") D EN5^PRCHE Q 14 I $G(PRCHPR)="P"&(PRCHNE="E") D EN6^PRCHE Q 15 I $G(PRCHPR)="R"&(PRCHNE="N") D EN3^PRCHEA Q 16 I $G(PRCHPR)="R"&(PRCHNE="E") D EN4^PRCHEA Q 17 I '$D(PRCHPR)&(PRCHNE="N") D EN5^PRCHE Q 18 I '$D(PRCHPR)&(PRCHNE="E") D EN6^PRCHE Q 19 QUIT 20 AMPO ;ask if they are amending a po or a requisition 21 N DIR,Y 22 S DIR(0)="SO^P:AMEND A PURCHASE ORDER;R:AMEND A REQUISITION" 23 S DIR("A")="Select THE TYPE OF ORDER" 24 D ^DIR 25 I Y="P" D PO^PRCHMA Q 26 I Y="R" D REQ^PRCHMA Q 27 QUIT 28 ADJPO ;ask if they are adjusting a po or requisition 29 N DIR,Y 30 S DIR(0)="SO^P:Adjustment Voucher to a PO;R:Adjustment Voucher to a Requisition" 31 S DIR("A")="Select THE TYPE OF ORDER" 32 D ^DIR 33 I Y="P" D EN14^PRCHE Q 34 I Y="R" D EN2^PRCHEB Q 35 QUIT 36 DIRPO ;Ask type of amendments for purchase card and delivery orders 37 ; 38 N PRCHTYPE,DIR 39 S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) 40 Q:PRCHTYPE="" 41 S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Edit" 42 S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change VENDOR;3:AUTHORITY Edit;4:LINE ITEM Add;5:LINE ITEM Delete;6:LINE ITEM Edit;7:F.O.B. Point" 43 S:PRCHTYPE="D" DIR(0)="SO^1:Change VENDOR;2:AUTHORITY Edit;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit;6:F.O.B. Point;7:SHIP TO Edit;8:Edit MAIL INVOICE TO;9:EST. SHIPPING Edit;10:PROMPT PAYMENT Edit" 44 S DIR("A")="Select TYPE OF AMENDMENT NUMBER" 45 D ^DIR 46 I PRCHTYPE="S" S:$G(Y)=4 Y=6 47 I PRCHTYPE="D",$G(Y) S Y=Y+1 48 S Y=$S(Y=1:30,Y=2:31,Y=3:34,Y=4:21,Y=5:22,Y=6:23,Y=7:35,Y=8:20,Y=9:25,Y=10:29,Y=11:33,1:-1) 49 QUIT 50 DIRREQ ;Ask type of amendments for purchase card and delivery orders 51 ; 52 N PRCHTYPE,DIR 53 S PRCHTYPE=$P($G(^PRC(442,PRCHPO,23)),U,11) 54 Q:PRCHTYPE="" 55 S:PRCHTYPE="S" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR" 56 S:PRCHTYPE="P" DIR(0)="SO^1:F.C.P. Edit;2:Change FEDERAL VENDOR;3:LINE ITEM Add;4:LINE ITEM Delete;5:LINE ITEM Edit" 57 S:PRCHTYPE="D" DIR(0)="SO^1:Change FEDERAL VENDOR;2:LINE ITEM Add;3:LINE ITEM Delete;4:LINE ITEM Edit;5:SHIP TO Edit;6:Edit MAIL INVOICE TO;7:EST. SHIPPING Edit" 58 S DIR("A")="Select TYPE OF AMENDMENT NUMBER" 59 D ^DIR 60 I PRCHTYPE="D",$G(Y) S Y=Y+1 61 S Y=$S(Y=1:30,Y=2:31,Y=3:21,Y=4:22,Y=5:23,Y=6:20,Y=7:25,Y=8:29,1:-1) 62 QUIT 63 CANPC ;Cancel a purchase card order 64 W ! S DIC="^PRC(442,",DIC(0)="AEQM" 65 S DIC("A")="Select PURCHASE CARD ORDER NUMBER: " 66 S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))" 67 D ^DIC Q:+Y<0 K DIC 68 S %A="Are sure you want to cancel this order",%B="",%=2 69 D ^PRCFYN I %<1!(%=2) K %A,%B,% Q 70 S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR 71 D C2237^PRCH442A 72 K DA,%A,%B,% 73 QUIT 74 CANDO ;Cancel a delivery order 75 W ! S DIC="^PRC(442,",DIC(0)="AEQM" 76 S DIC("A")="Select DELIVERY ORDER NUMBER: " 77 S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(23)),U,11)=""D""" 78 D ^DIC Q:+Y<0 K DIC 79 S %A="Are sure you want to cancel this order",%B="",%=2 80 D ^PRCFYN I %<1!(%=2) K %A,%B,% Q 81 S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR 82 D C2237^PRCH442A 83 K DA,%A,%B,% 84 QUIT -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m
r613 r623 1 PRCHQ4 2 ;;5.1;IFCAP;**63,114**;Oct 20, 2000;Build 4 3 ;Per VHA Directive 2004-038, this routine should not be modified.4 HE 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 VELST(PRCN) 26 27 28 29 30 31 32 33 34 35 36 37 VE(PRCD,PRCC) 38 39 40 41 42 ST(PRCC) 43 44 45 46 47 48 49 50 51 52 53 54 55 56 STX 57 MI(PRCRFQ,PRCC) 58 59 60 61 62 AC(PRCC) 63 64 65 66 67 TX(PRCN,PRCC) 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 IT(PRCC) 89 90 91 92 93 94 95 96 97 . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,2,PRCA,5)),U,2)98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) 118 119 120 121 122 123 124 125 126 127 DE(PRCN,PRCIT,PRCC) 128 129 130 131 132 133 134 135 136 137 138 DUNERR(PRCA) 139 140 141 142 143 1 PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05 15:27 2 ;;5.1;IFCAP;**63**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 HE ;Set up Heading segment 5 N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y 6 S PRCN0=$G(^PRC(444,PRCDA,0)),PRCN1=$G(^PRC(444,PRCDA,1)) 7 S X=$P(PRCN0,U,2) D JDN^PRCUTL S PRCA="HE^^"_Y_"^^" 8 S X=$P(PRCN1,U,2) D JDN^PRCUTL S PRCA=PRCA_Y_"^" 9 S PRCB=$P(PRCN0,U,3),X=$P(PRCB,".") D JDN^PRCUTL S X=$P(PRCB,".",2) 10 S X=X_$E("000000",$L(X)+1,6),PRCA=PRCA_Y_"^"_X_"^^^^^0^0^0^^^^^|" 11 K DA S DA=$P(PRCN0,U,4) I DA?1.N D 12 . K ^UTILITY("DIQ1",$J) 13 . S DIC=200,DR=".01;.135",DIQ(0)="I" D EN^DIQ1 K DIC,DIQ,DR 14 . S $P(PRCA,"^",8,9)=^UTILITY("DIQ1",$J,200,DA,.01,"I")_"^"_^UTILITY("DIQ1",$J,200,DA,.135,"I") 15 . K ^UTILITY("DIQ1",$J) 16 S ^TMP($J,"STRING",1)=PRCA 17 I $P(PRCA,U,3)'?7N S PRCZ(1)="Invalid RFQ Reference Date" 18 I $P(PRCA,U,5)'?7N S PRCZ(2)="Invalid Requested Delivery Date" 19 I $P(PRCA,U,6)'?7N S PRCZ(3)="Invalid RFQ Bids Due Date" 20 I $P(PRCA,U,7)'?6N S PRCZ(4)="Invalid RFQ Bids Due Time" 21 I $P(PRCA,U,8)="" S PRCZ(5)="Contracting Officer's Name is missing" 22 I $P(PRCA,U,9)="" S PRCZ(6)="Contracting Officer's Commercial Phone # is missing" 23 I $D(PRCZ) S PRCERR=3 D EN^DDIOL(.PRCZ) 24 Q 25 VELST(PRCN) ;Gets list of solicited vendors from RFQ and invokes 'VE' setup 26 N PRCX,PRCY,X,PRCW S PRCX=0,PRCW=0 27 F S PRCX=$O(^PRC(444,PRCDA,5,PRCX)) Q:PRCX'?1.N D 28 . S PRCY=$G(^PRC(444,PRCDA,5,PRCX,0)) Q:PRCY="" 29 . S:$P(PRCY,U,2)="" $P(PRCY,U,2)=$P(^PRC(444,PRCDA,0),U,7),$P(^PRC(444,PRCDA,5,PRCX,0),U,2)=$P(PRCY,U,2) 30 . Q:";b;e;"'[(";"_$P(PRCY,U,2)_";") 31 . S PRCY=$P(PRCY,U) 32 . S X=$S(PRCY["PRC(440,":$P($G(^PRC(440,$P(PRCY,";"),7)),U,12),1:$P($G(^PRC(444.1,$P(PRCY,";"),0)),U,2)) 33 . I X="" D DUNERR(PRCY) Q 34 . D VE(X,.PRCN) S PRCW=PRCW+1 35 I $P($G(^PRC(444,PRCDA,1)),U,8)="y" D VE("PUBLIC",.PRCN) S PRCW=PRCW+1 36 Q PRCW 37 VE(PRCD,PRCC) ;Set up Vendor segment 38 S PRCC=PRCC+1 39 S ^TMP($J,"STRING",PRCC)="VE^"_PRCD_"^^^^^^^^^^^^^^^^^^|" 40 S ^TMP($J,"VE",PRCD)="" 41 Q 42 ST(PRCC) ;Setting up Ship to segment 43 N PRCX,PRCY,DA,DIC,DR 44 S PRCY=$G(^PRC(444,PRCDA,0)),PRCX=$P(PRCY,U,10) 45 S:PRCX="" PRCX=$E($P(PRCY,U),1,3) 46 S PRCY=$P($G(^PRC(444,PRCDA,1)),U,3) Q:PRCY'?1.N 47 S PRCX=$G(^PRC(411,PRCX,1,PRCY,0)) Q:PRCX="" 48 S PRCC=PRCC+1 49 I $P(PRCX,U,9)]"" S ^TMP($J,"STRING",PRCC)="ST^"_$P(PRCX,U,9)_"^^^^^^^^^|" G STX 50 S PRCY="ST^^"_$P(PRCX,U)_"^"_$P(PRCX,U,2)_"^"_$P(PRCX,U,3)_"^"_$P(PRCX,U,4) 51 S PRCY=PRCY_"^^"_$P(PRCX,U,5)_"^^"_$TR($P(PRCX,U,7),"-")_"^|" 52 S DA=$P(PRCX,U,6) I DA?1.N D 53 . K ^UTILITY("DIQ1",$J) S DIC=5,DR=1 D EN^DIQ1 54 . S $P(PRCY,U,9)=$E(^UTILITY("DIQ1",$J,5,DA,1),1,2) K ^UTILITY("DIQ1",$J) 55 S ^TMP($J,"STRING",PRCC)=PRCY 56 STX Q 57 MI(PRCRFQ,PRCC) ;Set up Miscellaneous Information segment 58 N PRCY 59 S PRCY="MI^^^^"_PRCRFQ_"^^^^^^|",PRCC=PRCC+1 60 S ^TMP($J,"STRING",PRCC)=PRCY 61 Q 62 AC(PRCC) ;Set up Accounting Information segment 63 N PRCY 64 S PRCY="AC^^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^^^^^^^^^^^^^^|",PRCC=PRCC+1 65 S ^TMP($J,"STRING",PRCC)=PRCY 66 Q 67 TX(PRCN,PRCC) ;Set up Text segment (i.e. Administrative Certification 68 ;;or 864 text) 69 ;;Syntax of call: S X=$$TX^PRCHQ4(ARG1,.ARG2) 70 ;; Returns number of lines in reformatted Word Processing field 71 ;;ARG1: CLOSED GLOBAL ROOT 72 ;;ARG2: CURRENT MESSAGE LINE COUNT 73 N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF 74 S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") 75 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D 76 . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP 77 ;I PRCN="^PRC(444,PRCDA,4)",$G(PRCTYPE)="00",$P($G(^PRC(444,PRCDA,1)),U,8)="y" D 78 ;. S X="If you are not an electronic trading partner with VA, you may submit" D ^DIWP 79 ;. S X="your bid by mail or FAX to the Contracting Office. If you would" D ^DIWP 80 ;. S X="like to register as a VA Electronic Trading Partner, please contact" D ^DIWP 81 ;. S X="your Software Provider or VA EDI Staff at 512-326-6463." D ^DIWP 82 S PRCT=$G(^UTILITY($J,"W",1))+0 83 F PRCI=1:1:PRCT D 84 . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") 85 . S ^TMP($J,"STRING",PRCC)="TX^"_PRCI_"^"_X_"^|" 86 K ^UTILITY($J,"W") 87 Q PRCT 88 IT(PRCC) ;Set up Item segment (Also calls SC and DE to set up Delivery 89 ;;Schedule and Description segments for item.) 90 N PRCA,PRCB,PRCD,PRCE,PRCF,PRCG,PRCH,PRCK,PRCL,PRCY,PRCCNT 91 S PRCA=0,PRCCNT=0 92 F S PRCA=$O(^PRC(444,PRCDA,2,PRCA)) Q:PRCA'?1.N D 93 . S PRCL=0 94 . S PRCB=$G(^PRC(444,PRCDA,2,PRCA,0)) Q:PRCB="" 95 . S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U) 96 . S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1 97 . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,5)),U,2) 98 . S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^" 99 . S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH 100 . S PRCY=PRCY_"^^^^^^^^^^^^^" 101 . S PRCE=$P(PRCB,U,7) S:PRCE?1.N PRCE=$P($P($G(^PRC(444.2,PRCE,0)),U)," "),$P(PRCY,U,22)=PRCE 102 . S $P(PRCY,U,23,29)=$P(PRCD,U)_"^"_$P(PRCD,U,2)_"^"_$P(PRCB,U,11)_"^"_$P($G(^PRC(444,PRCDA,1)),U)_"^^^|" 103 . S PRCC=PRCC+1,^TMP($J,"STRING",PRCC)=PRCY 104 . S PRCF=PRCC 105 . S $P(^TMP($J,"STRING",PRCF),U,21)=$$DE("^PRC(444,PRCDA,2,PRCA,2)",PRCG,.PRCC) 106 . S $P(^TMP($J,"STRING",PRCF),U,27)=$$SC("^PRC(444,PRCDA,2,PRCA,4)",PRCG,PRCH,.PRCC,.PRCL) 107 . I $P(^TMP($J,"STRING",PRCF),U,3)="" S PRCK(1)="Item #"_$P(PRCB,U)_": FSC and NSN missing" 108 . I $P(^TMP($J,"STRING",PRCF),U,8)'>0 S PRCK(2)="Item #"_$P(PRCB,U)_": Quantity not greater than zero" 109 . I $P(^TMP($J,"STRING",PRCF),U,9)="" S PRCK(3)="Item #"_$P(PRCB,U)_": Unit of Purchase missing" 110 . I $P(^TMP($J,"STRING",PRCF),U,22)="" S PRCK(4)="Item #"_$P(PRCB,U)_": SIC Code missing" 111 . I $P(^TMP($J,"STRING",PRCF),U,21)'>0 S PRCK(5)="Item #"_$P(PRCB,U)_": Item Description missing" 112 . I $P(^TMP($J,"STRING",PRCF),U,27)>0,$P(^(PRCF),U,8)'=PRCL S PRCK(6)="Item #"_$P(PRCB,U)_": Total of Delivery Schedule NOT EQUAL to Line Quantity" 113 S:PRCCNT>0 $P(^TMP($J,"STRING",1),U,12)=PRCCNT 114 I PRCCNT'>0 S PRCK(7)="No Items in RFQ" 115 I $D(PRCK) S PRCERR=2 D EN^DDIOL(.PRCK) 116 Q 117 SC(PRCN,PRCIT,PRCU,PRCC,PRCJ) ;Set up Delivery Schedule for item 118 N PRCW,PRCX,PRCY,PRCZ,X,Y 119 S PRCX=0,PRCW=0 120 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX'?1.N D 121 . S PRCZ=$G(@PRCN@(PRCX,0)) Q:PRCZ="" 122 . S X=$P(PRCZ,U,2) D JDN^PRCUTL 123 . S PRCY="SC^"_PRCIT_"^"_$P(PRCZ,U)_"^"_($P(PRCZ,U,3)*100)_"^"_PRCU 124 . S PRCY=PRCY_"^"_Y_"^|",PRCC=PRCC+1,PRCJ=PRCJ+$P(PRCY,U,4) 125 . S ^TMP($J,"STRING",PRCC)=PRCY,PRCW=PRCW+1 126 Q PRCW 127 DE(PRCN,PRCIT,PRCC) ;Set up Item Description segments 128 N PRCI,PRCT,PRCX,X,DIWL,DIWR,DIWF 129 S PRCX=0,DIWL=1,DIWR=70,DIWF="" K ^UTILITY($J,"W") 130 F S PRCX=$O(@PRCN@(PRCX)) Q:PRCX="" D 131 . Q:'$D(@PRCN@(PRCX,0)) S X=@PRCN@(PRCX,0) D ^DIWP 132 S PRCT=$G(^UTILITY($J,"W",1)) 133 F PRCI=1:1:PRCT D 134 . S PRCC=PRCC+1,X=$G(^UTILITY($J,"W",1,PRCI,0)) S:$L(X)=0 X=" " S X=$TR(X,"^") 135 . S ^TMP($J,"STRING",PRCC)="DE^"_PRCIT_"^"_PRCI_"^"_X_"^|" 136 K ^UTILITY($J,"W") 137 Q PRCT 138 DUNERR(PRCA) ;Displays the Error Message for Vendor Lacking Dun # 139 Q:$D(ZTQUEUED) 140 N PRCB S PRCB="^"_$P(PRCA,";",2)_$P(PRCA,";")_",0)" 141 S PRCB=$P(@PRCB,U)_" lacks a Dun # so NOT a recipient" 142 D EN^DDIOL(PRCB) 143 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m
r613 r623 1 PRCPLO2A ;WOIFO/DAP-stock status report (cont) ; 1/26/06 12:00pm 2 V ;;5.1;IFCAP;**83,98,112**;Oct 20, 2000;Build 2 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ;External reference to $$GET1^DIQ(4, is supported by ICR# 10090 5 ; *112 changes by: VMP, Holloway,T. 6 ; 7 ENT ;*83 Building ^TMP with total result data, totaling logic pulled from PRCPRSS0 8 N PRCPIN,PRCPIN1,PRCPIN2,PRCPIN3,TOTVAL,TOTCLOS,TOTCLO1,TOTCLO2,SSRIEN 9 S U="^",STA=PRC("SITE"),INV=PRCP("I") 10 ; 11 SSR1 ;*98 First Stock Status Report data field set 12 ; 13 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,1)=STA ;Station # 14 S DATRN=$$FMTE^XLFDT(DATESTRT) 15 S DATRN1=$P(DATRN," ",1)_","_$P(DATRN," ",2) 16 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,2)=DATRN1 ;Date Range 17 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,3)=INARNG ;Inactivity Range 18 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,4)=INV ;Inventory Point # 19 ;*83 Retrieve external inventory point name and primary/secondary/ 20 ;warehouse indicator 21 S PRCPIN=$G(^PRCP(445,INV,0)) 22 I PRCPIN'="" S PRCPIN1=$P(PRCPIN,"^",1),PRCPIN2=$P(PRCPIN1,"-",2,99) 23 I PRCPIN'="" S PRCPIN3=$P(PRCPIN,"^",3) 24 I PRCPIN="" S PRCPIN2="",PRCPIN3="" 25 S PRCPIN2=$TR(PRCPIN2,"*","|") ; Needed due to "*" delimiter 26 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,5)=PRCPIN2 ;Inventory Point Name 27 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,6)=PRCPIN3 ;P/S/W Indicator 28 ; 29 S PRCPDX=$TR(^TMP($J,"PRCPSSR1",STA,INV),"^","*"),DR="3///"_PRCPDX 30 D FILE 31 ; 32 SSR2 ;*98 Second Stock Status Report data field set 33 ; 34 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,1,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% 35 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,1)=TOTOPEN ;Std. Open Balance Total $ 36 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,2,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% 37 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,2)=TOTOPEN ;ODI Open Balance Total $ 38 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,3,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% 39 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,3)=TOTOPEN ;All Open Balance Total $ 40 ; 41 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,4)=+$G(^TMP($J,1,"REC","TOTAL")) 42 ;Std. Receipts Total $ 43 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,5)=+$G(^TMP($J,2,"REC","TOTAL")) 44 ;ODI Receipts Total $ 45 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,6)=+$G(^TMP($J,3,"REC","TOTAL")) 46 ;All Receipts Total $ 47 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,7)=+$G(^TMP($J,1,"ISS","TOTAL")) 48 ;Std. Usages Total $ 49 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,8)=+$G(^TMP($J,2,"ISS","TOTAL")) 50 ;ODI Usages Total $ 51 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,9)=+$G(^TMP($J,3,"ISS","TOTAL")) 52 ;All Usages Total $ 53 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,10)=+$G(^TMP($J,1,"ADJ","TOTAL")) 54 ;Std. Adjustments Total $ 55 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,11)=+$G(^TMP($J,2,"ADJ","TOTAL")) 56 ;ODI Adjustments Total $ 57 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,12)=+$G(^TMP($J,3,"ADJ","TOTAL")) 58 ;All Adjustments Total $ 59 ; 60 S PRCPDX=$TR(^TMP($J,"PRCPSSR2",STA,INV),"^","*"),DR="4///"_PRCPDX 61 D FILE 62 ; 63 SSR3 ;*98 Third Stock Status Report data field set 64 ; 65 S TOTCLOS=0 66 S TOTCLOS=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,1)+$G(^TMP($J,1,"REC","TOTAL")) 67 S TOTCLOS=TOTCLOS+$G(^TMP($J,1,"ISS","TOTAL"))+$G(^TMP($J,1,"ADJ","TOTAL")) 68 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,1)=TOTCLOS ;Std. Closing Bal Total $ 69 S TOTCLO1=0 70 S TOTCLO1=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,2)+$G(^TMP($J,2,"REC","TOTAL")) 71 S TOTCLO1=TOTCLO1+$G(^TMP($J,2,"ISS","TOTAL"))+$G(^TMP($J,2,"ADJ","TOTAL")) 72 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,2)=TOTCLO1 ;ODI Closing Bal Total $ 73 S TOTCLO2=0 74 S TOTCLO2=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,3)+$G(^TMP($J,3,"REC","TOTAL")) 75 S TOTCLO2=TOTCLO2+$G(^TMP($J,3,"ISS","TOTAL"))+$G(^TMP($J,3,"ADJ","TOTAL")) 76 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,3)=TOTCLO2 ;All Closing Bal Total $ 77 ; 78 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,4)=+$G(^TMP($J,1,"RECN","TOTAL")) 79 ;# Std. Receipts 80 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,5)=+$G(^TMP($J,2,"RECN","TOTAL")) 81 ;# ODI Receipts 82 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,6)=+$G(^TMP($J,3,"RECN","TOTAL")) 83 ;# All Receipts 84 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,7)=+$G(^TMP($J,1,"ISSN","TOTAL")) 85 ;# Std. Issues 86 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,8)=+$G(^TMP($J,2,"ISSN","TOTAL")) 87 ;# ODI Issues 88 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,9)=+$G(^TMP($J,3,"ISSN","TOTAL")) 89 ;# All Issues 90 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,10)=+$G(^TMP($J,1,"ADJN","TOTAL")) 91 ;# Std. Adjustments 92 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,11)=+$G(^TMP($J,2,"ADJN","TOTAL")) 93 ;# ODI Adjustments 94 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,12)=+$G(^TMP($J,3,"ADJN","TOTAL")) 95 ;# All Adjustments 96 ; 97 S PRCPDX=$TR(^TMP($J,"PRCPSSR3",STA,INV),"^","*"),DR="5///"_PRCPDX 98 D FILE 99 ; 100 SSR4 ;*98 Fourth Stock Status Report data field set 101 ; 102 ;*83 Turnover computation logic also pulled from PRCPRSS0 103 S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(DATESTRT,4,5)) 104 I DAYS=28 S %=(17+$E(DATESTRT))_$E(DATESTRT,2,3),DAYS=$S(%#400=0:29,(%#4=0&(%#100'=0)):29,1:28) 105 ; 106 S %=($G(^TMP($J,1,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLOS:0,1:-%/TOTCLOS) 107 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=$J(%,0,2) 108 ;Std. Turnover 109 S %=($G(^TMP($J,2,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO1:0,1:-%/TOTCLO1) 110 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=$J(%,0,2) 111 ;ODI Turnover 112 S %=($G(^TMP($J,3,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO2:0,1:-%/TOTCLO2) 113 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=$J(%,0,2) 114 ;All Turnover 115 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,4)=+$G(^TMP($J,1,"INACTN","TOTAL")) 116 ;# Std. Inactive 117 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,5)=+$G(^TMP($J,2,"INACTN","TOTAL")) 118 ;# ODI Inactive 119 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,6)=+$G(^TMP($J,3,"INACTN","TOTAL")) 120 ;# All Inactive 121 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,7)=+$G(^TMP($J,1,"INACT","TOTAL")) 122 ;Std Inactive Total $ 123 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,8)=+$G(^TMP($J,2,"INACT","TOTAL")) 124 ;ODI Inactive Total $ 125 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,9)=+$G(^TMP($J,3,"INACT","TOTAL")) 126 ;All Inactive Total $ 127 ; 128 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"INACT","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) 129 I %="" S %=0 130 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=$J(%,0,2) 131 ;Std. Inactive % 132 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"INACT","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) 133 I %="" S %=0 134 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=$J(%,0,2) 135 ;ODI Inactive % 136 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"INACT","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) 137 I %="" S %=0 138 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=$J(%,0,2) 139 ;All Inactive % 140 ; 141 S PRCPDX=$TR(^TMP($J,"PRCPSSR4",STA,INV),"^","*"),DR="6///"_PRCPDX 142 D FILE 143 ; 144 SSR5 ;*98 Fifth Stock Status Report data field set 145 ; 146 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,1)=+$G(^TMP($J,1,"LONGN","TOTAL")) 147 ;# Std. Long Supply 148 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,2)=+$G(^TMP($J,2,"LONGN","TOTAL")) 149 ;# ODI Long Supply 150 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,3)=+$G(^TMP($J,3,"LONGN","TOTAL")) 151 ;# All Long Supply 152 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,4)=+$G(^TMP($J,1,"LONG","TOTAL")) 153 ;Std. Long Supply Total $ 154 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,5)=+$G(^TMP($J,2,"LONG","TOTAL")) 155 ;ODI Long Supply Total $ 156 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,6)=+$G(^TMP($J,3,"LONG","TOTAL")) 157 ;All Long Supply Total $ 158 ; 159 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"LONG","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) 160 I %="" S %=0 161 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=$J(%,0,2) 162 ;Std. Long Supply % 163 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"LONG","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) 164 I %="" S %=0 165 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=$J(%,0,2) 166 ;ODI Long Supply % 167 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"LONG","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) 168 I %="" S %=0 169 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=$J(%,0,2) 170 ;All Long Supply % 171 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,10)=+$G(^TMP($J,1,"CNT","TOTAL")) 172 ;# Std. Items 173 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,11)=+$G(^TMP($J,2,"CNT","TOTAL")) 174 ;# On-Demand Items 175 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,12)=+$G(^TMP($J,3,"CNT","TOTAL")) 176 ;# All Items 177 ; 178 S PRCPDX=$TR(^TMP($J,"PRCPSSR5",STA,INV),"^","*"),DR="7///"_PRCPDX 179 D FILE 180 K Y 181 ; 182 Q 183 ; 184 ;*98 Created filing subroutine 185 FILE ; Subroutine that creates entries in File #446.7 fields as they 186 ; are created 187 ; 188 N PRCPDR,PRCPSNM,PRCPDA,PRCPDX,X,Y 189 S PRCPDR=DR 190 S SSRIEN=STA_INV 191 S DIC="^PRCP(446.7,",DIC(0)="L",DLAYGO=446.7,X=SSRIEN D ^DIC K DIC,DLAYGO 192 S PRCPDA=Y+0 193 ;*98 Send enhanced mail message if exception occurs during FileMan set 194 I Y=-1 N PRCPMSG D Q 195 . S PRCPMSG(1)="Error saving to File #446.7 for Stock Status Report, related data: " 196 . S PRCPSNM=$$GET1^DIQ(4,STA_",",.01) 197 . S PRCPMSG(2)="",PRCPMSG(3)="Station: "_STA_" "_PRCPSNM 198 . S PRCPMSG(4)="Inventory Point: "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,4)_" "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,5) 199 . S PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR 200 . D MAIL^PRCPLO3 Q 201 ; 202 S DIE="^PRCP(446.7,",DA=PRCPDA D ^DIE K DIE,DR,DA 203 ; 204 Q 1 PRCPLO2A ;WOIFO/DAP-stock status report (cont) ; 1/26/06 12:00pm 2 V ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ENT ;*83 Building ^TMP with total result data, totaling logic pulled from PRCPRSS0 6 N PRCPIN,PRCPIN1,PRCPIN2,PRCPIN3,TOTVAL,TOTCLOS,TOTCLO1,TOTCLO2,SSRIEN 7 S U="^",STA=PRC("SITE"),INV=PRCP("I") 8 ; 9 SSR1 ;*98 First Stock Status Report data field set 10 ; 11 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,1)=STA ;Station # 12 S DATRN=$$FMTE^XLFDT(DATESTRT) 13 S DATRN1=$P(DATRN," ",1)_","_$P(DATRN," ",2) 14 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,2)=DATRN1 ;Date Range 15 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,3)=INARNG ;Inactivity Range 16 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,4)=INV ;Inventory Point # 17 ;*83 Retrieve external inventory point name and primary/secondary/ 18 ;warehouse indicator 19 S PRCPIN=$G(^PRCP(445,INV,0)) 20 I PRCPIN'="" S PRCPIN1=$P(PRCPIN,"^",1),PRCPIN2=$P(PRCPIN1,"-",2,99) 21 I PRCPIN'="" S PRCPIN3=$P(PRCPIN,"^",3) 22 I PRCPIN="" S PRCPIN2="",PRCPIN3="" 23 S PRCPIN2=$TR(PRCPIN2,"*","|") ; Needed due to "*" delimiter 24 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,5)=PRCPIN2 ;Inventory Point Name 25 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,6)=PRCPIN3 ;P/S/W Indicator 26 ; 27 S PRCPDX=$TR(^TMP($J,"PRCPSSR1",STA,INV),"^","*"),DR="3///"_PRCPDX 28 D FILE 29 ; 30 SSR2 ;*98 Second Stock Status Report data field set 31 ; 32 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,1,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% 33 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,1)=TOTOPEN ;Std. Open Balance Total $ 34 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,2,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% 35 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,2)=TOTOPEN ;ODI Open Balance Total $ 36 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,3,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+% 37 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,3)=TOTOPEN ;All Open Balance Total $ 38 ; 39 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,4)=+$G(^TMP($J,1,"REC","TOTAL")) 40 ;Std. Receipts Total $ 41 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,5)=+$G(^TMP($J,2,"REC","TOTAL")) 42 ;ODI Receipts Total $ 43 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,6)=+$G(^TMP($J,3,"REC","TOTAL")) 44 ;All Receipts Total $ 45 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,7)=+$G(^TMP($J,1,"ISS","TOTAL")) 46 ;Std. Usages Total $ 47 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,8)=+$G(^TMP($J,2,"ISS","TOTAL")) 48 ;ODI Usages Total $ 49 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,9)=+$G(^TMP($J,3,"ISS","TOTAL")) 50 ;All Usages Total $ 51 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,10)=+$G(^TMP($J,1,"ADJ","TOTAL")) 52 ;Std. Adjustments Total $ 53 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,11)=+$G(^TMP($J,2,"ADJ","TOTAL")) 54 ;ODI Adjustments Total $ 55 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,12)=+$G(^TMP($J,3,"ADJ","TOTAL")) 56 ;All Adjustments Total $ 57 ; 58 S PRCPDX=$TR(^TMP($J,"PRCPSSR2",STA,INV),"^","*"),DR="4///"_PRCPDX 59 D FILE 60 ; 61 SSR3 ;*98 Third Stock Status Report data field set 62 ; 63 S TOTCLOS=0 64 S TOTCLOS=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,1)+$G(^TMP($J,1,"REC","TOTAL")) 65 S TOTCLOS=TOTCLOS+$G(^TMP($J,1,"ISS","TOTAL"))+$G(^TMP($J,1,"ADJ","TOTAL")) 66 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,1)=TOTCLOS ;Std. Closing Bal Total $ 67 S TOTCLO1=0 68 S TOTCLO1=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,2)+$G(^TMP($J,2,"REC","TOTAL")) 69 S TOTCLO1=TOTCLO1+$G(^TMP($J,2,"ISS","TOTAL"))+$G(^TMP($J,2,"ADJ","TOTAL")) 70 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,2)=TOTCLO1 ;ODI Closing Bal Total $ 71 S TOTCLO2=0 72 S TOTCLO2=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,3)+$G(^TMP($J,3,"REC","TOTAL")) 73 S TOTCLO2=TOTCLO2+$G(^TMP($J,3,"ISS","TOTAL"))+$G(^TMP($J,3,"ADJ","TOTAL")) 74 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,3)=TOTCLO2 ;All Closing Bal Total $ 75 ; 76 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,4)=+$G(^TMP($J,1,"RECN","TOTAL")) 77 ;# Std. Receipts 78 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,5)=+$G(^TMP($J,2,"RECN","TOTAL")) 79 ;# ODI Receipts 80 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,6)=+$G(^TMP($J,3,"RECN","TOTAL")) 81 ;# All Receipts 82 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,7)=+$G(^TMP($J,1,"ISSN","TOTAL")) 83 ;# Std. Issues 84 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,8)=+$G(^TMP($J,2,"ISSN","TOTAL")) 85 ;# ODI Issues 86 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,9)=+$G(^TMP($J,3,"ISSN","TOTAL")) 87 ;# All Issues 88 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,10)=+$G(^TMP($J,1,"ADJN","TOTAL")) 89 ;# Std. Adjustments 90 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,11)=+$G(^TMP($J,2,"ADJN","TOTAL")) 91 ;# ODI Adjustments 92 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,12)=+$G(^TMP($J,3,"ADJN","TOTAL")) 93 ;# All Adjustments 94 ; 95 S PRCPDX=$TR(^TMP($J,"PRCPSSR3",STA,INV),"^","*"),DR="5///"_PRCPDX 96 D FILE 97 ; 98 SSR4 ;*98 Fourth Stock Status Report data field set 99 ; 100 ;*83 Turnover computation logic also pulled from PRCPRSS0 101 S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(DATESTRT,4,5)) 102 I DAYS=28 S %=(17+$E(DATESTRT))_$E(DATESTRT,2,3),DAYS=$S(%#400=0:29,(%#4=0&(%#100'=0)):29,1:28) 103 ; 104 S %=($G(^TMP($J,1,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLOS:0,1:-%/TOTCLOS) 105 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 106 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=% 107 ;Std. Turnover 108 S %=($G(^TMP($J,2,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO1:0,1:-%/TOTCLO1) 109 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 110 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=% 111 ;ODI Turnover 112 S %=($G(^TMP($J,3,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO2:0,1:-%/TOTCLO2) 113 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 114 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=% 115 ;All Turnover 116 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,4)=+$G(^TMP($J,1,"INACTN","TOTAL")) 117 ;# Std. Inactive 118 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,5)=+$G(^TMP($J,2,"INACTN","TOTAL")) 119 ;# ODI Inactive 120 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,6)=+$G(^TMP($J,3,"INACTN","TOTAL")) 121 ;# All Inactive 122 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,7)=+$G(^TMP($J,1,"INACT","TOTAL")) 123 ;Std Inactive Total $ 124 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,8)=+$G(^TMP($J,2,"INACT","TOTAL")) 125 ;ODI Inactive Total $ 126 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,9)=+$G(^TMP($J,3,"INACT","TOTAL")) 127 ;All Inactive Total $ 128 ; 129 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"INACT","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) 130 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 131 I %="" S %=0 132 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=% 133 ;Std. Inactive % 134 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"INACT","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) 135 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 136 I %="" S %=0 137 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=% 138 ;ODI Inactive % 139 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"INACT","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) 140 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 141 I %="" S %=0 142 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=% 143 ;All Inactive % 144 ; 145 S PRCPDX=$TR(^TMP($J,"PRCPSSR4",STA,INV),"^","*"),DR="6///"_PRCPDX 146 D FILE 147 ; 148 SSR5 ;*98 Fifth Stock Status Report data field set 149 ; 150 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,1)=+$G(^TMP($J,1,"LONGN","TOTAL")) 151 ;# Std. Long Supply 152 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,2)=+$G(^TMP($J,2,"LONGN","TOTAL")) 153 ;# ODI Long Supply 154 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,3)=+$G(^TMP($J,3,"LONGN","TOTAL")) 155 ;# All Long Supply 156 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,4)=+$G(^TMP($J,1,"LONG","TOTAL")) 157 ;Std. Long Supply Total $ 158 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,5)=+$G(^TMP($J,2,"LONG","TOTAL")) 159 ;ODI Long Supply Total $ 160 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,6)=+$G(^TMP($J,3,"LONG","TOTAL")) 161 ;All Long Supply Total $ 162 ; 163 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"LONG","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL"))) 164 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 165 I %="" S %=0 166 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=% 167 ;Std. Long Supply % 168 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"LONG","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL"))) 169 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 170 I %="" S %=0 171 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=% 172 ;ODI Long Supply % 173 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"LONG","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL"))) 174 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2) 175 I %="" S %=0 176 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=% 177 ;All Long Supply % 178 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,10)=+$G(^TMP($J,1,"CNT","TOTAL")) 179 ;# Std. Items 180 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,11)=+$G(^TMP($J,2,"CNT","TOTAL")) 181 ;# On-Demand Items 182 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,12)=+$G(^TMP($J,3,"CNT","TOTAL")) 183 ;# All Items 184 ; 185 S PRCPDX=$TR(^TMP($J,"PRCPSSR5",STA,INV),"^","*"),DR="7///"_PRCPDX 186 D FILE 187 K Y 188 ; 189 Q 190 ; 191 ;*98 Created filing subroutine 192 FILE ; Subroutine that creates entries in File #446.7 fields as they 193 ; are created 194 ; 195 N PRCPDR,PRCPSNM,PRCPDA,PRCPDX,X,Y 196 S PRCPDR=DR 197 S SSRIEN=STA_INV 198 S DIC="^PRCP(446.7,",DIC(0)="L",DLAYGO=446.7,X=SSRIEN D ^DIC K DIC,DLAYGO 199 S PRCPDA=Y+0 200 ;*98 Send enhanced mail message if exception occurs during FileMan set 201 I Y=-1 N PRCPMSG D Q 202 . S PRCPMSG(1)="Error saving to File #446.7 for Stock Status Report, related data: " 203 . S PRCPSNM=$$GET1^DIQ(4,STA_",",.01) 204 . S PRCPMSG(2)="",PRCPMSG(3)="Station: "_STA_" "_PRCPSNM 205 . S PRCPMSG(4)="Inventory Point: "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,4)_" "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,5) 206 . S PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR 207 . D MAIL^PRCPLO3 Q 208 ; 209 S DIE="^PRCP(446.7,",DA=PRCPDA D ^DIE K DIE,DR,DA 210 ; 211 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m
r613 r623 1 PRCPUSEL 2 V ;;5.1;IFCAP;**1,83,110**;Oct 20, 2000;Build 73 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$G(PRCP(I)) S %=1 Q23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 V1 54 55 56 DISPLAY 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 NOMENU 97 98 99 100 101 102 103 PARAM(INVPT) 104 105 106 107 108 109 110 111 112 TERM 113 114 115 116 117 118 119 120 SSMSG 121 122 123 124 125 126 127 128 129 130 131 1 PRCPUSEL ;WISC/RFJ/DAP-utilities: setup inventory variables ;14 Feb 91 2 V ;;5.1;IFCAP;**1,83**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; enter distribution point--input variables: 5 ; prcp("dptype")=distribution point type code [W,P,S] 6 ; returns the following variables: 7 ; prcp("in")=name of inv pt (no station #), 8 ; prcp("inv")=keep perpetual inventory flag 9 ; prcp("his")=keep detailed history flag, 10 ; prcp("i")=da of inv pt 11 ; 12 ;*83 Routine PRCPLO1 associated with PRC*5.1*83 is a modified copy of 13 ;this routine and any changes made to this routine should also be 14 ;considered for that routine as well. 15 ; 16 N %,C,DISYS,I,J,PRCF,PRCPFLAG,X,Y 17 I +$G(DUZ)<1 W !,"YOU ARE NOT SETUP AS A USER!" K PRC,PRCP Q 18 ; 19 S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q 20 I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q 21 ; 22 S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$D(PRCP(I)) S %=1 Q 23 I '% D DISPLAY Q 24 ; 25 ; allow adding new whse if not one for station 26 I $G(PRCP("DPTYPE"))="W" D Q:$G(PRCPFLAG) 27 . K PRCPFLAG 28 . S %=0 F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I $P($P($G(^PRCP(445,%,0)),"^"),"-")=PRC("SITE") S PRCPFLAG=1 Q 29 . I $G(PRCPFLAG) K PRCPFLAG Q 30 . S PRCP("I")=$$INVPT^PRCPUINV(PRC("SITE"),"W",1,1,"") 31 . I 'PRCP("I") S PRCPFLAG=1 K PRC,PRCP 32 ; 33 S %=$S($D(PRCP("DPTYPE")):PRCP("DPTYPE"),1:"^") 34 S (I,J)=0 35 F S I=$O(^PRCP(445,"AD",DUZ,I)) Q:'I I $D(^PRCP(445,I,0)) D I J>1 Q 36 . S:%="^"!(%[$P(^PRCP(445,I,0),"^",3)) Y(0)=^(0),J=J+1,Y=I 37 I J=1 D Q:$G(PRCPFLAG) S PRC("SITE")=+Y(0) D V1 Q 38 . I '$D(^PRC(411,+Y(0),0)) D K PRC,PRCP S PRCPFLAG=1 39 . . W !,"ERROR - SITE PARAMETERS IN FILE 411 FOR SITE " 40 . . W +Y(0)," ARE MISSING." 41 I $G(PRCHAUTH) Q:'$G(PRCP("I")) D G V1 42 . S Y=PRCP("I")_"^"_$P($G(^PRCP(445,PRCP("I"),0)),U) 43 ; 44 S DIC="^PRCP(445,",DIC(0)="AEQMOZ" 45 S DIC("S")="I +^(0)=PRC(""SITE""),$P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" 46 I $D(PRCP("DPTYPE")) S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)" 47 S DIC("A")="Select "_$S('$D(PRCP("DPTYPE")):"",PRCP("DPTYPE")="W":"Supply Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")_"Inventory Point: " 48 S D="C",PRCPPRIV=1 49 D IX^DIC 50 K PRCPPRIV,DIC 51 I Y<0 K PRC,PRCP Q 52 ; 53 V1 ; internal program jump 54 D PARAM(+Y) 55 ; 56 DISPLAY ; display top of page header 57 I '$G(PRCP("I")) G PRCPUSEL 58 S %=0 F I="RV1","RV0","XY" I '$D(PRCP(I)) S %=1 Q 59 I % D TERM 60 ; 61 S %="",$P(%," ",81)="" 62 S X="I N V E N T O R Y version "_$P($T(PRCPUSEL+1),";",3) 63 S Y=80-$L(X)\2 64 S X=$E(%,1,Y)_X_% 65 W @IOF,PRCP("RV1"),$E(X,1,40) 66 X PRCP("XY") 67 W $E(X,41,80),PRCP("RV0") 68 S PRCP("PAR")=^PRCP(445,PRCP("I"),0) 69 S X=$S(+$G(PRC("SITE")):"("_PRC("SITE")_") ",1:"") 70 S X=X_$S(PRCP("DPTYPE")="W":"Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"") 71 S X=X_"Inventory Point: "_PRCP("IN") 72 W !,X,?(80-$L($P($G(PRC("PER")),"^",2))),$P($G(PRC("PER")),"^",2) 73 I PRCP("DPTYPE")="P" S Y=$P(PRCP("PAR"),"^",12) I Y,Y'>DT D 74 . D DD^%DT 75 . W !,?6,"--> NEXT REQUEST FOR WAREHOUSE ISSUES IS DUE IN SUPPLY ON ",Y,"." 76 I $P(PRCP("PAR"),"^",9)="Y" D 77 . W !?6,"--> THERE ARE ITEMS AT OR BELOW THE EMERGENCY STOCK LEVEL." 78 I $E($P(PRCP("PAR"),"^",14),1,5)'=$E(DT,1,5) D 79 . W !?6,"--> USAGE/DISTRIBUTION TOTALS NEEDS TO BE PURGED." 80 I $E($P(PRCP("PAR"),"^",17),1,5)'=$E(DT,1,5) D 81 . W !?6,"--> RECEIPTS HISTORY BY ITEM NEEDS TO BE PURGED." 82 I PRCP("DPTYPE")'="S",$E($P(PRCP("PAR"),"^",19),1,5)'=$E(DT,1,5) D 83 . W !?6,"--> DISTRIBUTION HISTORY NEEDS TO BE PURGED." 84 I $E($P(PRCP("PAR"),"^",18),1,5)'=$E(DT,1,5) D 85 . W !?6,"--> TRANSACTION REGISTER NEEDS TO BE PURGED." 86 I $P(PRCP("PAR"),"^",6)="Y",$E($P(PRCP("PAR"),"^",22),1,5)'=$E(DT,1,5) D 87 . W !?6,"--> OPENING MONTHLY INVENTORY BALANCES NEED TO BE SET." 88 I PRCP("DPTYPE")="S",$P($G(^PRCP(445,PRCP("I"),5)),"^",1)]"" D SSMSG 89 I $O(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),"")) D 90 . W !?6,"--> THERE ARE UNPROCESSED SUPPLY STATION TRANSACTIONS." 91 ; 92 W !,PRCP("RV1"),$E(%,1,40) X PRCP("XY") W $E(%,41,80),PRCP("RV0") 93 Q 94 ; 95 ; 96 NOMENU ; user did not select a valid inventory point, do not allow access 97 ; to the menu (called from option file) 98 N X 99 S X(1)="YOU MUST SELECT A VALID INVENTORY POINT BEFORE ACCESSING THIS MENU" D DISPLAY^PRCPUX2(1,79,.X) 100 Q 101 ; 102 ; 103 PARAM(INVPT) ; set up parameters for inventory point 104 K PRCP 105 N DATA 106 S DATA=$G(^PRCP(445,INVPT,0)) I DATA="" Q 107 S PRCP("I")=INVPT,PRCP("IN")=$P($P(DATA,"^"),"-",2,99),PRCP("INV")=$P(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3) 108 D TERM 109 Q 110 ; 111 ; 112 TERM ; get terminal attributes 113 N X 114 I '$D(IOF)!('$G(IOST(0))) S IOP="HOME" D ^%ZIS K IOP 115 S X="IORVON;IORVOFF" D ENDR^%ZISS 116 S PRCP("RV1")=$G(IORVON),PRCP("RV0")=$G(IORVOFF) 117 S PRCP("XY")="N DX,DY S (DX,DY)=0 "_$G(^%ZOSF("XY")) 118 Q 119 ; 120 SSMSG ; check supply station secondaries, give message of qty mismatch 121 N GIPCNT,INVPT,ITEM,PRCPFLAG,SSCNT 122 S INVPT=PRCP("I") 123 S ITEM=0 124 F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q 125 . I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item 126 . S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7) 127 . S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1) 128 . I 'GIPCNT,'SSCNT Q 129 . I GIPCNT=SSCNT Q 130 . W !,?6,"--> QUANTITY DISCREPANCIES EXIST WITH THE SUPPLY STATION." 131 . S PRCPFLAG=1 -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m
r613 r623 1 PRCSD122 2 V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 133 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 8 9 SIG 10 11 12 13 14 15 16 17 I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5W " (",$P(^(.13),U,2),")"18 19 20 SIG1 21 22 23 24 25 26 27 28 29 1 PRCSD122 ;WISC/SAW-CONTROL POINT ACT. 2237 TERM. DISP. CON'T ;4/21/93 08:46 2 V ;;5.1;IFCAP;;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U 5 W !,"JUSTIFICATION OF NEED OR TURN-IN" 6 I '$D(^PRCS(410,DA,8,0)) G SIG 7 S DIWL=1,DIWR=80,DIWF="" K ^UTILITY($J,"W") S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA)) 8 S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:IOSL-$Y<2 NEWP^PRCSD121 Q:Z1=U W !,^UTILITY($J,"W",DIWL,K,0) 9 SIG ;PRINT SIGNATURE BLOCKS 10 I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U 11 W !,L 12 W !,"Originator of Request: " S XNAME=$P($G(^PRCS(410,DA,14)),"^") I XNAME'="" W $P($G(^VA(200,XNAME,0)),"^") 13 W !,"Signature of Initiator",?37,"Signature of Approving Official Date" 14 I '$D(^PRCS(410,DA,7)) W ! G SIG1 15 W !,?37 K P1 S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1),$P(^(7),U,6)'="" W "/ES/",$$DECODE^PRCSC1(DA) 16 N PRSHLB S PRSHLB=^DD(410,40,0) W ?69,! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLB,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,28) 17 I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")" 18 N PRSHLC S PRSHLC=^DD(410,42,0) K P2 W ?37 I $D(P1),$P(PRSHLC,"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,30) 19 W ?69,! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?37 W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?69 I $P(^(7),U,5)'="" S Y=$P(^(7),U,5) D DD^%DT W Y 20 SIG1 W !,$E(L,1,36) 21 W " ",$E(L,38,68) 22 W "------------" I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U 23 W !,"Appropriation and Accounting Symbols" 24 S P=$P(^PRCS(410,DA,0),U,5) I $D(^(3)) S X=^(3) S:$P(X,U,2)'="" P=P_"-"_$P(X,U,2) S:$P(X,U)'="" P=P_"-"_$P($P(X,U)," ") S:$P(X,U,3)'="" P=P_"-"_$P($P(X,U,3)," ") 25 S:$D(PRCS("SUB")) P=P_"-"_PRCS("SUB") 26 I $D(^PRCS(410,DA,4)),$P(^(4),U,5)'="" S P=P_"-"_$P(^(4),U,5) 27 S FPROJ=$P($G(^PRCS(410,DA,3)),"^",12) S P=P_" "_FPROJ 28 W !,P,!,L 29 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m
r613 r623 1 PRCSP122 2 V ;;5.1;IFCAP;**95,107**;Oct 20, 2000;Build 133 4 5 6 7 DEL 8 9 10 11 12 13 14 15 16 17 18 SIG 19 20 21 22 23 24 25 26 I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5W " (",$P(^(.13),U,2),")"27 28 29 SIG1 30 31 32 1 PRCSP122 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;4/21/93 08:53 2 V ;;5.1;IFCAP;**95**;Oct 20, 2000 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 I '$D(^PRCS(410,DA,"RM",0)) G DEL 5 I $D(^PRCS(410,DA,"RM",0)) W ! S P(1)=0,DIWL=6,DIWR=96,DIWF="" K ^UTILITY($J,"W") S X="SPECIAL REMARKS:" D DIWP^PRCUTL($G(DA)) F J=1:1 S P(1)=$O(^PRCS(410,DA,"RM",P(1))) Q:P(1)="" S X=^(P(1),0) D DIWP^PRCUTL($G(DA)) 6 S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0) 7 DEL I $D(^PRCS(410,DA,9)),$P(^(9),U)'="" W !,"DELIVER TO: ",$P(^(9),U) 8 W !,L,!,"FOB",?24,"|TERMS",?48,"|DELIVERY DATE",?63,"|QUOTE DATE",?77,"|BY(Initials)",!,?24,"|",?48,"|",?63,"|",?77,"|" 9 W !,$E(L,1,24),"|",$E(L,1,23),"|",$E(L,1,14),"|",$E(L,1,13),"|",$E(L,1,12) 10 I $Y>58 D NEWP^PRCSP121 11 W !,"JUSTIFICATION OF NEED OR TURN-IN (If recurring need, indicate 30-day estimate. If turn-in,",!,"do not use this form if circumstances require use of VA Form 90-1217, Report of Survey)" 12 I '$D(^PRCS(410,DA,8,0)) G SIG 13 S (MYTEMP,BFLAG)=0 14 F I=1:1 S MYTEMP=$O(^PRCS(410,DA,8,MYTEMP)) Q:MYTEMP="" S BFLAG=1 15 I BFLAG=0 G SIG 16 S DIWL=6,DIWR=96,DIWF="" K ^UTILITY($J,"W") S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA)) 17 S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0) 18 SIG ;PRINT SIGNATURE BLOCKS 19 I $Y>58 D NEWP^PRCSP121 20 W !,L 21 W !,"Originator of Request: " S XNAME=$P($G(^PRCS(410,DA,14)),"^") I XNAME'="" W $P($G(^VA(200,XNAME,0)),"^") 22 W !,"Signature of Initiator",?39,"|Signature of Approving Official |Date" 23 I '$D(^PRCS(410,DA,7)) W !,?39,"|",?72,"|",!,?39,"|",?72,"|" G SIG1 24 K P1 W !,?39,"|" S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1) W "/ES/",$$DECODE^PRCSC1(DA) 25 N PRSHLE S PRSHLE=^DD(410,40,0) W ?72,"|",! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLE,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,31) 26 I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")" 27 K P2 W ?39,"|" I $D(P1),$P(^DD(410,42,0),"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,33) 28 W ?72,"|",! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?39,"|" W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?72,"|" S Y=$S($P(^(7),U,7):$P(^(7),U,7),1:$P(^(7),U,5)) I Y D DD^%DT W Y 29 SIG1 W !,$E(L,1,39) 30 W "|",$E(L,1,32) 31 W "|",$E(L,1,17) Q:PRNTALL=0 I $Y>41 D NEWP^PRCSP121 32 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m
r613 r623 1 PRCSRIG1 2 V ;;5.1;IFCAP;**13,81,101,110**;Oct 20, 2000;Build 73 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 SV 34 35 ;patch *81 -DynaMed trx. is not allowed to be re-used 36 N PRCVSY,PRCVID 37 S PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") 38 I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0)39 I PRCVSY=1,PRCVID=1 G CHK1 40 G EXIT:$D(ZTQUEUED) 41 42 CHK1 43 JMP 44 45 CLS 46 47 48 HDRG 49 50 51 HOLD 52 ASK 53 EN 54 55 EN1 56 57 58 59 60 ITDMID(PRCSRID0) 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 EXIT 81 82 83 1 PRCSRIG1 ;WISC/SAW/KMB/LJP/SC-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ;3-3-93/14:30 ; 3/31/05 3:48pm 2 V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be 6 ;RE-USED for generating 2237(s),hence removed this prompt for DM 7 ;trxs. only. 8 ; 9 U IO S PRCSNO=$P(^PRCS(410.3,PRCSRID0,0),"^"),PRC("SITE")=+PRCSNO,PRC("CP")=$S($D(^PRC(420,PRC("SITE"),1,+$P(PRCSNO,"-",4),0)):$P(^(0),"^"),1:"") 10 I PRC("CP")="" W !!,"Control Point ",$P(PRCSNO,"-",4),"no longer exists. You will have to transfer",!,"this repetitive item list to an existing control point before you can continue." K PRC("CP") G EXIT 11 ;Create transaction number 12 D:'$D(DT) DT^DICRW S PRCSTIME=$E(DT,4,5),PRCSQUAR=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",PRCSTIME) 13 S:PQTR=1 PRCSQUAR=$P(PRCSNO,"-",3) 14 S Z1=$P(PRCSNO,"-")_"-"_PRC("FY")_"-"_PRCSQUAR_"-"_$P(PRCSNO,"-",4) 15 S Z2=$P(Z1,"-",1,2)_"-"_$P(Z1,"-",4) 16 S PRCSCC=$P(PRCSNO,"-",5),PRCSCC=$S($D(^PRCD(420.1,+PRCSCC,0)):$E($P(^(0),"^"),1,30),1:PRCSCC) S:PRCSCC="NONE" PRCSCC="" S X="N",%DT="T" D ^%DT S PRCSD1=$P(Y,".") X ^DD("DD") S PRCSD=Y,X="T+30" D ^%DT S PRCSD(1)=Y 17 ; 18 ;See NOIS MON-0399-51726 19 KILL ^TMP($J) 20 S IB=0 21 F S IB=$O(^PRCS(410.3,PRCSRID0,1,IB)) Q:'IB D ; 22 . S FF=$G(^PRCS(410.3,PRCSRID0,1,IB,0)) 23 . S ^TMP($J,410.3,PRCSRID0,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)="" 24 ; 25 ; Loop thru RIL entry numbers. PRCSV1 is the vendor for 26 ;the item, from the Rep. Item List. Starting here, loop 27 ;thru the vendor to get the items ordered from that vendor, 28 ;using PRCSRI for the item. 29 S (PRCSV1,PRCSTC)="",(PRCSCT,PRCSCT(1),PRCSIT,BFLAG)=0 30 F PRCSRIJ=0:1 S PRCSV1=$O(^TMP($J,410.3,PRCSRID0,1,"AC",PRCSV1)) Q:PRCSV1=""!(BFLAG=1) S PRCSCT=PRCSCT+1,PRCSCT(1)=PRCSCT(1)+1 D:'PRCSRIJ HDRG D ITEMG^PRCSRIG2 31 I 'PRCSRIJ W !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO G CLS 32 D:IOSL-$Y<3 HOLD,HDRG W !!,"Total no. of requests generated: ",PRCSCT," Total no. of items (all requests): ",PRCSIT,!,"Total committed (estimated) cost (all requests) : ","$"_$J(PRCSTC,0,2) 33 SV ; 34 I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC 35 G EXIT:$D(ZTQUEUED) 36 ;patch *81 -DynaMed trx. is not allowed to be re-used 37 N PRCVSY,PRCVID 38 S PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") 39 I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0) 40 I PRCVSY=1,PRCVID=1 G CHK1 41 U IO(0) S %=2 W !,"Do you wish to re-use this list " D YN^DICN G:%=1 JMP G:%=0 SV 42 CHK1 I PRCSCT=PRCSCT(1) S DIK="^PRCS(410.3,",DA=PRCSRID0 D ^DIK G CLS 43 JMP D RLR^PRCSUT1 44 S $P(^PRCS(410.3,PRCSRID0,0),U,5)="",DIK="^PRCS(410.3,",DA=PRCSRID0 D IX^DIK 45 CLS ; 46 D:$D(ZTSK) KILL^%ZTLOAD G EXIT 47 ; 48 HDRG W @IOF,"GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE",?55,"DATE: ",PRCSD,!,"Requests Generated From Repetitive Item List Entry # ",PRCSNO,! S L="",$P(L,"-",IOM)="-" W L S L="" 49 Q 50 ; 51 HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) W !,"Press return to continue: " R Z(1):DTIME Q 52 ASK S %=2 W !,"Do you wish to edit this request" D YN^DICN D ASK:%=0 G:%=2 EN1 Q:%'=1 53 EN W ! K DTOUT,DUOUT,Y S DIE="^PRCS(410,",(PRCSDR,DR)="[PRCSENPR]",T1=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=T1 Q 54 S DA=T1 D RL^PRCSUT1,^PRCSCK I $D(PRCSERR),PRCSERR G EN 55 EN1 W ! D W6^PRCSEB Q 56 ;***************************************************************** 57 ; PRCSRID0 represents the ien of the record in file 410.3 58 ; patch *81 --itdmid removes Re-use Ques for DM related RIL 59 ;***************************************************************** 60 ITDMID(PRCSRID0) ; check DynaMed DOC ID existence for an item 61 ;N PRCVA,PRCVB,PRCVFLG 62 ;S PRCVA=0 63 ;S PRCVFLG=0 ; 0 means that there is no DM ID on a item 64 ;S PRCVA=$O(^PRCS(410.3,PRCSRID0,1,PRCVA)) D 65 ;.Q:+$G(PRCVA)'>0 66 ;.S PRCVB=$$GET1^DIQ(410.31,PRCVA_","_PRCSRID0_",",6) ; DM doc id 67 ;.I PRCVB'="" S PRCVFLG=1 Q 68 ;Q PRCVFLG 69 ; 70 ;Remove the prompt if entry is set in 414.02 Audit File 'C' x-ref 71 N PRCVFLG,PRCVL,PRCVM 72 S PRCVM=$$GET1^DIQ(410.3,PRCSRID0_",",.01) ; ext value of RIL trx 73 S PRCVL="" 74 S PRCVFLG=0 75 S PRCVL=$O(^PRCV(414.02,"C",PRCVM,PRCVL)) 76 I PRCVL'="" S PRCVFLG=1 Q 1 77 Q PRCVFLG 78 ; 79 ; 80 EXIT K %,%DT,%ZIS,PRCSRID0,DA,DIC,DIE,DIK,PRCSRIJ,K,L,PRCSRIM,PRCS,PRCSCS 81 K PRCSCT,PRCSCC,PRCSD,PRCSD1,PRCSRI,PRCSIT,PRCSL,PRCSNO,PRCSS,PRCSTC 82 K PRCSV1,PX,T1,X,X1,X2,Y,Z,Z1,Z2 83 K PRCSTIME,PRCSQUAR,^TMP($J) Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRC2.m
r613 r623 1 PRCVRC2 ;WOIFO/BMM/VAC - silently build RIL for DynaMed ; 12/3/07 10:32am 2 V ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;12/07 Code modified to fix error in GETTXN due to logic error. 6 ; Added KILL statements to eliminate finding random ^TMP global data 7 ; from other routines and to clean up ^DIC calls. 8 ; 9 ;validation, error code for PRCVRC1 10 ; 11 Q 12 ; 13 GETFY(PRCVDT) ;return the fiscal year, PRCVDT is date/time the DM 14 ;message was created (thus the date/time for RIL) 15 ; 16 Q $E(100+$E(PRCVDT,2,3)+$E(PRCVDT,4),2,3) 17 ; 18 GETQTR(PRCVDT) ;return the fiscal quarter, PRCVDT is date/time the DM 19 ;message was created (thus the date/time for RIL) 20 ; 21 N QTR S QTR=+$E(PRCVDT,4,5) 22 Q $P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QTR) 23 ; 24 GETTXN(PRCVSTR) ;obtain current transaction number (if exists) from 25 ;Transaction Number file (#410.1) 26 ;increment transaction for current use, update 410.1 entry 27 ;return new transaction number for this RIL 28 ;PRCVSTR is Entry Number, comes in as "station-fy-qtr-fcp-cc" 29 ;TXN is transaction #, PRCVRN is IEN for 410.1 entry 30 ;NOTE: CHECK 410 too, look in EN1^PRCSUT3, lines 8-10 etc. 31 ; 32 Q:$G(PRCVSTR)="" 0 33 N TXN,PRCVE,PRCVRN S TXN="",(PRCVRN,PRCVE)=0 34 ;check if Entry Number def in 410.1 35 K ATXN,^TMP("DIERR",$J),^TMP("DILIST",$J) 36 D FIND^DIC(410.1,,"1","BX",PRCVSTR,,,,,"ATXN") 37 ; 38 S TXN=+$G(ATXN("DILIST","ID",1,1)) 39 S PRCVRN=$G(ATXN("DILIST",2,1)) 40 I TXN<1 D Q:PRCVE=1 0 41 . ;TXN=0 so Entry Number not def, create new 42 . K PRCVAT S PRCVAT(410.1,"+1,",.01)=PRCVSTR 43 . S PRCVAT(410.1,"+1,",2)=DT 44 . S PRCVAT(410.1,"+1,",1)=1 45 . K ^TMP("DIERR",$J),^TMP("DILIST",$J) 46 . D UPDATE^DIE("","PRCVAT","PRCVRN") 47 . ;don't send msg here 48 . ;I $D(^TMP("DIERR",$J)) D SENDMSG(7,PRCVGL,0,1) S PRCVE=1 Q 49 . I $D(^TMP("DIERR",$J))>0 K ^TMP("DIERR",$J),^TMP("DILIST",$J) S PRCVE=1 Q 50 . S PRCVRN=PRCVRN(1) 51 S TXN=TXN+1 52 K PRCVSA S PRCVSA(410.1,PRCVRN_",",1)=TXN 53 K ^TMP("DIERR",$J),^TMP("DILIST",$J) 54 D FILE^DIE("","PRCVSA") 55 ;don't send msg here 56 ;I $D(^TMP("DILIST",$J)) D SENDMSG(7,PRCVGL,0,1) Q 0 57 I $D(^TMP("DIERR",$J))>0 K ^TMP("DIERR",$J),^TMP("DILIST",$J) Q 0 58 K ^TMP("DIERR",$J),^TMP("DILIST",$J) 59 S TXN="000"_TXN,TXN=$E(TXN,$L(TXN)-3,$L(TXN)) 60 Q TXN 61 ; 62 CHKDT(INDT) ;check the incoming date (date/time message created) against 63 ;the present date. date/time message created must be today or in 64 ;the past. if INDT is today or before today then return 1, else 65 ;return 0 66 ;both dates are in Fileman format ex. 3050503.12446 67 ; 68 Q:$G(INDT)="" 0 69 N %,PRESENT,PRCVDIFF 70 D NOW^%DTC S PRESENT=% 71 S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) 72 I PRCVDIFF'<0 Q 1 73 Q 0 74 ; 75 CHKDTN(INDT) ;check the incoming date (Date Needed By from DynaMed) 76 ;against the present date. Date Needed By must be today or in the 77 ;future. if INDT is today or after today then return 1, else return 0 78 ;both dates are in FileMan format ex. 3050503.12446 79 ; 80 Q:$G(INDT)="" 0 81 N %,PRESENT,PRCVDIFF 82 D NOW^%DTC S PRESENT=% 83 S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) 84 I PRCVDIFF'>0 Q 1 85 Q 0 86 ; 87 CHKBOC(ITEM,BOC) ;test BOC from passed-in detail record 88 ; 89 Q:$G(ITEM)="" 0 90 N PRCVIBOC 91 S PRCVIBOC=$$GET1^DIQ(441,ITEM_",",12,"I") 92 I PRCVIBOC'=BOC Q 0 93 Q 1 94 ; 95 CHKFCP(PRCVFCP,PRCVST) ;validate that FCP is in 420 96 ; 97 Q:$G(PRCVFCP)=""!($G(PRCVST)="") 0 98 N PRCVE,PRCVN,PRCVVAL 99 S PRCVVAL=1,PRCVN=0 100 S PRCVN=$$FIND1^DIC(420.01,","_PRCVST_",","",PRCVFCP_" ","B","","PRCVE") 101 I +PRCVN'>0 S PRCVVAL=0 102 Q PRCVVAL 103 ; 104 CHKITM(PRCVITM) ;check extracted item number: 105 ;1. must be greater than 100000 106 ;2. must be defined in Item Master (#441) file 107 ;3. must not be inactive (441 field 16 '=1) 108 ; 109 Q:$G(PRCVITM)="" 0 110 N CITM S CITM=0 111 ;N NITM 112 ;S NITM=$$FIND1^DIC(441,"","X",PRCVITM,"","","ATXN") 113 ;I '$D(ATXN) Q 1 114 I PRCVITM'<100000,$D(^PRC(441,"B",PRCVITM)) D 115 . I +$$GET1^DIQ(441,PRCVITM_",",16,"I")=0 S CITM=1 116 Q CITM 117 ; 118 CHKVEND(VENDN) ;check that vendor in Vendor file is active. 119 ;VENDN is Vendor number 120 ; 121 Q:+VENDN=0 0 122 N NVNDP,CHKFLG 123 S CHKFLG=0 124 I $D(^PRC(440,VENDN,0)),$$GET1^DIQ(440,VENDN_",",32,"I")="" S CHKFLG=1 125 Q CHKFLG 126 ; 127 CHKVI(VENDN,ITMN) ;check that vendor VENDN sells item ITMN 128 ;can't use $$FIND1^DIC since could be >1 cross-ref and >1 node 129 ; 130 N ITMNN,VENDP,CHKFLG 131 S (VENDP,ITMNN,CHKFLG)=0 132 Q:+VENDN=0!(+ITMN=0) CHKFLG 133 ;get item ien, quit if undef 134 S ITMNN=$O(^PRC(441,"B",ITMN,0)) 135 Q:ITMNN="" CHKFLG 136 ;get pointer to vendor ien 137 S VENDP=$O(^PRC(441,ITMNN,2,"B",VENDN,0)) 138 ;check that vendor is defined 139 I VENDP>0,$D(^PRC(440,VENDP,0)) S CHKFLG=1 140 ;if item file defined and vendor for item defined, good 141 Q CHKFLG 142 ; 143 CHKDUZ(INDUZ) ;validate that DUZ against New Person (#200) 144 ; 145 N DUZFLG S DUZFLG=0 146 Q:$G(INDUZ)="" DUZFLG 147 I $D(^VA(200,INDUZ,0)) S DUZFLG=1 148 Q DUZFLG 149 ; 150 CHKNIF(ITEM,NIF) ;use the passed-in item to check that the passed-in 151 ;NIF# is correct. return 1 if valid, 0 if not valid 152 ; 153 N PRCVINIF 154 S PRCVINIF=$$GET1^DIQ(441,ITEM_",",51) 155 I PRCVINIF=NIF Q 1 156 Q 0 157 ; 158 MAKECAP(INSTR) ;take INSTR and return an all-caps version of it 159 ; 160 Q:$G(INSTR)="" "" 161 N X,Y 162 S X=INSTR X ^%ZOSF("UPPERCASE") 163 Q Y 164 ; 165 SENDMSG(EC,PRCVGL,CTR,ERPC) ;send an alert or error message back to 166 ;DynaMed via VIE by posting "ERR" node to appropriate ^XTMP node 167 ; 168 ;the error text is currently stored in the routine PRCVRC3 169 ; 170 ;EC is the error code 171 ;use EC to get the description and severity 172 ;the message is built in ECSTR and the "ERR" node in ^XTMP is 173 ; created using passed-in message id in MID. the error message 174 ; is appended to "ERR" and is separated by other error messages 175 ; already there with a carat ("^") 176 ;PRCVGL is the ^XTMP subscript and CTR is the detail counter # 177 ;ERPC is the data piece in the line item node or header node to 178 ; which the error pertains 179 ; 180 N X S X="PRCVRC3" 181 X ^%ZOSF("TEST") I '$T Q 182 N ECSTR,OVERSTR,ERRCTR 183 S ERPC=$G(ERPC) 184 S ECSTR=ERPC_"^"_$P($T(ET+EC^PRCVRC3),";;",2),CTR=+CTR 185 I CTR'=0 D 186 . S ERRCTR=+$O(^XTMP(PRCVGL,2,CTR,"ERR",""),-1) 187 . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,2,CTR,"ERR",ERRCTR)=ECSTR 188 I CTR=0 D 189 . S ERRCTR=+$O(^XTMP(PRCVGL,1,"ERR",""),-1) 190 . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,1,"ERR",ERRCTR)=ECSTR 191 Q 192 ; 193 ADDAUD(ADDSTR) ;add "^"-pieces from ADDSTR as fields to a new record in 194 ;the Audit file #410.02 195 ; 196 ;ADDSTR pieces: DynaMed Doc ID ^ Item # ^ Vendor ^ User DUZ ^ 197 ; Last name,First name ^ RIL# ^ date/time RIL created ^ 198 ; date/time message created (DynaMed requisition) ^ date needed 199 ; 200 Q:$G(ADDSTR)="" 201 ; 202 ;set up entry 203 N PRCVA,PRCVI,PRCVP,PRCVRIL,PRCVTMP S PRCVA="",PRCVP=0 204 F PRCVI=.01,1,2,3,13,4,5,6,12 S PRCVP=PRCVP+1 D 205 . S PRCVA(414.02,"+1,",PRCVI)=$P(ADDSTR,U,PRCVP) 206 ;add record to Audit File 207 D UPDATE^DIE("","PRCVA") 208 ;if error, send bulletin 209 I $D(^TMP("DIERR",$J)) D Q 210 . S PRCVTMP="PRCVRC2",PRCVRIL=$P(ADDSTR,U,5) 211 . S XMB(1)="creating an entry in the DynaMed Audit File (#414.02)" 212 . S XMB(2)=$P(ADDSTR,U) 213 . S XMB(3)="unable to create Audit File entry" 214 . S ^TMP($J,"PRCVRC2",1,0)="",PRCVP=1 215 . S ^TMP($J,"PRCVRC2",2,0)="DynaMed Doc ID: "_$P(ADDSTR,U) 216 . S ^TMP($J,"PRCVRC2",3,0)="Item #: "_$P(ADDSTR,U,2) 217 . S ^TMP($J,"PRCVRC2",4,0)="Vendor #: "_$P(ADDSTR,U,3) 218 . S ^TMP($J,"PRCVRC2",5,0)="User DUZ: "_$P(ADDSTR,U,4) 219 . S ^TMP($J,"PRCVRC2",6,0)="RIL #: "_$P(ADDSTR,U,5) 220 . S ^TMP($J,"PRCVRC2",7,0)="Message date/time: "_$P(ADDSTR,U,6) 221 . S ^TMP($J,"PRCVRC2",8,0)="RIL create date: "_PRCVRIL 222 . S ^TMP($J,"PRCVRC2",9,0)="Date Needed: "_$P(ADDSTR,U,8) 223 . S ^TMP($J,"PRCVRC2",10,0)="Error: "_$G(^TMP("DIERR",$J,1,"TEXT",1)) 224 . S PRCVST=$P(PRCVRIL,"-"),PRCVFCP=$P(PRCVRIL,"-",4) 225 . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP) 226 Q 227 ; 1 PRCVRC2 ;WOIFO/BMM - silently build RIL for DynaMed ; 12/16/04 2 V ;;5.1;IFCAP;**81**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ;validation, error code for PRCVRC1 6 ; 7 Q 8 ; 9 GETFY(PRCVDT) ;return the fiscal year, PRCVDT is date/time the DM 10 ;message was created (thus the date/time for RIL) 11 ; 12 Q $E(100+$E(PRCVDT,2,3)+$E(PRCVDT,4),2,3) 13 ; 14 GETQTR(PRCVDT) ;return the fiscal quarter, PRCVDT is date/time the DM 15 ;message was created (thus the date/time for RIL) 16 ; 17 N QTR S QTR=+$E(PRCVDT,4,5) 18 Q $P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QTR) 19 ; 20 GETTXN(PRCVSTR) ;obtain current transaction number (if exists) from 21 ;Transaction Number file (#410.1) 22 ;increment transaction for current use, update 410.1 entry 23 ;return new transaction number for this RIL 24 ;PRCVSTR is Entry Number, comes in as "station-fy-qtr-fcp-cc" 25 ;TXN is transaction #, PRCVRN is IEN for 410.1 entry 26 ;NOTE: CHECK 410 too, look in EN1^PRCSUT3, lines 8-10 etc. 27 ; 28 Q:$G(PRCVSTR)="" 0 29 N TXN,PRCVE,PRCVRN S TXN="",(PRCVRN,PRCVE)=0 30 ;check if Entry Number def in 410.1 31 K ATXN 32 D FIND^DIC(410.1,,"1","BX",PRCVSTR,,,,,"ATXN") 33 ; 34 S TXN=+$G(ATXN("DILIST","ID",1,1)) 35 S PRCVRN=$G(ATXN("DILIST",2,1)) 36 I TXN<1 D Q:PRCVE=1 0 37 . ;TXN=0 so Entry Number not def, create new 38 . K PRCVAT S PRCVAT(410.1,"+1,",.01)=PRCVSTR 39 . S PRCVAT(410.1,"+1,",2)=DT 40 . S PRCVAT(410.1,"+1,",1)=1 41 . D UPDATE^DIE("","PRCVAT","PRCVRN") 42 . ;don't send msg here 43 . ;I $D(^TMP("DIERR",$J)) D SENDMSG(7,PRCVGL,0,1) S PRCVE=1 Q 44 . I $D(^TMP("DIERR",$J)) S PRCVE=1 Q 45 . S PRCVRN=PRCVRN(1) 46 S TXN=TXN+1 47 K PRCVSA S PRCVSA(410.1,PRCVRN_",",1)=TXN 48 D FILE^DIE("","PRCVSA") 49 ;don't send msg here 50 ;I $D(^TMP("DILIST",$J)) D SENDMSG(7,PRCVGL,0,1) Q 0 51 I $D(^TMP("DILIST",$J)) Q 0 52 S TXN="000"_TXN,TXN=$E(TXN,$L(TXN)-3,$L(TXN)) 53 Q TXN 54 ; 55 CHKDT(INDT) ;check the incoming date (date/time message created) against 56 ;the present date. date/time message created must be today or in 57 ;the past. if INDT is today or before today then return 1, else 58 ;return 0 59 ;both dates are in Fileman format ex. 3050503.12446 60 ; 61 Q:$G(INDT)="" 0 62 N %,PRESENT,PRCVDIFF 63 D NOW^%DTC S PRESENT=% 64 S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) 65 I PRCVDIFF'<0 Q 1 66 Q 0 67 ; 68 CHKDTN(INDT) ;check the incoming date (Date Needed By from DynaMed) 69 ;against the present date. Date Needed By must be today or in the 70 ;future. if INDT is today or after today then return 1, else return 0 71 ;both dates are in FileMan format ex. 3050503.12446 72 ; 73 Q:$G(INDT)="" 0 74 N %,PRESENT,PRCVDIFF 75 D NOW^%DTC S PRESENT=% 76 S PRCVDIFF=$$FMDIFF^XLFDT(PRESENT,INDT,1) 77 I PRCVDIFF'>0 Q 1 78 Q 0 79 ; 80 CHKBOC(ITEM,BOC) ;test BOC from passed-in detail record 81 ; 82 Q:$G(ITEM)="" 0 83 N PRCVIBOC 84 S PRCVIBOC=$$GET1^DIQ(441,ITEM_",",12,"I") 85 I PRCVIBOC'=BOC Q 0 86 Q 1 87 ; 88 CHKFCP(PRCVFCP,PRCVST) ;validate that FCP is in 420 89 ; 90 Q:$G(PRCVFCP)=""!($G(PRCVST)="") 0 91 N PRCVE,PRCVN,PRCVVAL 92 S PRCVVAL=1,PRCVN=0 93 S PRCVN=$$FIND1^DIC(420.01,","_PRCVST_",","",PRCVFCP_" ","B","","PRCVE") 94 I +PRCVN'>0 S PRCVVAL=0 95 Q PRCVVAL 96 ; 97 CHKITM(PRCVITM) ;check extracted item number: 98 ;1. must be greater than 100000 99 ;2. must be defined in Item Master (#441) file 100 ;3. must not be inactive (441 field 16 '=1) 101 ; 102 Q:$G(PRCVITM)="" 0 103 N CITM S CITM=0 104 ;N NITM 105 ;S NITM=$$FIND1^DIC(441,"","X",PRCVITM,"","","ATXN") 106 ;I '$D(ATXN) Q 1 107 I PRCVITM'<100000,$D(^PRC(441,"B",PRCVITM)) D 108 . I +$$GET1^DIQ(441,PRCVITM_",",16,"I")=0 S CITM=1 109 Q CITM 110 ; 111 CHKVEND(VENDN) ;check that vendor in Vendor file is active. 112 ;VENDN is Vendor number 113 ; 114 Q:+VENDN=0 0 115 N NVNDP,CHKFLG 116 S CHKFLG=0 117 I $D(^PRC(440,VENDN,0)),$$GET1^DIQ(440,VENDN_",",32,"I")="" S CHKFLG=1 118 Q CHKFLG 119 ; 120 CHKVI(VENDN,ITMN) ;check that vendor VENDN sells item ITMN 121 ;can't use $$FIND1^DIC since could be >1 cross-ref and >1 node 122 ; 123 N ITMNN,VENDP,CHKFLG 124 S (VENDP,ITMNN,CHKFLG)=0 125 Q:+VENDN=0!(+ITMN=0) CHKFLG 126 ;get item ien, quit if undef 127 S ITMNN=$O(^PRC(441,"B",ITMN,0)) 128 Q:ITMNN="" CHKFLG 129 ;get pointer to vendor ien 130 S VENDP=$O(^PRC(441,ITMNN,2,"B",VENDN,0)) 131 ;check that vendor is defined 132 I VENDP>0,$D(^PRC(440,VENDP,0)) S CHKFLG=1 133 ;if item file defined and vendor for item defined, good 134 Q CHKFLG 135 ; 136 CHKDUZ(INDUZ) ;validate that DUZ against New Person (#200) 137 ; 138 N DUZFLG S DUZFLG=0 139 Q:$G(INDUZ)="" DUZFLG 140 I $D(^VA(200,INDUZ,0)) S DUZFLG=1 141 Q DUZFLG 142 ; 143 CHKNIF(ITEM,NIF) ;use the passed-in item to check that the passed-in 144 ;NIF# is correct. return 1 if valid, 0 if not valid 145 ; 146 N PRCVINIF 147 S PRCVINIF=$$GET1^DIQ(441,ITEM_",",51) 148 I PRCVINIF=NIF Q 1 149 Q 0 150 ; 151 MAKECAP(INSTR) ;take INSTR and return an all-caps version of it 152 ; 153 Q:$G(INSTR)="" "" 154 N X,Y 155 S X=INSTR X ^%ZOSF("UPPERCASE") 156 Q Y 157 ; 158 SENDMSG(EC,PRCVGL,CTR,ERPC) ;send an alert or error message back to 159 ;DynaMed via VIE by posting "ERR" node to appropriate ^XTMP node 160 ; 161 ;the error text is currently stored in the routine PRCVRC3 162 ; 163 ;EC is the error code 164 ;use EC to get the description and severity 165 ;the message is built in ECSTR and the "ERR" node in ^XTMP is 166 ; created using passed-in message id in MID. the error message 167 ; is appended to "ERR" and is separated by other error messages 168 ; already there with a carat ("^") 169 ;PRCVGL is the ^XTMP subscript and CTR is the detail counter # 170 ;ERPC is the data piece in the line item node or header node to 171 ; which the error pertains 172 ; 173 N X S X="PRCVRC3" 174 X ^%ZOSF("TEST") I '$T Q 175 N ECSTR,OVERSTR,ERRCTR 176 S ERPC=$G(ERPC) 177 S ECSTR=ERPC_"^"_$P($T(ET+EC^PRCVRC3),";;",2),CTR=+CTR 178 I CTR'=0 D 179 . S ERRCTR=+$O(^XTMP(PRCVGL,2,CTR,"ERR",""),-1) 180 . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,2,CTR,"ERR",ERRCTR)=ECSTR 181 I CTR=0 D 182 . S ERRCTR=+$O(^XTMP(PRCVGL,1,"ERR",""),-1) 183 . S ERRCTR=ERRCTR+1,^XTMP(PRCVGL,1,"ERR",ERRCTR)=ECSTR 184 Q 185 ; 186 ADDAUD(ADDSTR) ;add "^"-pieces from ADDSTR as fields to a new record in 187 ;the Audit file #410.02 188 ; 189 ;ADDSTR pieces: DynaMed Doc ID ^ Item # ^ Vendor ^ User DUZ ^ 190 ; Last name,First name ^ RIL# ^ date/time RIL created ^ 191 ; date/time message created (DynaMed requisition) ^ date needed 192 ; 193 Q:$G(ADDSTR)="" 194 ; 195 ;set up entry 196 N PRCVA,PRCVI,PRCVP,PRCVRIL,PRCVTMP S PRCVA="",PRCVP=0 197 F PRCVI=.01,1,2,3,13,4,5,6,12 S PRCVP=PRCVP+1 D 198 . S PRCVA(414.02,"+1,",PRCVI)=$P(ADDSTR,U,PRCVP) 199 ;add record to Audit File 200 D UPDATE^DIE("","PRCVA") 201 ;if error, send bulletin 202 I $D(^TMP("DIERR",$J)) D Q 203 . S PRCVTMP="PRCVRC2",PRCVRIL=$P(ADDSTR,U,5) 204 . S XMB(1)="creating an entry in the DynaMed Audit File (#414.02)" 205 . S XMB(2)=$P(ADDSTR,U) 206 . S XMB(3)="unable to create Audit File entry" 207 . S ^TMP($J,"PRCVRC2",1,0)="",PRCVP=1 208 . S ^TMP($J,"PRCVRC2",2,0)="DynaMed Doc ID: "_$P(ADDSTR,U) 209 . S ^TMP($J,"PRCVRC2",3,0)="Item #: "_$P(ADDSTR,U,2) 210 . S ^TMP($J,"PRCVRC2",4,0)="Vendor #: "_$P(ADDSTR,U,3) 211 . S ^TMP($J,"PRCVRC2",5,0)="User DUZ: "_$P(ADDSTR,U,4) 212 . S ^TMP($J,"PRCVRC2",6,0)="RIL #: "_$P(ADDSTR,U,5) 213 . S ^TMP($J,"PRCVRC2",7,0)="Message date/time: "_$P(ADDSTR,U,6) 214 . S ^TMP($J,"PRCVRC2",8,0)="RIL create date: "_PRCVRIL 215 . S ^TMP($J,"PRCVRC2",9,0)="Date Needed: "_$P(ADDSTR,U,8) 216 . S ^TMP($J,"PRCVRC2",10,0)="Error: "_$G(^TMP("DIERR",$J,1,"TEXT",1)) 217 . S PRCVST=$P(PRCVRIL,"-"),PRCVFCP=$P(PRCVRIL,"-",4) 218 . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP) 219 Q 220 ; -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m
r613 r623 1 PRCVRE1 ;WOIFO/VC-Transmit HL7 message to IFCAP for requisition received from DynaMed ; 11/3/04 3:13pm ; 5/6/05 3:43pm 2 ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ; 5 ;An exemption from the 245 character length standard for a variable 6 ; has been requested from the SACC for reading HL7 segments into 7 ; a single variable. The limit is request to be 1K and if longer 8 ; than that the system will exit with an Application ACK reject. 9 ; Submitted 4/14/05. 10 ; 11 ;This routine processes messages from DynaMed to IFCAP to build a RIL 12 ; 13 ;HL("MID") - Message Control ID 14 ;HL7DT - Today's date in HL7 format 15 ;PRCDT - Date value 16 ;ORC Segment will repeat for each item 17 ; PRCORD - Order control should be NW for new order - ORC-1 18 ; PRCFCP - Fund control Point - ORC-3 19 ; PRCDATE - Date and time item entered - ORC-9 20 ; PRCEMP - Enter by - ORC-10 DUZ^Lname^Fname^Approving Authority 21 ; PRCCC - Cost Center - ORC-17 22 ; PRCSITE - Site Code should be 516 - ORC-21 23 ;RQD Segment will repeat for each item 24 ; PRCCTR - Item counter - RQD-1 25 ; PRCDOC - DynaMed Document number - unique per item - RQD-2 26 ; PRCITM - Item number $p1 of RQD-3 27 ; PRCQTY - Item quantity - RQD-5 28 ; PRCNEED - Date Needed - RQD-10 29 ;RQ1 Segment one segment for each RQD segment 30 ; PRCCOST - Estimated Unit Cost - RQ1-1 31 ; PRCBOC - BOC Number - RQ1-3 32 ; PRCVND - Vendor number - pointer to file 440 - RQ1-4 33 ; PRCNIF - National Item File number - RQ1-5 34 ;PRCTYP - Repetitive Item List type - default to blank 35 ;Message builds an ^XTMP to pass data to IFCAP RIL build routine. 36 ; The first node is "PRCVRE*"+the Message Control ID. The next nodes 37 ; are 0,1, and 2. The 0 node is the standard ^XTMP structure plus 38 ; $H. The $H is used to measure transmission timing. The 1 node holds 39 ; header data common to all detail items being transmitted. The 2 40 ; node holds detail information about each item ordered in a counter 41 ; sub-node. 42 ; Under the 1 and 2 nodes are "ERR" subnodes that hold error 43 ; information about each item. There can be multiple errors 44 ; associated with each item, therefore there are multiple sub-nodes 45 ; possible under each "ERR" node. 46 ;Counters 47 ; PRCCNT, ACKCNT,PRCCC1,PRCFCP1,X,X1,X2,X8,X9,I,II,LL,ERRCNT 48 ;ERRCOD - Error code from IFCAP 49 ;ERRDAT - Error data from IFCAP 50 ;ERRSTR - Error text from IFCAP 51 ;ERRSUB - A substring of ERRSTR 52 ;ERRS - Error substring from IFCAP 53 ;SEVER - Error severity value - W or E 54 ;TOT,TOTERR,TOTGOOD,TOTREC - Counters of errors returned to DM 55 ;FLDNO - Field identified in an error message 56 ;ERRVAL - ERROR FLAG 57 ;ERRARY - Message Error array sent to Prosthetics 58 ;ERRLOC - Location of error sent in ACK 59 ;PRCCS, PRCFS, PRCRS - Field delimiters 60 ;PRCNODE - Message segment identifier 61 ;Temporary Globals 62 ; ^TMP("PRCVRIL",$J,"ACK") - Acknowledgement is ok 63 ; ^TMP("PRCVRIL",$J,"NAK") - Acknowledgement is not ok 64 ; ^TMP("HLA",$J) - Message array sent to DynaMed 65 ; ^XTMP("PRCVRE*"_Message Control ID,) - Data sent to IFCAP 66 ;Temporary variables 67 ; TMP,MSGFLG,X, X1 68 ;PRCHD - Array to hold map between HL7 and XTMP for Header info 69 ;PRCDET - Array to hold map between HL7 and XTMP for Detail info 70 ;PRCVERR - Array to hold error messages for MailMan 71 ;PRCSUB - XTMP first node 72 ;PRCSUB2 - Second $p of PRCSUB equal to Message Control ID 73 ;PRCVRES - Return variable from GENACK - Note:this doesn't work. 74 ;PRCVINDX - Index number into XTMP to keep track of number of items 75 ; 76 Q 77 ; 78 BEGIN N PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE 79 N PRCDOC,PRCITM,PRCQTY,PRCFCP,PRCCC 80 N PRCCOST,PRCVND,PRCBOC,PRCNEED,PRCNIF 81 N PRCSUB,PRCSUB2,PRCDT,PRCVINDX 82 N ERRARY,PRCCS,PRCFS,PRCRS,PRCNODE,PRCNODE2 83 N ACKCNT,NODE1,NODE2,PRCCTR,PRCCNT,PRCI,PRCJ,MID 84 N X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1,LENVAL 85 ; Fields used in PRCVREA are NEWed and KILLed here 86 N MSG,MSGFLG,DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,ERRSUB,FLDNO 87 N I,IL,ERRTXT,I,II,III,J,SEVER,TOT,TOTERR,TOTGOOD,TOTREC 88 N PRCDET,PRCHD,PRCVERR,MYRESULT,ERRLOC,PRCVRES 89 D:'$D(U) DT^DICRW 90 S PRCDT=$$NOW^XLFDT 91 S HL7DT=$$FMTHL7^XLFDT(PRCDT),PRCDT=HL7DT 92 S PRCSUB="PRCVRE*"_HL("MID") K ^XTMP(PRCSUB) 93 D BUILD 94 S PRCCNT=0 95 S PRCFS=$G(HL("FS")),PRCCS=$E($G(HL("ECH"))),PRCRS=$E($G(HL("ECH")),2) 96 D START 97 D CLEANUP 98 Q 99 ; 100 START ;This will read the incoming message from DynaMed and build ^TMP 101 ; 102 SETACK ; Set up information for the ACK or NAK 103 ; 104 K ^TMP("PRCVRIL",$J) 105 S ^TMP("PRCVRIL",$J,"ACK",1)="MSA"_PRCFS_"AA"_PRCFS_HL("MID") 106 S ^TMP("PRCVRIL",$J,"NAK",1)="MSA"_PRCFS_"AE"_PRCFS_HL("MID") 107 S ^TMP("PRCVRIL",$J,"NAK",2)="ERR"_PRCFS 108 S ACKCNT=2 109 ; 110 ;If this is not the right message quit 111 ; 112 I HL("MTN")'="OMN" D Q 113 .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Message Type: "_HL("MTN") 114 .D NAKIT^PRCVREA 115 I HL("ETN")'="O07" D Q 116 .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Event Type: "_HL("ETN") 117 .D NAKIT^PRCVREA 118 ; 119 S ERRARY(1)="OK" 120 ; 121 ;Read the message and build the ^TMP global 122 ; 123 K ^TMP("PRCVRE",$J) 124 S PRCI="" 125 F PRCI=1:1 X HLNEXT Q:HLQUIT'>0 D 126 .S ^TMP("PRCVRE",$J,PRCSUB,PRCI)=HLNODE,PRCJ=0 127 .F S PRCJ=$O(HLNODE(PRCJ)) Q:'PRCJ S ^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)=HLNODE(PRCJ) 128 .I $E(HLNODE,1,3)="ORC" D 129 ..S PRCFCP=$P(HLNODE,PRCFS,4),PRCCC=$P(HLNODE,PRCFS,18) 130 ..S TMP($J,PRCFCP,PRCCC)="" 131 ; 132 ;Validate that there is only one FCP and CC 133 S PRCFCP="",PRCFCP1="" 134 ; Prevent PRCCC1 undefined PRC*5.1*119 135 S PRCCC1="" 136 F X8=1:1 S PRCFCP=$O(TMP($J,PRCFCP)) Q:PRCFCP="" D 137 .S PRCFCP1=X8 138 .S PRCCC="" 139 .F X9=1:1 S PRCCC=$O(TMP($J,PRCFCP,PRCCC)) Q:PRCCC="" D 140 ..S PRCCC1=X9 141 I (PRCFCP1>1)!(PRCCC1>1) D Q 142 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN") D NAKIT^PRCVREA 143 ; 144 PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP 145 ; 146 S PRCI=0,PRCJ=0,LENVAL="OK" 147 F S PRCI=$O(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:PRCI="" Q:LENVAL="NOTOK" D 148 .S NODE1=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:NODE1="" 149 .F PRCJ=1:1 D Q:$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))="" 150 ..S NODE2=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)) 151 ..I $L(NODE1)+$L(NODE2)>1024 S LENVAL="NOTOK" Q 152 ..S NODE1=NODE1_NODE2 153 .Q:LENVAL="NOTOK" 154 .S PRCNODE=$E(NODE1,1,3) 155 .; 156 .; IF MSH segment ignore the record 157 .; 158 .I PRCNODE="MSH" Q 159 .S PRCNODE2=$E(NODE1,5,$L(NODE1)) 160 .; 161 .; If ORC segment process the record 162 .; 163 .I PRCNODE="ORC" D Q 164 ..I $D(^XTMP(PRCSUB,1))'=0 Q 165 ..S PRCORD=$P(PRCNODE2,PRCFS,1),DYNADATE=$P(PRCNODE2,PRCFS,9),PRCEMP=$P($P(PRCNODE2,PRCFS,10),PRCCS,1,3),PRCSITE=$P(PRCNODE2,PRCFS,21) 166 ..S PRCFCP=$P(PRCNODE2,PRCFS,3),PRCCC=$P(PRCNODE2,PRCFS,17) 167 ..S PRCDATE=$$HL7TFM^XLFDT(DYNADATE) 168 ..S $P(^XTMP(PRCSUB,1),U,1)=0 169 ..S $P(^XTMP(PRCSUB,1),U,4)=PRCORD,$P(^XTMP(PRCSUB,1),U,5)=PRCSITE 170 ..S $P(^XTMP(PRCSUB,1),U,6)=PRCDATE,$P(^XTMP(PRCSUB,1),U,7)=PRCEMP 171 .; 172 .; If RQD segment process the record 173 .; 174 .I PRCNODE="RQD" D Q 175 ..S PRCCTR=$P(PRCNODE2,PRCFS,1) 176 ..S PRCDOC=$P(PRCNODE2,PRCFS,2),PRCITM=$P(PRCNODE2,PRCFS,3) 177 ..S PRCQTY=$P(PRCNODE2,PRCFS,5),DYNADATE=$P(PRCNODE2,PRCFS,10) 178 ..S PRCNEED=$$HL7TFM^XLFDT(DYNADATE) 179 .; 180 .;If RQ1 segment process the record and build the XTMP global record 181 .; 182 .I PRCNODE="RQ1" D Q 183 ..S PRCCOST=$P(PRCNODE2,PRCFS,1),PRCBOC=$P(PRCNODE2,PRCFS,3),PRCVND=$P(PRCNODE2,PRCFS,4),PRCNIF=$P(PRCNODE2,PRCFS,5) 184 ..; 185 ..; Now build the XTMP record 186 ..; 187 ..S PRCVINDX=$P($G(^XTMP(PRCSUB,1)),U,1) 188 ..I PRCCTR>PRCVINDX S $P(^XTMP(PRCSUB,1),U,1)=PRCCTR 189 ..S $P(^XTMP(PRCSUB,1),U,2)=PRCFCP 190 ..S $P(^XTMP(PRCSUB,1),U,3)=PRCCC 191 ..S ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC 192 ; 193 I LENVAL="NOTOK" D Q 194 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K" 195 .D NAKIT^PRCVREA 196 .K ^XTMP(PRCSUB) 197 D CALLIT^PRCVREA 198 Q 199 ; 200 BUILD ;Build the ^XTMP global zero node record. 201 ; 202 S XX=$$HTFM^XLFDT($H,1) 203 S X1=$$FMADD^XLFDT(XX,5) 204 S ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$H 205 Q 206 ; 207 CLEANUP ;This area will kill all temporary globals and variables 208 ; 209 K ^TMP("PRCVRE",$J),TMP($J) 210 K ^TMP("HLA",$J) 211 K ^TMP("PRCVRIL",$J) 212 K PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC 213 K PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC 214 K PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED 215 K PRCFS,PRCCS,PRCRS,PRCVINDX 216 K ERRARY 217 K PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ 218 K ACKCNT,NODE1,NODE2,LENVAL 219 K X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1 220 ;Fields killed here are used in PRCVREA 221 K MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB 222 K DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER 223 K TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES 224 Q 1 PRCVRE1 ;WOIFO/VC-Transmit HL7 message to IFCAP for requisition received from DynaMed ; 11/3/04 3:13pm ; 5/6/05 3:43pm 2 ;;5.1;IFCAP;**81**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified 4 ; 5 ;An exemption from the 245 character length standard for a variable 6 ; has been requested from the SACC for reading HL7 segments into 7 ; a single variable. The limit is request to be 1K and if longer 8 ; than that the system will exit with an Application ACK reject. 9 ; Submitted 4/14/05. 10 ; 11 ;This routine processes messages from DynaMed to IFCAP to build a RIL 12 ; 13 ;HL("MID") - Message Control ID 14 ;HL7DT - Today's date in HL7 format 15 ;PRCDT - Date value 16 ;ORC Segment will repeat for each item 17 ; PRCORD - Order control should be NW for new order - ORC-1 18 ; PRCFCP - Fund control Point - ORC-3 19 ; PRCDATE - Date and time item entered - ORC-9 20 ; PRCEMP - Enter by - ORC-10 DUZ^Lname^Fname^Approving Authority 21 ; PRCCC - Cost Center - ORC-17 22 ; PRCSITE - Site Code should be 516 - ORC-21 23 ;RQD Segment will repeat for each item 24 ; PRCCTR - Item counter - RQD-1 25 ; PRCDOC - DynaMed Document number - unique per item - RQD-2 26 ; PRCITM - Item number $p1 of RQD-3 27 ; PRCQTY - Item quantity - RQD-5 28 ; PRCNEED - Date Needed - RQD-10 29 ;RQ1 Segment one segment for each RQD segment 30 ; PRCCOST - Estimated Unit Cost - RQ1-1 31 ; PRCBOC - BOC Number - RQ1-3 32 ; PRCVND - Vendor number - pointer to file 440 - RQ1-4 33 ; PRCNIF - National Item File number - RQ1-5 34 ;PRCTYP - Repetitive Item List type - default to blank 35 ;Message builds an ^XTMP to pass data to IFCAP RIL build routine. 36 ; The first node is "PRCVRE*"+the Message Control ID. The next nodes 37 ; are 0,1, and 2. The 0 node is the standard ^XTMP structure plus 38 ; $H. The $H is used to measure transmission timing. The 1 node holds 39 ; header data common to all detail items being transmitted. The 2 40 ; node holds detail information about each item ordered in a counter 41 ; sub-node. 42 ; Under the 1 and 2 nodes are "ERR" subnodes that hold error 43 ; information about each item. There can be multiple errors 44 ; associated with each item, therefore there are multiple sub-nodes 45 ; possible under each "ERR" node. 46 ;Counters 47 ; PRCCNT, ACKCNT,PRCCC1,PRCFCP1,X,X1,X2,X8,X9,I,II,LL,ERRCNT 48 ;ERRCOD - Error code from IFCAP 49 ;ERRDAT - Error data from IFCAP 50 ;ERRSTR - Error text from IFCAP 51 ;ERRSUB - A substring of ERRSTR 52 ;ERRS - Error substring from IFCAP 53 ;SEVER - Error severity value - W or E 54 ;TOT,TOTERR,TOTGOOD,TOTREC - Counters of errors returned to DM 55 ;FLDNO - Field identified in an error message 56 ;ERRVAL - ERROR FLAG 57 ;ERRARY - Message Error array sent to Prosthetics 58 ;ERRLOC - Location of error sent in ACK 59 ;PRCCS, PRCFS, PRCRS - Field delimiters 60 ;PRCNODE - Message segment identifier 61 ;Temporary Globals 62 ; ^TMP("PRCVRIL",$J,"ACK") - Acknowledgement is ok 63 ; ^TMP("PRCVRIL",$J,"NAK") - Acknowledgement is not ok 64 ; ^TMP("HLA",$J) - Message array sent to DynaMed 65 ; ^XTMP("PRCVRE*"_Message Control ID,) - Data sent to IFCAP 66 ;Temporary variables 67 ; TMP,MSGFLG,X, X1 68 ;PRCHD - Array to hold map between HL7 and XTMP for Header info 69 ;PRCDET - Array to hold map between HL7 and XTMP for Detail info 70 ;PRCVERR - Array to hold error messages for MailMan 71 ;PRCSUB - XTMP first node 72 ;PRCSUB2 - Second $p of PRCSUB equal to Message Control ID 73 ;PRCVRES - Return variable from GENACK - Note:this doesn't work. 74 ;PRCVINDX - Index number into XTMP to keep track of number of items 75 ; 76 Q 77 ; 78 BEGIN N PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE 79 N PRCDOC,PRCITM,PRCQTY,PRCFCP,PRCCC 80 N PRCCOST,PRCVND,PRCBOC,PRCNEED,PRCNIF 81 N PRCSUB,PRCSUB2,PRCDT,PRCVINDX 82 N ERRARY,PRCCS,PRCFS,PRCRS,PRCNODE,PRCNODE2 83 N ACKCNT,NODE1,NODE2,PRCCTR,PRCCNT,PRCI,PRCJ,MID 84 N X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1,LENVAL 85 ; Fields used in PRCVREA are NEWed and KILLed here 86 N MSG,MSGFLG,DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,ERRSUB,FLDNO 87 N I,IL,ERRTXT,I,II,III,J,SEVER,TOT,TOTERR,TOTGOOD,TOTREC 88 N PRCDET,PRCHD,PRCVERR,MYRESULT,ERRLOC,PRCVRES 89 D:'$D(U) DT^DICRW 90 S PRCDT=$$NOW^XLFDT 91 S HL7DT=$$FMTHL7^XLFDT(PRCDT),PRCDT=HL7DT 92 S PRCSUB="PRCVRE*"_HL("MID") K ^XTMP(PRCSUB) 93 D BUILD 94 S PRCCNT=0 95 S PRCFS=$G(HL("FS")),PRCCS=$E($G(HL("ECH"))),PRCRS=$E($G(HL("ECH")),2) 96 D START 97 D CLEANUP 98 Q 99 ; 100 START ;This will read the incoming message from DynaMed and build ^TMP 101 ; 102 SETACK ; Set up information for the ACK or NAK 103 ; 104 K ^TMP("PRCVRIL",$J) 105 S ^TMP("PRCVRIL",$J,"ACK",1)="MSA"_PRCFS_"AA"_PRCFS_HL("MID") 106 S ^TMP("PRCVRIL",$J,"NAK",1)="MSA"_PRCFS_"AE"_PRCFS_HL("MID") 107 S ^TMP("PRCVRIL",$J,"NAK",2)="ERR"_PRCFS 108 S ACKCNT=2 109 ; 110 ;If this is not the right message quit 111 ; 112 I HL("MTN")'="OMN" D Q 113 .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Message Type: "_HL("MTN") 114 .D NAKIT^PRCVREA 115 I HL("ETN")'="O07" D Q 116 .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Event Type: "_HL("ETN") 117 .D NAKIT^PRCVREA 118 ; 119 S ERRARY(1)="OK" 120 ; 121 ;Read the message and build the ^TMP global 122 ; 123 K ^TMP("PRCVRE",$J) 124 S PRCI="" 125 F PRCI=1:1 X HLNEXT Q:HLQUIT'>0 D 126 .S ^TMP("PRCVRE",$J,PRCSUB,PRCI)=HLNODE,PRCJ=0 127 .F S PRCJ=$O(HLNODE(PRCJ)) Q:'PRCJ S ^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)=HLNODE(PRCJ) 128 .I $E(HLNODE,1,3)="ORC" D 129 ..S PRCFCP=$P(HLNODE,PRCFS,4),PRCCC=$P(HLNODE,PRCFS,18) 130 ..S TMP($J,PRCFCP,PRCCC)="" 131 ; 132 ;Validate that there is only one FCP and CC 133 S PRCFCP="",PRCFCP1="" 134 F X8=1:1 S PRCFCP=$O(TMP($J,PRCFCP)) Q:PRCFCP="" D 135 .S PRCFCP1=X8 136 .S PRCCC="" 137 .F X9=1:1 S PRCCC=$O(TMP($J,PRCFCP,PRCCC)) Q:PRCCC="" D 138 ..S PRCCC1=X9 139 I (PRCFCP1>1)!(PRCCC1>1) D Q 140 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN") D NAKIT^PRCVREA 141 ; 142 PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP 143 ; 144 S PRCI=0,PRCJ=0,LENVAL="OK" 145 F S PRCI=$O(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:PRCI="" Q:LENVAL="NOTOK" D 146 .S NODE1=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:NODE1="" 147 .F PRCJ=1:1 D Q:$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))="" 148 ..S NODE2=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)) 149 ..I $L(NODE1)+$L(NODE2)>1024 S LENVAL="NOTOK" Q 150 ..S NODE1=NODE1_NODE2 151 .Q:LENVAL="NOTOK" 152 .S PRCNODE=$E(NODE1,1,3) 153 .; 154 .; IF MSH segment ignore the record 155 .; 156 .I PRCNODE="MSH" Q 157 .S PRCNODE2=$E(NODE1,5,$L(NODE1)) 158 .; 159 .; If ORC segment process the record 160 .; 161 .I PRCNODE="ORC" D Q 162 ..I $D(^XTMP(PRCSUB,1))'=0 Q 163 ..S PRCORD=$P(PRCNODE2,PRCFS,1),DYNADATE=$P(PRCNODE2,PRCFS,9),PRCEMP=$P($P(PRCNODE2,PRCFS,10),PRCCS,1,3),PRCSITE=$P(PRCNODE2,PRCFS,21) 164 ..S PRCFCP=$P(PRCNODE2,PRCFS,3),PRCCC=$P(PRCNODE2,PRCFS,17) 165 ..S PRCDATE=$$HL7TFM^XLFDT(DYNADATE) 166 ..S $P(^XTMP(PRCSUB,1),U,1)=0 167 ..S $P(^XTMP(PRCSUB,1),U,4)=PRCORD,$P(^XTMP(PRCSUB,1),U,5)=PRCSITE 168 ..S $P(^XTMP(PRCSUB,1),U,6)=PRCDATE,$P(^XTMP(PRCSUB,1),U,7)=PRCEMP 169 .; 170 .; If RQD segment process the record 171 .; 172 .I PRCNODE="RQD" D Q 173 ..S PRCCTR=$P(PRCNODE2,PRCFS,1) 174 ..S PRCDOC=$P(PRCNODE2,PRCFS,2),PRCITM=$P(PRCNODE2,PRCFS,3) 175 ..S PRCQTY=$P(PRCNODE2,PRCFS,5),DYNADATE=$P(PRCNODE2,PRCFS,10) 176 ..S PRCNEED=$$HL7TFM^XLFDT(DYNADATE) 177 .; 178 .;If RQ1 segment process the record and build the XTMP global record 179 .; 180 .I PRCNODE="RQ1" D Q 181 ..S PRCCOST=$P(PRCNODE2,PRCFS,1),PRCBOC=$P(PRCNODE2,PRCFS,3),PRCVND=$P(PRCNODE2,PRCFS,4),PRCNIF=$P(PRCNODE2,PRCFS,5) 182 ..; 183 ..; Now build the XTMP record 184 ..; 185 ..S PRCVINDX=$P($G(^XTMP(PRCSUB,1)),U,1) 186 ..I PRCCTR>PRCVINDX S $P(^XTMP(PRCSUB,1),U,1)=PRCCTR 187 ..S $P(^XTMP(PRCSUB,1),U,2)=PRCFCP 188 ..S $P(^XTMP(PRCSUB,1),U,3)=PRCCC 189 ..S ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC 190 ; 191 I LENVAL="NOTOK" D Q 192 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K" 193 .D NAKIT^PRCVREA 194 .K ^XTMP(PRCSUB) 195 D CALLIT^PRCVREA 196 Q 197 ; 198 BUILD ;Build the ^XTMP global zero node record. 199 ; 200 S XX=$$HTFM^XLFDT($H,1) 201 S X1=$$FMADD^XLFDT(XX,5) 202 S ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$H 203 Q 204 ; 205 CLEANUP ;This area will kill all temporary globals and variables 206 ; 207 K ^TMP("PRCVRE",$J),TMP($J) 208 K ^TMP("HLA",$J) 209 K ^TMP("PRCVRIL",$J) 210 K PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC 211 K PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC 212 K PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED 213 K PRCFS,PRCCS,PRCRS,PRCVINDX 214 K ERRARY 215 K PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ 216 K ACKCNT,NODE1,NODE2,LENVAL 217 K X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1 218 ;Fields killed here are used in PRCVREA 219 K MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB 220 K DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER 221 K TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES 222 Q -
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVREA.m
r613 r623 1 PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 2/29/08 1:54pm 2 ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified 4 ; 5 CALLIT ;Call the IFCAP RIL build Routine 6 ; 7 D EN^PRCVRC1(PRCSUB) 8 ; 9 SETUP S PRCHD(1)="" 10 ;Added 1,"T" node to stop crash 11 S PRCHD(1,"T")="ORDER HEADER INFO" 12 S PRCHD(2)="ORC"_PRCCS_PRCCS_3 13 S PRCHD(2,"T")="FUND CONTROL POINT" 14 S PRCHD(3)="ORC"_PRCCS_PRCCS_17 15 S PRCHD(3,"T")="COST CENTER" 16 S PRCHD(4)="" 17 S PRCHD(5)="ORC"_PRCCS_PRCCS_21 18 S PRCHD(5,"T")="SITE NUMBER" 19 S PRCHD(6)="" 20 S PRCHD(7)="ORC"_PRCCS_PRCCS_10 21 S PRCHD(7,"T")="DUZ" 22 S PRCHD(8)="ORC"_PRCCS_PRCCS_10 23 S PRCHD(8,"T")="LAST NAME" 24 S PRCHD(9)="ORC"_PRCCS_PRCCS_11 25 S PRCHD(9,"T")="FIRST NAME" 26 S PRCDET(1)="RQD"_PRCCS_PRCCS_3 27 S PRCDET(1,"T")="ITEM NUMBER" 28 S PRCDET(2)="RQD"_PRCCS_PRCCS_5 29 S PRCDET(2,"T")="QUANTITY" 30 S PRCDET(3)="RQ1"_PRCCS_PRCCS_4 31 S PRCDET(3,"T")="VENDOR ID" 32 S PRCDET(4)="RQ1"_PRCCS_PRCCS_1 33 S PRCDET(4,"T")="UNIT COST" 34 S PRCDET(5)="RQD"_PRCCS_PRCCS_10 35 S PRCDET(5,"T")="DATE NEEDED" 36 S PRCDET(6)="RQD"_PRCCS_PRCCS_2 37 S PRCDET(6,"T")="DYNAMED DOCUMENT ID" 38 S PRCDET(7)="RQ1"_PRCCS_PRCCS_5 39 S PRCDET(7,"T")="NIF NUMBER" 40 S PRCDET(8)="RQ1"_PRCCS_PRCCS_3 41 S PRCDET(8,"T")="BOC" 42 ;Check if IFCAP has returned any errors 43 ; 44 S ERRCNT=1 45 S PRCVERR(0)="0" 46 HEAD ;If there are errors in the "1" sub-segment, add all errors to all 47 ; line items 48 S ERRCNT=1,MSGFLG=0,PRCSUB2=$P(PRCSUB,"*",2) 49 I $D(^XTMP(PRCSUB,1,"ERR"))>0 D 50 .S II=0 51 .F I=1:1 S II=$O(^XTMP(PRCSUB,1,"ERR",II)) Q:II="" D 52 ..S ERRDAT=$G(^XTMP(PRCSUB,1,"ERR",II)) 53 ..Q:ERRDAT="" 54 ..S MSGFLG=1 55 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 56 ..S SEVER=$P(ERRDAT,U,4) 57 ..S ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS 58 ..S PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT,ERRCNT=ERRCNT+1 59 ..S J=0 60 ..F IL=1:1 S J=$O(^XTMP(PRCSUB,2,J)) Q:J="" D 61 ...S ERRSUB=$P(ERRSTR,PRCFS,3) 62 ...S $P(ERRSUB,U,2)=J 63 ...S $P(ERRSTR,PRCFS,3)=ERRSUB 64 ...;S $P($P(ERRSTR,PRCFS,3),U,2)=J 65 ...S $P(ERRSTR,PRCFS,7)=$P($G(^XTMP(PRCSUB,2,J)),U,6) 66 ...S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 67 DETAIL ;If there are errors in the detail lines, add them 68 S II=0 69 F I=1:1 S II=$O(^XTMP(PRCSUB,2,II)) Q:II="" D 70 .S DOCID=$P(^XTMP(PRCSUB,2,II),U,6) 71 .S III=0 72 .F J=1:1 S III=$O(^XTMP(PRCSUB,2,II,"ERR",III)) Q:III="" D 73 ..S ERRDAT=$G(^XTMP(PRCSUB,2,II,"ERR",III)) 74 ..Q:ERRDAT="" 75 ..S MSGFLG=1 76 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 77 ..S ERRLOC=PRCDET(FLDNO),$P(ERRLOC,U,2)=II 78 ..S SEVER=$P(ERRDAT,U,4) 79 ..S ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID 80 ..S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 81 ..S PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID 82 ..S ERRCNT=ERRCNT+1 83 ; 84 I MSGFLG=0 D ACKIT,CLEANUP^PRCVRE1 Q 85 SETNTE ; If there are errors set an NTE segment 86 ; 87 S TOT=0,TOTREC=0,TOTERR=0 88 F I=1:1 S TOT=$O(^XTMP(PRCSUB,2,TOT)) Q:TOT="" D 89 .S TOTREC=TOT 90 .I $D(^XTMP(PRCSUB,2,TOT,"ERR"))>0 D 91 ..S ERRS=0 92 ..F J=1:1 S ERRS=$O(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)) Q:ERRS="" D 93 ...S SEVER=$P($G(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4) 94 ...I SEVER'="W" S TOTERR=TOTERR+1,ERRS=99 95 I $D(^XTMP(PRCSUB,2,"ERR",1))>1 S TOTERR=TOTREC 96 S TOTGOOD=TOTREC-TOTERR 97 S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD,ACKCNT=ACKCNT+1 98 D NAKIT,CLEANUP^PRCVRE1 Q 99 ; 100 NAKIT ;Send an acknowledgement that the message is rejected 101 ; 102 I HL("APAT")'="AL" Q 103 S MSG="" 104 F I=1:1 S MSG=$O(^TMP("PRCVRIL",$J,"NAK",MSG)) Q:MSG="" D 105 .S ^TMP("HLA",$J,I)=^TMP("PRCVRIL",$J,"NAK",MSG) 106 S PRCVRES="" 107 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 108 ;I +$P(PRCVRES,U,2) D 109 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 110 MAIL ;Send MailMan message with error 111 Q:LENVAL="NOTOK" 112 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 113 S XMSUB="RIL build errors in HL7 message "_HL("MID")_" " 114 S XMDUZ="IFCAP/DynaMed Interface" 115 S XMTEXT="PRCVERR(" 116 D GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP) 117 D ^XMD 118 K XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 119 Q 120 ; 121 ACKIT ;Send an acknowledgement that everything went fine 122 ; 123 I HL("APAT")'="AL" Q 124 F I=1:1:1 S ^TMP("HLA",$J,I)=$G(^TMP("PRCVRIL",$J,"ACK",I)) 125 ; 126 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 127 ;I +P(PRCVRES,U,2) D 128 ;.I $D(ERRCNT)=0 S ERRCNT=1 129 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 130 ;.D MAIL 131 Q 1 PRCVREA ;WOIFO/VC-Transmit HL7 message to IFCAP for RIL(cont);11/24/03 ; 4/26/05 2:42pm 2 ;;5.1;IFCAP;**81**;Oct 20, 2000 3 ;Per VHA Directive 10-93-142, this routine should not be modified 4 ; 5 CALLIT ;Call the IFCAP RIL build Routine 6 ; 7 D EN^PRCVRC1(PRCSUB) 8 ; 9 SETUP S PRCHD(1)="" 10 S PRCHD(2)="ORC"_PRCCS_PRCCS_3 11 S PRCHD(2,"T")="FUND CONTROL POINT" 12 S PRCHD(3)="ORC"_PRCCS_PRCCS_17 13 S PRCHD(3,"T")="COST CENTER" 14 S PRCHD(4)="" 15 S PRCHD(5)="ORC"_PRCCS_PRCCS_21 16 S PRCHD(5,"T")="SITE NUMBER" 17 S PRCHD(6)="" 18 S PRCHD(7)="ORC"_PRCCS_PRCCS_10 19 S PRCHD(7,"T")="DUZ" 20 S PRCHD(8)="ORC"_PRCCS_PRCCS_10 21 S PRCHD(8,"T")="LAST NAME" 22 S PRCHD(9)="ORC"_PRCCS_PRCCS_11 23 S PRCHD(9,"T")="FIRST NAME" 24 S PRCDET(1)="RQD"_PRCCS_PRCCS_3 25 S PRCDET(1,"T")="ITEM NUMBER" 26 S PRCDET(2)="RQD"_PRCCS_PRCCS_5 27 S PRCDET(2,"T")="QUANTITY" 28 S PRCDET(3)="RQ1"_PRCCS_PRCCS_4 29 S PRCDET(3,"T")="VENDOR ID" 30 S PRCDET(4)="RQ1"_PRCCS_PRCCS_1 31 S PRCDET(4,"T")="UNIT COST" 32 S PRCDET(5)="RQD"_PRCCS_PRCCS_10 33 S PRCDET(5,"T")="DATE NEEDED" 34 S PRCDET(6)="RQD"_PRCCS_PRCCS_2 35 S PRCDET(6,"T")="DYNAMED DOCUMENT ID" 36 S PRCDET(7)="RQ1"_PRCCS_PRCCS_5 37 S PRCDET(7,"T")="NIF NUMBER" 38 S PRCDET(8)="RQ1"_PRCCS_PRCCS_3 39 S PRCDET(8,"T")="BOC" 40 ;Check if IFCAP has returned any errors 41 ; 42 S ERRCNT=1 43 S PRCVERR(0)="0" 44 HEAD ;If there are errors in the "1" sub-segment, add all errors to all 45 ; line items 46 S ERRCNT=1,MSGFLG=0,PRCSUB2=$P(PRCSUB,"*",2) 47 I $D(^XTMP(PRCSUB,1,"ERR"))>0 D 48 .S II=0 49 .F I=1:1 S II=$O(^XTMP(PRCSUB,1,"ERR",II)) Q:II="" D 50 ..S ERRDAT=$G(^XTMP(PRCSUB,1,"ERR",II)) 51 ..Q:ERRDAT="" 52 ..S MSGFLG=1 53 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 54 ..S SEVER=$P(ERRDAT,U,4) 55 ..S ERRSTR="ERR"_PRCFS_PRCFS_PRCHD(FLDNO)_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS 56 ..S PRCVERR(ERRCNT)="Error in Requisition Header for "_PRCHD(FLDNO,"T")_" from HL7 MESSAGE "_PRCSUB2_" "_ERRCOD_" "_ERRTXT,ERRCNT=ERRCNT+1 57 ..S J=0 58 ..F IL=1:1 S J=$O(^XTMP(PRCSUB,2,J)) Q:J="" D 59 ...S ERRSUB=$P(ERRSTR,PRCFS,3) 60 ...S $P(ERRSUB,U,2)=J 61 ...S $P(ERRSTR,PRCFS,3)=ERRSUB 62 ...;S $P($P(ERRSTR,PRCFS,3),U,2)=J 63 ...S $P(ERRSTR,PRCFS,7)=$P($G(^XTMP(PRCSUB,2,J)),U,6) 64 ...S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 65 DETAIL ;If there are errors in the detail lines, add them 66 S II=0 67 F I=1:1 S II=$O(^XTMP(PRCSUB,2,II)) Q:II="" D 68 .S DOCID=$P(^XTMP(PRCSUB,2,II),U,6) 69 .S III=0 70 .F J=1:1 S III=$O(^XTMP(PRCSUB,2,II,"ERR",III)) Q:III="" D 71 ..S ERRDAT=$G(^XTMP(PRCSUB,2,II,"ERR",III)) 72 ..Q:ERRDAT="" 73 ..S MSGFLG=1 74 ..S FLDNO=$P(ERRDAT,U,1),ERRCOD="PRCV"_$P(ERRDAT,U,2),ERRTXT=$P(ERRDAT,U,3) 75 ..S ERRLOC=PRCDET(FLDNO),$P(ERRLOC,U,2)=II 76 ..S SEVER=$P(ERRDAT,U,4) 77 ..S ERRSTR="ERR"_PRCFS_PRCFS_ERRLOC_PRCFS_"207"_PRCCS_"Application internal error"_PRCCS_"HL70357"_PRCFS_SEVER_PRCFS_ERRCOD_PRCCS_ERRTXT_PRCFS_DOCID 78 ..S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)=ERRSTR,ACKCNT=ACKCNT+1 79 ..S PRCVERR(ERRCNT)="Error in detail for Message Control ID "_PRCSUB2_". Field in error - "_PRCDET(FLDNO,"T")_". "_ERRTXT_" DynaMed Doc ID "_DOCID 80 ..S ERRCNT=ERRCNT+1 81 ; 82 I MSGFLG=0 D ACKIT,CLEANUP^PRCVRE1 Q 83 SETNTE ; If there are errors set an NTE segment 84 ; 85 S TOT=0,TOTREC=0,TOTERR=0 86 F I=1:1 S TOT=$O(^XTMP(PRCSUB,2,TOT)) Q:TOT="" D 87 .S TOTREC=TOT 88 .I $D(^XTMP(PRCSUB,2,TOT,"ERR"))>0 D 89 ..S ERRS=0 90 ..F J=1:1 S ERRS=$O(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)) Q:ERRS="" D 91 ...S SEVER=$P($G(^XTMP(PRCSUB,2,TOT,"ERR",ERRS)),U,4) 92 ...I SEVER'="W" S TOTERR=TOTERR+1,ERRS=99 93 I $D(^XTMP(PRCSUB,2,"ERR",1))>1 S TOTERR=TOTREC 94 S TOTGOOD=TOTREC-TOTERR 95 S ^TMP("PRCVRIL",$J,"NAK",ACKCNT)="NTE"_PRCFS_PRCFS_PRCFS_TOTREC_"-"_TOTERR_"-"_TOTGOOD,ACKCNT=ACKCNT+1 96 D NAKIT,CLEANUP^PRCVRE1 Q 97 ; 98 NAKIT ;Send an acknowledgement that the message is rejected 99 ; 100 I HL("APAT")'="AL" Q 101 S MSG="" 102 F I=1:1 S MSG=$O(^TMP("PRCVRIL",$J,"NAK",MSG)) Q:MSG="" D 103 .S ^TMP("HLA",$J,I)=^TMP("PRCVRIL",$J,"NAK",MSG) 104 S PRCVRES="" 105 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 106 ;I +$P(PRCVRES,U,2) D 107 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 108 MAIL ;Send MailMan message with error 109 Q:LENVAL="NOTOK" 110 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 111 S XMSUB="RIL build errors in HL7 message "_HL("MID")_" " 112 S XMDUZ="IFCAP/DynaMed Interface" 113 S XMTEXT="PRCVERR(" 114 D GETFCPU^PRCVLIC(.XMY,PRCSITE,PRCFCP) 115 D ^XMD 116 K XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ 117 Q 118 ; 119 ACKIT ;Send an acknowledgement that everything went fine 120 ; 121 I HL("APAT")'="AL" Q 122 F I=1:1:1 S ^TMP("HLA",$J,I)=$G(^TMP("PRCVRIL",$J,"ACK",I)) 123 ; 124 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.PRCVRES) 125 ;I +P(PRCVRES,U,2) D 126 ;.I $D(ERRCNT)=0 S ERRCNT=1 127 ;.S PRCVERR(ERRCNT)="Application ACK not processed. Contact EVS." 128 ;.D MAIL 129 Q
Note:
See TracChangeset
for help on using the changeset viewer.
