| 1 | RMPRED4 ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/29/1994
|
---|
| 2 | ;;3.0;PROSTHETICS;**33,35,46,53,62**;Feb 09, 1996
|
---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
| 4 | ;
|
---|
| 5 | ;RVD patch #62 - PCE interface
|
---|
| 6 | K DIR
|
---|
| 7 | ;I $P(R1(0),U,13)=11&($P(R1(0),U,14)="C")&'$G(RMLOC) D
|
---|
| 8 | S DIR(0)="667.3,3",DIR("A")="UNIT COST",DIR("B")=$P(R1(0),U,16)/$P(R1(0),U,7)
|
---|
| 9 | I $D(RMLOC),$D(RMHCDA),$D(RMITDA) S DIR("B")=$$COST^RMPR5NU1
|
---|
| 10 | D ^DIR G:$D(DIRUT)!$D(DTOUT)!$D(DUOUT) CO^RMPRED6
|
---|
| 11 | S (ACNT,RMPRREL)=Y*$P(R1(0),U,7),$P(R3("D"),U,16)=ACNT,$P(R1(0),U,16)=ACNT
|
---|
| 12 | K DIR
|
---|
| 13 | QTY ;
|
---|
| 14 | S DIR(0)="660,5",DIR("B")=$P(R1(0),U,7),RMPRCUST=$P(R1(0),U,16)/$P(R1(0),U,7) D ^DIR G:$D(DIRUT) CO^RMPRED6
|
---|
| 15 | I $D(RMUBA),((RMUBA+$P(R1(0),U,7))-Y<0) D LOWBA^RMPRSTI G LOC^RMPRED6
|
---|
| 16 | S $P(R1(0),U,7)=Y,$P(R1(0),U,16)=Y*RMPRCUST K DIR
|
---|
| 17 | DATE S:$P(R1(0),U,12) DIR("B")=$P(R3("D"),U,12) S DIR("A")="DELIVERY DATE",DIR(0)="660,10" D ^DIR K DIR
|
---|
| 18 | G:X["^" CO^RMPRED6 G:$D(DTOUT) EXIT W:$P(R1(0),U,12)&(X="@") !?5,"Deleted..." H 1 I $P(R1(0),U,12)=""&(X="@") W ?16,"??" G DATE
|
---|
| 19 | S $P(R1(0),U,12)=Y,Y=$P(R1(0),U,12) D DD^%DT S $P(R3("D"),U,12)=Y
|
---|
| 20 | REQ S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR G:$D(DIRUT) CO^RMPRED6 G:$D(DTOUT) EXIT
|
---|
| 21 | I X["^" W !,"Jumping not allowed!" G REQ
|
---|
| 22 | I $P(R1(0),U,11)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,11)="" G LOT
|
---|
| 23 | S $P(R1(0),U,11)=X
|
---|
| 24 | LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR G:$D(DUOUT) CO^RMPRED6
|
---|
| 25 | I X["^" W !,"Jumping not allowed!" G LOT
|
---|
| 26 | I $P(R1(0),U,24)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,24)="" G REMA
|
---|
| 27 | S $P(R1(0),U,24)=X
|
---|
| 28 | REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) D ^DIR G:$D(DIRUT) CO^RMPRED6 G:$D(DTOUT) EXIT
|
---|
| 29 | I X["^" W !,"Jumping not allowed!" G REMA
|
---|
| 30 | I $P(R1(0),U,18)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,18)="" G CC
|
---|
| 31 | S $P(R1(0),U,18)=X
|
---|
| 32 | CC G CO^RMPRED6
|
---|
| 33 | ;
|
---|
| 34 | POST ;POSTS EDITED TRANSACTION TO 660
|
---|
| 35 | W !,"Posting...."
|
---|
| 36 | S RIPNEW=$P($G(R1(1)),U,3),RITNEW=$P(R1(0),U,6),RMQNEW=$P(R1(0),U,7)
|
---|
| 37 | S:$G(RITNEW) RITNEW=$P($G(^RMPR(661,RITNEW,0)),U,1)
|
---|
| 38 | S:$G(RITOLD) RITOLD=$P($G(^RMPR(661,RITOLD,0)),U,1)
|
---|
| 39 | S ^RMPR(660,RMPRIEN,0)=R1(0),^("AM")=R1("AM"),^(1)=R1(1),^(2)=R1(2)
|
---|
| 40 | I RMHCNEW'=RMHCOLD D
|
---|
| 41 | .K ^RMPR(660,RMPRIEN,"DES")
|
---|
| 42 | .MERGE ^RMPR(660,RMPRIEN,"DES")=^RMPR(661.1,RMHCNEW,2)
|
---|
| 43 | .S $P(^RMPR(660,RMPRIEN,"DES",0),U,2)=""
|
---|
| 44 | S DIK="^RMPR(660,",DA=RMPRIEN D IX1^DIK K DIK
|
---|
| 45 | S RMVAR=RMLOCNEW_"^"_RMHCNEW_"^"_RMHCOLD_"^"_RMLOCOLD_"^"_RMITNEW_"^"_RMITOLD_"^"_RMQNEW_"^"_RMQOLD_"^"_RMSO_"^"_RMDFN
|
---|
| 46 | I $G(RMQOLD)'=$G(RMQNEW)&($G(RMLOCNEW)=$G(RMLOCOLD))&($G(RMHCNEW)=$G(RMHCOLD))&(RMITNEW=RMITOLD) D QTYN^RMPRED5(RMVAR) G EXIT
|
---|
| 47 | I $G(RMHCOLD)'=$G(RMHCNEW)!(RMITNEW'=RMITOLD)!($G(RMLOCNEW)'=$G(RMLOCOLD)) D NHCPC^RMPRED5(RMVAR)
|
---|
| 48 | ;pce update, patch #62
|
---|
| 49 | I $D(^RMPR(660,RMPRIEN,10)),$P(^RMPR(660,RMPRIEN,10),U,12) D
|
---|
| 50 | .S RMCHK=$$SENDPCE^RMPRPCEA(RMPRIEN)
|
---|
| 51 | .I RMCHK<1 H 3
|
---|
| 52 | G EXIT
|
---|
| 53 | ;end posting (edit 2319)
|
---|
| 54 | ;
|
---|
| 55 | DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK
|
---|
| 56 | K DIR
|
---|
| 57 | S DIR("A")="Are you sure you want to DELETE this entry",DIR("B")="N",DIR(0)="Y"
|
---|
| 58 | D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) G EXIT
|
---|
| 59 | I Y'=1 G CO^RMPRED6
|
---|
| 60 | I $P(^RMPR(669.9,RMPRSITE,0),U,3)'=1!(RMPRPF=11) G DEL2
|
---|
| 61 | I $G(RMPRIP),+$P(^RMPR(660,RMPRIEN,1),U,3)
|
---|
| 62 | I S DIC="^PRCP(445,",DIC(0)="M",X=RMPRIP,DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" D ^DIC G:+Y<0 ERR K DIC S PRCP("I")=+Y,RMPRDTD=1
|
---|
| 63 | I '$D(RMPRDTD) S DIC="^PRCP(445,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))" D ^DIC K DIC S PRCP("I")=+Y
|
---|
| 64 | S PRCP("ITEM")=$P(R3("D"),U,6),PRCP("QTY")=$P(R1(0),U,7),PRCP("TYP")="A" D ^PRCPUSA G:$D(PRCP("ITEM")) ERR
|
---|
| 65 | DEL2 I RMPRPF=11 S RM1=$G(^RMPR(660,RMPRIEN,1)),R6612=$P(RM1,U,5) D:$G(R6612)
|
---|
| 66 | .S RM0=$G(^RMPR(660,RMPRIEN,0)),RMQTY=$P(RM0,U,7)
|
---|
| 67 | .S RM10=$G(^RMPR(660,RMPRIEN,10))
|
---|
| 68 | .;check if SUSPENSE and PCE entry has been created. added by #62.
|
---|
| 69 | .S RMIPCE=$P(RM10,U,12) I RMIPCE D
|
---|
| 70 | ..S RMCHK=$$DEL^RMPRPCED(RMPRIEN)
|
---|
| 71 | .;if no pce link, only delete entry in #668
|
---|
| 72 | .I 'RMIPCE D
|
---|
| 73 | ..S RMAMIS=$G(^RMPR(660,RMPRIEN,"AMS"))
|
---|
| 74 | ..S RMIE68=$O(^RMPR(668,"F",RMPRIEN,0))
|
---|
| 75 | ..Q:'$G(RMIE68)
|
---|
| 76 | ..S DA=$O(^RMPR(668,RMIE68,10,"B",RMPRIEN,0))
|
---|
| 77 | ..S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",10," D ^DIK
|
---|
| 78 | ..S RMAMIEN=$O(^RMPR(668,RMIE68,11,"B",RMAMIS,0)),RMCNT=0
|
---|
| 79 | ..F I=0:0 S I=$O(^RMPR(668,RMIE68,10,"B",I)) Q:I'>0 D
|
---|
| 80 | ...S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1
|
---|
| 81 | ..I RMCNT=1 D
|
---|
| 82 | ...S DA=RMAMIEN
|
---|
| 83 | ...S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11,"
|
---|
| 84 | ...D ^DIK
|
---|
| 85 | .S RMSTO=$G(^RMPR(661.2,R6612,0)),RMLOC=$P(RMSTO,U,16)
|
---|
| 86 | .S RMDAHC=$P(RM1,U,4),RMIT=$P(RMSTO,U,9)
|
---|
| 87 | .S RMHCDA=$O(^RMPR(661.3,RMLOC,1,"B",RMDAHC,0))
|
---|
| 88 | .Q:'$G(RMHCDA)
|
---|
| 89 | .S:$D(^RMPR(661.3,RMLOC,1,RMHCDA)) RMITDA=$O(^RMPR(661.3,RMLOC,1,RMHCDA,1,"B",RMIT,0))
|
---|
| 90 | .Q:'$G(RMITDA)
|
---|
| 91 | .S RBAL=0 D
|
---|
| 92 | ..S RMBA=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2),RBAL=RMBA+RMQTY
|
---|
| 93 | ..S (RAVA,RAV)=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10)
|
---|
| 94 | ..S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,2)=RBAL
|
---|
| 95 | ..S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,3)=RBAL*RAV
|
---|
| 96 | ..S $P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,12)=RMQTY
|
---|
| 97 | .D BAL^RMPR5NU1
|
---|
| 98 | .S X=DT,DIC(0)="AEQL",DLAYGO=661.2,DIC="^RMPR(661.2," K DD,DO
|
---|
| 99 | .D FILE^DICN K DLAYGO S RMCOM="Returned from STOCK ISSUE"
|
---|
| 100 | .S ^RMPR(661.2,+Y,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQTY_"^"_RMIT_"^^"_RMQTY_"^"_RMTOBA_"^"_RMCOM_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLOC_"^"_RAVA
|
---|
| 101 | .S DA=+Y,DIK=DIC D IX1^DIK
|
---|
| 102 | .W !,"****Current Balance @ Location ",$P(^RMPR(661.3,RMLOC,0),U,1)," is now: ",RBAL
|
---|
| 103 | S DIK="^RMPR(660,",DA=RMPRIEN D ^DIK
|
---|
| 104 | W $C(7),!?10,"Deleted..." H 1
|
---|
| 105 | G EXIT
|
---|
| 106 | ERR W !!,"Error encountered while posting to GIP. Patient 10-2319 not deleted!! Please check with your Application Coordinator." H 5 G EXIT
|
---|
| 107 | EXIT ;KILL VARIABLES AND EXIT ROUTINE
|
---|
| 108 | I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN)
|
---|
| 109 | N RMPRSITE,RMPR D KILL^XUSCLEAN Q
|
---|