53 lines
2.2 KiB
Mathematica
53 lines
2.2 KiB
Mathematica
PRCH7C ;WISC/PLT-PURCHASE CARD PROSTHETICS AMEND/RECONCILE INTERFACE; 4/1/98
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
QUIT ;invalid entry
|
|
;
|
|
; prca=ien of 442, prcb=new order amount
|
|
; X-return value=1 if amendment done, 0=not done
|
|
AMEND(PRCA,PRCB) ;amendment
|
|
N PRC,PRCPROST,PRCRI,PRCHAUTH,PRCPAMT
|
|
N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON
|
|
N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
|
|
N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,PRCHN,PRCHO,SFUND
|
|
N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
|
|
N DA
|
|
D DUZ^PRCFSITE
|
|
S PRCRI(442)=+PRCA,PRCRI(443.6)=+PRCA,PRCPAMT=PRCB
|
|
;
|
|
; Clean up arrays NEW, PRCFMO and PRCTMP before their first call.
|
|
K NEW,PRCFMO,PRCTMP
|
|
D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0
|
|
D DUZ^PRCFSITE
|
|
S PRCHAUTH=1,PRCPROST=6
|
|
S A=$P(^PRC(442,PRCRI(442),0),"^"),PRC("SITE")=$P(A,"-")
|
|
S PRCHPO=PRCRI(442) I $D(^PRC(443.6,PRCRI(442),0)) S PRCHNEW=111
|
|
; S B=5 D ICLOCK^PRC0B("^PRC(442,"_PRCHPO_",",.B)
|
|
;
|
|
; The next two lines are needed when adding amendments in Prosthetics.
|
|
L +^PRC(442,PRCHPO):0 E W !,"Someone else is editing this entry, try later." G AMEEX
|
|
S PRCENTRY=PRCHPO
|
|
; D AMENDNO^PRCHAMU D DCLOCK^PRC0B("^PRC(442,"_PRCHPO_",") G:'$G(PRCHAM) AMEEX
|
|
D AMENDNO^PRCHAMU G:'$G(PRCHAM) AMEEX
|
|
S PRCHAMT=0,FL=0 D INFO^PRCHAMU G:$D(PRCHAV)!ER AMEEX
|
|
S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB
|
|
I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX
|
|
I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
|
|
K NOCAN,DTOUT,DUOUT,REPONUM S PRCHAMDA=23,ROU=$P(^PRCD(442.2,PRCHAMDA,0),U,3),ROU=$TR(ROU,"~","^")
|
|
S PRCHL1=$P(^PRCD(442.2,PRCHAMDA,1),U),PRCHL2=$P(^(1),U,2)
|
|
D @ROU
|
|
D CAN1^PRCHMA
|
|
AMEEX D KILL^PRCHMA1 S X=$S(PRCPROST=6.9:1,1:0)
|
|
;
|
|
; Clean up arrays NEW, PRCFMO, and PRCTMP after use.
|
|
K NEW,PRCFMO,PRCTMP
|
|
QUIT
|
|
;
|
|
RECON(PRCA,PRCB) ;prca=ri of file 442, prcb=ri of file 200
|
|
; X-return value 1 if final charge, 0=else
|
|
N A
|
|
I $G(IOSTBM)="" S X="IOSTBM" D ENDR^%ZISS I $G(IOSTBM)="" D EN^DDIOL("Wrong type terminal (missing IOSTBM)!") S X=0 QUIT
|
|
S A=+^PRC(442,PRCA,0),A=$P(^PRC(411,A,9),U,7)
|
|
D RECON^PRCH1A2(PRCA,PRCB,A)
|
|
QUIT
|