source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCRD2.m@ 1078

Last change on this file since 1078 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1PRCHCRD2 ;WISC/DJM-LINK ITEM FILE DATA INTO AMMENDMENT FILE ;1/11/94 11:55 AM [5/14/98 4:58pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4LST ;ENTERED FROM SET 0F 'AD' X-REF ON 'REPETITIVE (PR CARD) NO. WITHIN 'ITEM' MULTIPLE
5 L +^PRC(441,PRCHCI,2,PRCHCV):5 E W !!,$C(7),"Another user is editing this entry, try later." G Q
6 S PRCHCY=$G(^PRC(441,PRCHCI,0)),PRCHCNS=$P(PRCHCY,U,5),PRCHCSC=$P(PRCHCY,U,3),PRCHCSB=$P(PRCHCY,U,10) S:$G(PRCHCSB) PRCHCSB=$P($G(^PRCD(420.2,PRCHCSB,0)),U,1)
7 S PRCHCY=$G(^PRC(441,PRCHCI,2,PRCHCV,0)),PRCHCVS=$P(PRCHCY,U,4),PRCHCDC=$P(PRCHCY,U,5),PRCHCUC=$P(PRCHCY,U,2),PRCHCCN=$P(PRCHCY,U,3),PRCHCUP=$P(PRCHCY,U,7),PRCHCPK=$P(PRCHCY,U,8),PRCHCMX=$P(PRCHCY,U,9),PRCHSKM=$P(PRCHCY,U,10)
8 S PRCHCY=$G(^PRC(441,PRCHCI,3)),PRCHSKU=$P(PRCHCY,U,8),PRCHFGRP=$P(PRCHCY,U,7),PRCHDRTY=$P(PRCHCY,U,9)
9 S PRCHCS=" ",L=1 F M=0:0 S M=$O(^PRC(441,PRCHCI,1,M)) Q:M'>0 S PRCHC("%X",L,0)=PRCHCS_^(M,0),L=L+1,PRCHCS=""
10 S:PRCHCDC]"" PRCHC("%X",L,0)=" NDC:"_PRCHCDC,L=L+1
11 S PRCHC("%X",0)="^^"_L_U_L_U_DT_U,%X="PRCHC(""%X"",",%Y="^PRC(443.6,PRCHCPO,2,PRCHCIT,1,"
12 S:PRCHCCN]"" PRCHCY=$G(^PRC(440,PRCHCV,4,PRCHCCN,0)),PRCHCCN=$S($P(PRCHCY,U,2)>DT:$P(PRCHCY,U,1),1:"")
13 S PRCHC(0)=^PRC(443.6,DA(1),2,DA,0),PRCHC(2)="",PRCHCQ=$P(PRCHC(0),U,2) S:$D(^(2)) PRCHC(2)=^(2) S PRCHC(4)=$G(^(4))
14 S $P(PRCHC(0),U,3)=PRCHCUP,$P(PRCHC(0),U,12)=PRCHCPK,$P(PRCHC(0),U,14)=PRCHCMX S:$P(PRCHC(0),U,4)="" $P(PRCHC(0),U,4)=PRCHCSB S $P(PRCHC(0),U,9)=PRCHCUC,$P(PRCHC(0),U,15)=PRCHCDC,$P(PRCHC(0),U,16)=PRCHSKU,$P(PRCHC(0),U,17)=PRCHSKM
15 ;S $P(PRCHC(4),U,12)=PRCHFGRP
16 S $P(PRCHC(4),U,11)=PRCHDRTY
17 S:PRCHCVS'="" $P(PRCHC(0),U,6)=PRCHCVS S:PRCHCNS'="" $P(PRCHC(0),U,13)=PRCHCNS
18 S $P(PRCHC(2),U,1)=PRCHCQ*PRCHCUC,$P(PRCHC(2),U,2)=PRCHCCN,$P(PRCHC(2),U,3)=PRCHCSC,^PRC(443.6,DA(1),2,DA,0)=PRCHC(0),^(2)=PRCHC(2),^(4)=PRCHC(4)
19 S:PRCHCCN]"" ^PRC(443.6,DA(1),2,"AC",$E(PRCHCCN,1,30),DA)="" K ^PRC(443.6,DA(1),2,DA,1) D %XY^%RCR L -^PRC(441,PRCHCI,2,PRCHCV) G Q
20Q K PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHCPO,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY,PRCHSKM,PRCHSKU,PRCHFGRP
21 Q
22 ;
23EN1 ;THIS ENTRY POINT IS CALLED FROM THE INPUT TRANSFORM OF THE BOC FIELD, #.01, IN THE BOC MULTIPLE, FIELD 41.
24 K DD,DO S ZD=D,ZDO=$G(DO),ZDO(2)=$G(DO(2)),ZDIC=$G(DIC),ZDIC(0)=$G(DIC(0)),ZDIX=$G(DIX),DIC="^PRC(442,"_DA_",2,",DIC(0)="AEMQZ",D="D"
25 D IX^DIC K DIC S X=$P(Y(0),"^",4),D=ZD,DO=ZDO,DO(2)=ZDO(2),DIC=ZDIC,DIC(0)=ZDIC(0),DIX=ZDIX K:X="" X K Y,ZD,ZDO,ZDIC,ZDIX
26 Q
27 ;
28EN2 ;THIS ENTRY POINT COMES FROM THE XECUTABLE 'HELP' SECTION OF THE BOC FIELD. SEE EN1 TO LOCATE THIS FIELD.
29 K DD,DO S ZD=D,ZDO=$G(DO),ZDO(2)=$G(DO(2)),ZDIC=$G(DIC),ZDIC(0)=$G(DIC(0)),ZDIX=$G(DIX),X="?",DIC="^PRC(442,"_DA_",2,",DIC(0)="EZ",D="D"
30 D IX^DIC K DIC S:+Y>0 X=$P(Y(0),"^",4) S D=ZD,DO=ZDO,DO(2)=ZDO(2),DIC=ZDIC,DIC(0)=ZDIC(0),DIX=ZDIX K Y,ZD,ZDO,ZDIC,ZDIX
31 Q
32 ;
33EN5 ;FILE 443.6, REPETITIVE (PR CARD) NO. #1.5
34 I $P(^PRC(443.6,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
35 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(443.6,DA(1),0)
36 Q
37 ;
Note: See TracBrowser for help on using the repository browser.