| 1 | PRCH7PUC ;Hines OIFO/RVD - GUI PURCHASE CARD PROS ORDER INTERFACE ;8/13/03 09:50
|
|---|
| 2 | ;;5.1;IFCAP;**68**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;This routine is for Obligating and canceling a PO using a GUI interface.
|
|---|
| 6 | ;Line label UP1 is for MUMPS entry point.
|
|---|
| 7 | ;
|
|---|
| 8 | ; PRCSITE - station number
|
|---|
| 9 | ; PRCVEN - vendor
|
|---|
| 10 | ; RESULTS - return variable
|
|---|
| 11 | ; PRCA - IEN of Prosthetics Order file 664
|
|---|
| 12 | ; PRCB - IEN of file 442
|
|---|
| 13 | ; PRCC - Total Cost
|
|---|
| 14 | ; PRCRMPR - Variable to quit in IFCAP E-Sig routine PRCUESIG
|
|---|
| 15 | UP1(X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) ;ENTRY FOR GUI PURCHASING
|
|---|
| 16 | ;
|
|---|
| 17 | N PRCPROST,PRCHPC,PRCRI,A,B,Y,DIE
|
|---|
| 18 | N PRCHPO,PRCHTOT,PRCHBOCC,PRCHBOC1,PRCHN
|
|---|
| 19 | S PRC("PER")=+DUZ
|
|---|
| 20 | K X S X=$S('$D(^VA(200,+PRC("PER"),20)):"",1:^VA(200,+PRC("PER"),20))
|
|---|
| 21 | I $P(X,"^",2)="" S %X=$P(^VA(200,+PRC("PER"),0),"^"),%X=$P(%X,",",2)_" "_$P(%X,",")_$P(%X,",",3),$P(^VA(200,+PRC("PER"),20),"^",2)=%X,X=%X K %X
|
|---|
| 22 | S $P(PRC("PER"),"^",2,4)=$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_$S($D(^VA(200,+PRC("PER"),.13)):$P(^(.13),"^",2),1:"")
|
|---|
| 23 | S PRCHVEN=PRCVEN
|
|---|
| 24 | S PRCPROST=3,PRCHPC=1
|
|---|
| 25 | S PRCRI(442)=PRCB
|
|---|
| 26 | S PRCHPO=PRCRI(442),PRCHTOT=PRCC
|
|---|
| 27 | S A=^PRC(440.5,$P(^PRC(442,PRCRI(442),23),"^",8),0),PRCHBOC1=$P(A,U,4)
|
|---|
| 28 | S DIE="^PRC(442,",DA=PRCHPO,DR="60////"_PRCHTOT_";91////"_PRCHTOT_";65////RMPR" D ^DIE K DR
|
|---|
| 29 | S PRCHN("SFC")=+$P(^PRC(442,PRCRI(442),0),U,19)
|
|---|
| 30 | S:'$D(^PRC(442,PRCHPO,2,0)) $P(^PRC(442,PRCHPO,2,0),U,2)=$P(^DD(442,40,0),U,2)
|
|---|
| 31 | S DA(1)=PRCHPO,DIE="^PRC(442,"_DA(1)_",2,",DA=1
|
|---|
| 32 | S DR=".01///^S X=1;1///Prosthetic Order;2///^S X=1;3///^S X=""EA"";5////^S X=PRCHTOT;3.1///^S X=1;9.7///^S X=1;9///^S X="""";8///^S X=9999;K PRCHBOCC;"
|
|---|
| 33 | S DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
|
|---|
| 34 | S DR(1,442.01,2)="S PRCHBOCC=$P($G(^PRCD(420.2,PRCHBOCC,0)),U);3.5////^S X=PRCHBOCC;S Y=""@89"";@87;3.5////^S X=PRCHBOC1;@89;K PRCHBOCC"
|
|---|
| 35 | D ^DIE
|
|---|
| 36 | I '$D(Y) D PROS^PRCHNPO
|
|---|
| 37 | S X="" I PRCPROST=3 D CANIC(PRCRI(442)) S X="^"
|
|---|
| 38 | QUIT
|
|---|
| 39 | ;
|
|---|
| 40 | CANIC(PRCA) ;cancel order, prca=ri of prosthetic order, prcb=ri file 442
|
|---|
| 41 | N PRCPROST,PRCHPC,A,B,X,Y
|
|---|
| 42 | S PRCPROST=99,PRCHPC=1
|
|---|
| 43 | D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCA,".5///^S X=45")
|
|---|
| 44 | S DA=PRCA D C2237^PRCH442A K DA,%A,%B,%
|
|---|
| 45 | QUIT
|
|---|
| 46 | ;
|
|---|
| 47 | ;PRCPONO - IEN of file #442
|
|---|
| 48 | ;PRCA - IEN of file #664
|
|---|
| 49 | ;RESULTS - a return value
|
|---|
| 50 | ;
|
|---|
| 51 | ;cancel a PO. Call by Prosthetics GUI.
|
|---|
| 52 | C1(PRCA) G C2
|
|---|
| 53 | CAN(RESULTS,PRCPONO) ;broker entry point.
|
|---|
| 54 | C2 ;
|
|---|
| 55 | N PRCPROST,PRCHPC,A,B,X,Y
|
|---|
| 56 | S PRCPROST=99,PRCHPC=1
|
|---|
| 57 | L +^PRC(442,PRCA):1
|
|---|
| 58 | I '$T S RESULTS="Unable to Access P.O. in IFCAP." Q
|
|---|
| 59 | D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCA,".5///^S X=45")
|
|---|
| 60 | S DA=PRCA D C2237^PRCH442A K DA,%A,%B,%
|
|---|
| 61 | S RESULTS(0)="P.O. has been cancelled."
|
|---|
| 62 | Q
|
|---|
| 63 | ;END
|
|---|
