| 1 | PRCH7C ;WISC/PLT-PURCHASE CARD PROSTHETICS AMEND/RECONCILE INTERFACE; 4/1/98
|
|---|
| 2 | V ;;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
|
|---|
| 8 | AMEND(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
|
|---|
| 40 | AMEEX 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 | ;
|
|---|
| 46 | RECON(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
|
|---|
