source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH7C.m@ 1524

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

initial load of WorldVistAEHR

File size: 2.2 KB
Line 
1PRCH7C ;WISC/PLT-PURCHASE CARD PROSTHETICS AMEND/RECONCILE INTERFACE; 4/1/98
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6 ; prca=ien of 442, prcb=new order amount
7 ; X-return value=1 if amendment done, 0=not done
8AMEND(PRCA,PRCB) ;amendment
9 N PRC,PRCPROST,PRCRI,PRCHAUTH,PRCPAMT
10 N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON
11 N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
12 N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,PRCHN,PRCHO,SFUND
13 N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
14 N DA
15 D DUZ^PRCFSITE
16 S PRCRI(442)=+PRCA,PRCRI(443.6)=+PRCA,PRCPAMT=PRCB
17 ;
18 ; Clean up arrays NEW, PRCFMO and PRCTMP before their first call.
19 K NEW,PRCFMO,PRCTMP
20 D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0
21 D DUZ^PRCFSITE
22 S PRCHAUTH=1,PRCPROST=6
23 S A=$P(^PRC(442,PRCRI(442),0),"^"),PRC("SITE")=$P(A,"-")
24 S PRCHPO=PRCRI(442) I $D(^PRC(443.6,PRCRI(442),0)) S PRCHNEW=111
25 ; S B=5 D ICLOCK^PRC0B("^PRC(442,"_PRCHPO_",",.B)
26 ;
27 ; The next two lines are needed when adding amendments in Prosthetics.
28 L +^PRC(442,PRCHPO):0 E W !,"Someone else is editing this entry, try later." G AMEEX
29 S PRCENTRY=PRCHPO
30 ; D AMENDNO^PRCHAMU D DCLOCK^PRC0B("^PRC(442,"_PRCHPO_",") G:'$G(PRCHAM) AMEEX
31 D AMENDNO^PRCHAMU G:'$G(PRCHAM) AMEEX
32 S PRCHAMT=0,FL=0 D INFO^PRCHAMU G:$D(PRCHAV)!ER AMEEX
33 S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB
34 I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX
35 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
36 K NOCAN,DTOUT,DUOUT,REPONUM S PRCHAMDA=23,ROU=$P(^PRCD(442.2,PRCHAMDA,0),U,3),ROU=$TR(ROU,"~","^")
37 S PRCHL1=$P(^PRCD(442.2,PRCHAMDA,1),U),PRCHL2=$P(^(1),U,2)
38 D @ROU
39 D CAN1^PRCHMA
40AMEEX D KILL^PRCHMA1 S X=$S(PRCPROST=6.9:1,1:0)
41 ;
42 ; Clean up arrays NEW, PRCFMO, and PRCTMP after use.
43 K NEW,PRCFMO,PRCTMP
44 QUIT
45 ;
46RECON(PRCA,PRCB) ;prca=ri of file 442, prcb=ri of file 200
47 ; X-return value 1 if final charge, 0=else
48 N A
49 I $G(IOSTBM)="" S X="IOSTBM" D ENDR^%ZISS I $G(IOSTBM)="" D EN^DDIOL("Wrong type terminal (missing IOSTBM)!") S X=0 QUIT
50 S A=+^PRC(442,PRCA,0),A=$P(^PRC(411,A,9),U,7)
51 D RECON^PRCH1A2(PRCA,PRCB,A)
52 QUIT
Note: See TracBrowser for help on using the repository browser.