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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH7C 2291 printed Sep 02, 2024@18:50:42 Page 2
PRCH7C ;WISC/PLT-PURCHASE CARD PROSTHETICS AMEND/RECONCILE INTERFACE; 4/1/98
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ; prca=ien of 442, prcb=new order amount
+5 ; X-return value=1 if amendment done, 0=not done
AMEND(PRCA,PRCB) ;amendment
+1 NEW PRC,PRCPROST,PRCRI,PRCHAUTH,PRCPAMT
+2 NEW PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON
+3 NEW A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
+4 NEW PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,PRCHN,PRCHO,SFUND
+5 NEW PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
+6 NEW DA
+7 DO DUZ^PRCFSITE
+8 SET PRCRI(442)=+PRCA
SET PRCRI(443.6)=+PRCA
SET PRCPAMT=PRCB
+9 ;
+10 ; Clean up arrays NEW, PRCFMO and PRCTMP before their first call.
+11 KILL NEW,PRCFMO,PRCTMP
+12 DO KILL^PRCHMA1
SET PRCHNEW=""
SET PRCHNORE=1
SET CAN=0
+13 DO DUZ^PRCFSITE
+14 SET PRCHAUTH=1
SET PRCPROST=6
+15 SET A=$PIECE(^PRC(442,PRCRI(442),0),"^")
SET PRC("SITE")=$PIECE(A,"-")
+16 SET PRCHPO=PRCRI(442)
IF $DATA(^PRC(443.6,PRCRI(442),0))
SET PRCHNEW=111
+17 ; S B=5 D ICLOCK^PRC0B("^PRC(442,"_PRCHPO_",",.B)
+18 ;
+19 ; The next two lines are needed when adding amendments in Prosthetics.
+20 LOCK +^PRC(442,PRCHPO):0
IF '$TEST
WRITE !,"Someone else is editing this entry, try later."
GOTO AMEEX
+21 SET PRCENTRY=PRCHPO
+22 ; D AMENDNO^PRCHAMU D DCLOCK^PRC0B("^PRC(442,"_PRCHPO_",") G:'$G(PRCHAM) AMEEX
+23 DO AMENDNO^PRCHAMU
if '$GET(PRCHAM)
GOTO AMEEX
+24 SET PRCHAMT=0
SET FL=0
DO INFO^PRCHAMU
if $DATA(PRCHAV)!ER
GOTO AMEEX
+25 SET X=$PIECE($GET(^PRC(443.6,PRCHPO,0)),U,16)
DO EN2^PRCHAMXB
+26 IF PRCHNEW=""
SET DA(1)=PRCHPO
SET DA=PRCHAM
SET PRCHX=X
SET X=0
SET PRCHAMDA=34
DO EN8^PRCHAMXB
SET X=PRCHX
+27 IF $PIECE(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($PIECE(^(0),U,4)=15)
SET CAN=1
+28 KILL NOCAN,DTOUT,DUOUT,REPONUM
SET PRCHAMDA=23
SET ROU=$PIECE(^PRCD(442.2,PRCHAMDA,0),U,3)
SET ROU=$TRANSLATE(ROU,"~","^")
+29 SET PRCHL1=$PIECE(^PRCD(442.2,PRCHAMDA,1),U)
SET PRCHL2=$PIECE(^(1),U,2)
+30 DO @ROU
+31 DO CAN1^PRCHMA
AMEEX DO KILL^PRCHMA1
SET X=$SELECT(PRCPROST=6.9:1,1:0)
+1 ;
+2 ; Clean up arrays NEW, PRCFMO, and PRCTMP after use.
+3 KILL NEW,PRCFMO,PRCTMP
+4 QUIT
+5 ;
RECON(PRCA,PRCB) ;prca=ri of file 442, prcb=ri of file 200
+1 ; X-return value 1 if final charge, 0=else
+2 NEW A
+3 IF $GET(IOSTBM)=""
SET X="IOSTBM"
DO ENDR^%ZISS
IF $GET(IOSTBM)=""
DO EN^DDIOL("Wrong type terminal (missing IOSTBM)!")
SET X=0
QUIT
+4 SET A=+^PRC(442,PRCA,0)
SET A=$PIECE(^PRC(411,A,9),U,7)
+5 DO RECON^PRCH1A2(PRCA,PRCB,A)
+6 QUIT
