170 lines
9.1 KiB
Mathematica
170 lines
9.1 KiB
Mathematica
RMPR29LI ;HIN/RVD-ENTER LAB STOCK ISSUE 2529-3 [ 11/05/98
|
|
;;3.0;PROSTHETICS;**33,37**;Feb 09,1996
|
|
CREATE ;CREATE Lab Stock Issue 2529-3
|
|
K RMPREDIT,RMPRTMP,RMPR25,REDIT,RMCLOF,DIC D DIV4^RMPRSIT G:$D(X) EXIT
|
|
D GETPAT^RMPRUTIL I '$D(RMPRDFN) G EXIT
|
|
S RMDFN=RMPRDFN
|
|
VIEW ;CREATE Lab Stock Issue 2529-3 VIA LAB MENU
|
|
N RMPRDA,RMPRWO,RMPRJOB S RMPRF=15,RFLG=1,RNEW=1 D ^RMPRPAT
|
|
S DIC="^RMPR(664.1,",DIC(0)="ZL",X=DT
|
|
S DLAYGO=664.1 D FILE^DICN K DLAYGO,DIC G:+Y'>0 EXIT
|
|
S RMPRDA=+Y,$P(^RMPR(664.1,RMPRDA,0),U,2)=RMDFN,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,17)="S"
|
|
S IDEF=$$STA^RMPR31U(RMPR("STA"))
|
|
S DA=RMPRDA,DIK="^RMPR(664.1," D IX1^DIK
|
|
K DR,DA,DIC,DIK,Y,DIE D KVAR^VADPT
|
|
S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2),VAIP("D")="L"
|
|
D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
|
|
I $G(RMPRDA)>0,$G(RMPRDA)'="" D TYPE
|
|
G EXIT
|
|
EDT ;EDIT/DELETE 2529-3
|
|
D DIV4^RMPRSIT G:$D(X) EXIT
|
|
K ^TMP($J),DR,DIC,RMPRDA S REDIT=1
|
|
S DIC="^RMPR(664.1,",DIC(0)="AEQM",DR=".01"
|
|
S DIC("S")="I $P(^(0),U,17)=""S""",DIC("W")="D EN3^RMPRD1"
|
|
D ^DIC K DIC G:+Y'>0 EXIT S RMPRDA=+Y I $G(RMPRDA)'>0 Q
|
|
L +^RMPR(664.1,RMPRDA,0):1
|
|
I '$T W $C(7),!!,?5,"Someone is already editing this entry" G EXIT
|
|
S RMPRDFN=$P(^RMPR(664.1,RMPRDA,0),U,2)
|
|
D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
|
|
D LIS^RMPR29LU K DIR
|
|
S DIR(0)="Y",DIR("A")="Would you like to Edit this Entry",DIR("B")="YES"
|
|
D ^DIR G:$D(DTOUT)!($D(DUOUT)) EXIT G:Y=0!(Y<0) EXIT
|
|
S RL=$O(^RMPR(664.1,RMPRDA,2,0)) I RL D
|
|
.S RM2=$G(^RMPR(664.1,RMPRDA,2,RL,0)),RMTYPS=$P(RM2,U,7)
|
|
.S RMCATS=$P(RM2,U,8),RMSPES=$P(RM2,U,9),RMGIP=$P(RM2,U,13)
|
|
.S RM23=$G(^RMPR(664.1,RMPRDA,2,RL,3))
|
|
.S RMHS=$P($G(^RMPR(664.1,RMPRDA,2,RL,2)),U,1)
|
|
.S RMSO=$P(RM23,U,1),RMLOC=$P(RM23,U,1),RMIT=$P(RM23,U,3)
|
|
TYPE ;
|
|
S %X="^RMPR(664.1,RMPRDA,",%Y="^TMP($J,RMPRDA," D %XY^%RCR
|
|
K DIR S PDA=RMPRDA D ST^RMPR29LS S:$G(RMCLOF) REDIT=1
|
|
I '$G(RMPRDFN) W !,"*** Unable to access patient information, please contact your IRM..",! G EXIT
|
|
D GD^RMPR29LS I $D(RNEW),$D(RMFLG) D RDL^RMPR29LU G:$D(RMFLG) EXIT
|
|
I $G(REDIT) S RIDA=$O(^RMPR(664.1,RMPRDA,2,0)) I RIDA D
|
|
.S RM0=$G(^RMPR(664.1,RMPRDA,2,RIDA,0)),RMTYPS=$P(RM0,U,7),RMCATS=$P(RM0,U,8),RMSPES=$P(RM0,U,9),RMSO=$P($G(^RMPR(664.1,RMPRDA,2,RIDA,3)),U,1)
|
|
.S RMPRWO=$P(RM0,U,6),RMQTYS=$P(RM0,U,2),RMHS=$P($G(^RMPR(664.1,RMPRDA,2,RIDA,2)),U,1)
|
|
VC S:'$D(RMSO) RMSO="C" S DIR(0)="SBO^V:VA;C:COMMERCIAL",DIR("A")="Select VA or COMMERCIAL SOURCE" S:$D(RMSO) DIR("B")=RMSO
|
|
S DIR("?")="Enter V for VA or C for Commercial" D ^DIR
|
|
I $D(DUOUT)!$D(DTOUT) G:$G(REDIT) LAB D RDL^RMPR29LU G EXIT
|
|
G:Y="" VC S (RMSOR,RMSO)=Y
|
|
TRAN K DIR S DIR(0)="664.16,8"
|
|
;S DIR("A")="Enter Type of Transaction: "
|
|
S:$D(RMTYPS) DIR("B")=$S(RMTYPS="I":"INITIAL",RMTYPS="X":"REPAIR",RMTYPS="R":"REPLACE",RMTYPS="S":"SPARE",1:"")
|
|
D ^DIR
|
|
I $D(DUOUT)!$D(DTOUT) G:$G(RMCLOF)!($G(REDIT)) LAB D RDL^RMPR29LU G EXIT
|
|
I Y="" W !,"Please enter type of Transaction!!" G TRAN
|
|
S RMTYP=Y
|
|
S RMTYPS=$S(Y="I":"INITIAL",Y="X":"REPAIR",Y="R":"REPLACE",Y="S":"SPARE",1:"")
|
|
PCAT K DIR S DIR(0)="664.16,9"
|
|
S:$D(RMCATS) DIR("B")=$S(RMCATS=1:"SC/OP",RMCATS=2:"SC/IP",RMCATS=3:"NSC/IP",RMCATS=4:"NSC/OP",1:"")
|
|
D ^DIR
|
|
I $D(DUOUT)!$D(DTOUT) G:$G(RMCLOF)!($G(REDIT)) LAB D RDL^RMPR29LU G EXIT
|
|
I Y="" W !,"Please enter Patient Category!!" G PCAT
|
|
S RMCAT=Y,RMCATS=$S(Y=1:"SC/OP",Y=2:"SC/IP",Y=3:"NSC/IP",Y=4:"NSC/OP",1:"") K DIR G:RMCAT<4 ITEM
|
|
S DIR(0)="664.16,10"
|
|
S:$D(RMSPES) DIR("B")=$S(RMSPES=1:"SPECIAL LEGISLATION",RMSPES=2:"A&A",RMSPES=3:"PHC",RMSPES=4:"ELIGIBILITY REFORM",1:"")
|
|
I RMCAT=4 D ^DIR I $D(DUOUT)!$D(DTOUT) G:$G(RMCLOF)!($G(REDIT)) LAB D RDL^RMPR29LU G EXIT
|
|
I RMCAT=4 S RMSPE=Y,RMSPES=$S(Y=1:"SPECIAL LEGISLATION",Y=2:"A&A",Y=3:"PHC",Y=4:"ELIGIBILITY REFORM",1:"")
|
|
K DIR
|
|
ITEM ;EDIT 2529-3 ITEM
|
|
K DIC,DIR,RDEL,RMEDIT,DTOUT,DUOUT,RMITFLG,RMPRGIP S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,"
|
|
S DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQML"
|
|
D ^DIC K DIC G:+Y'>0 LAB
|
|
S RMITEMS=$P($G(^RMPR(661,$P(Y,U,2),0)),U,1)
|
|
S (RMIDA,DA)=+Y,DIE="^RMPR(664.1,"_RMPRDA_",2,",DR=".01" D ^DIE I $D(Y)!'$D(^RMPR(664.1,RMPRDA,2,RMIDA,0)) D G ITEM
|
|
.K ^RMPR(664.1,RMPRDA,2,RMIDA) K DIE,DR,RMIDA S RICHECK=$O(^RMPR(664.1,RMPRDA,2,0))
|
|
.K:'$G(RICHECK) REDIT
|
|
I $D(^RMPR(664.1,RMPRDA,2,RMIDA,0)),$P(^RMPR(664.1,RMPRDA,2,RMIDA,0),U,1)="" K ^RMPR(664.1,RMPRDA,2,RMIDA) G ITEM
|
|
S RM0=$G(^RMPR(664.1,RMPRDA,2,RMIDA,0)),RM3=$G(^RMPR(664.1,RMPRDA,2,RMIDA,3))
|
|
I $G(REDIT) D
|
|
.S RMHS=$P($G(^RMPR(664.1,RMPRDA,2,DA,2)),U,1),RMLOC=$P(RM3,U,4),RMIT=$P(RM3,U,3)
|
|
.S RMQTYS=$P(RM0,U,2),RMUNCO=$P(RM0,U,4),RMITEMS=$P(^RMPR(661,$P(RM0,U,1),0),U,1)
|
|
.S:'$D(RMCAT) RMCATS=$P(RM0,U,8) S:'$D(RMTYPS) RMTYPS=$P(RM0,U,7) S:'$D(RMSPE) RMSPES=$P(RM0,U,9)
|
|
HCPCS ;HCPCS code
|
|
K DIC
|
|
S DIC(0)="AEQM",DIC="^RMPR(661.1,",DIC("A")="PSAS HCPCS: " S:$D(RMHS) DIC("B")=RMHS
|
|
S DIC("S")="I $P(^RMPR(661.1,+Y,0),U,10)"
|
|
D ^DIC I $D(DUOUT)!$D(DTOUT) G:$G(RMCLOF)!($G(REDIT)) LAB D RDL^RMPR29LU G EXIT
|
|
I Y=-1 W !,"HCPCS CODE IS MANDATORY!" D HELP G HCPCS
|
|
I $P(^RMPR(661.1,+Y,0),U,10)<1 D HELP G HCPCS
|
|
I +Y>0 G:$P(^RMPR(661.1,+Y,0),U,5)'=1 HCPCS
|
|
S (RMI,RMHCPC,RMHS,DA(1),RMHCPCS)=+Y D ITEMLOC^RMPR5NU1 K DIC
|
|
I $G(RMITFLG) G:$G(RMCLOF)!($G(REDIT)) LAB D RDL^RMPR29LU G EXIT
|
|
K:'$G(RMHCDA)!'$G(RMITDA) RMLOC I $G(RMLOC) S RMGIP=0 G VEN
|
|
GI I $P(^RMPR(669.9,RMPRSITE,0),U,3),'$D(^PRCP(445,"AD",DUZ)) W $C(7),!,"You are not an authorized user of any Inventory Point, please see your ADPAC." H 2 S RMEXIT=1 Q
|
|
S RMPRGIP=$P(^RMPR(669.9,RMPRSITE,0),U,3),RMFORM=15 I RMPRGIP S PRCPPRIV=1 D INV^RMPR29LS G:$D(RMEXIT)&($G(REDIT)) LAB Q:$D(RMEXIT)
|
|
G:$D(RDEL) ITEM
|
|
;
|
|
VEN K DIC("S")
|
|
;S X=" ",DIC=440,DIC(0)="ZM" D ^DIC S:+Y>0 DIC("B")=$P(^PRC(440,+Y,0),U,1)
|
|
VEN0 I $G(RMLOC),$D(RMVEN) S DIC("B")=RMVEN
|
|
S DIC(0)="AEQM",DIC=440,DIC("A")="VENDOR: " S:$G(REDIT)&($D(RMVENS)) DIC("B")=RMVENS D ^DIC
|
|
I $D(DTOUT)!$D(DUOUT) G:$G(RMCLOF)!($G(REDIT)) LAB D RDL^RMPR29LU G EXIT
|
|
I +Y'>0 W !!,?5,$C(7),"This is a required response. Enter '^' to exit",! G VEN
|
|
S (RMVEN,RMVENS)=+Y K DIC,Y,X
|
|
UNICO ;UNIT COST
|
|
I (RMSO["C")&($G(RMPRGIP)) S RMCOS=$P($G(^PRCP(445,PRCP("I"),1,PRCP("ITEM"),0)),U,15)
|
|
I $G(RMLOC) S RMCOS=$P(^RMPR(661.3,RMLOC,1,RMHCDA,1,RMITDA,0),U,10)
|
|
I $P(RM0,U,4) S RMCOS=$P(RM0,U,4)
|
|
S DIR(0)="667.3,3",DIR("A")="UNIT COST"
|
|
S:$D(RMCOS)&($G(RMCOS)>0) DIR("B")=RMCOS
|
|
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT) G:$G(REDIT)!($G(RMCLOF)) LAB D RDL^RMPR29LU G EXIT
|
|
I (RMSO["C")&(X<.001) W !,"You must enter a UNIT COST....",! G UNICO
|
|
S (RMCOS,RMCO)=Y
|
|
;
|
|
QTY S DIR(0)="664.16,2" S:$D(RMQTYS) DIR("B")=RMQTYS D ^DIR
|
|
I $D(DUOUT)!$D(DTOUT) G:$G(REDIT)!($G(RMCLOF)) LAB D RDL^RMPR29LU G EXIT
|
|
I X<1 W !,"You must enter a quantity....",! G QTY
|
|
S (RMQTY,RMQTYS)=Y K DIR
|
|
K DIR S DIR(0)="664.16,12",RMSERS=$P(RM0,U,12) S:$D(RMSERS) DIR("B")=RMSERS D ^DIR
|
|
I $D(DUOUT)!$D(DTOUT) G:$G(RMCLOF)!($G(REDIT)) LAB D RDL^RMPR29LU G EXIT
|
|
S (RMSER,RMSERS)=Y,RMSO=RMSOR K DIR
|
|
S DIE(0)="AEQM",DR=4,DR(1,664.129)="4;",DR(2,664.1294)=".01"
|
|
S ^RMPR(664.1,RMPRDA,8,0)="^664.129DA",^RMPR(664.1,RMPRDA,8,1,1,0)="^664.1294^"
|
|
S DA(1)=RMPRDA,DIE="^RMPR(664.1,"_RMPRDA_",8,",DA=1 D ^DIE K DIE,DR,DA
|
|
S DA(1)=RMPRDA,DA=RMIDA,DIE="^RMPR(664.1,"_RMPRDA_",2,"
|
|
S DR="2///^S X=$G(RMQTY);4///^S X=$G(RMCO);12///^S X=$G(RMSER);8///^S X=$G(RMTYP);9///^S X=$G(RMCAT);10///^S X=$G(RMSPE);16///^S X=$G(RMIT);14///^S X=$G(RMSOR)"
|
|
D ^DIE I $D(DTOUT)!$D(DUOUT) G:$G(REDIT)!$G(RMCLOF) LAB G EXIT
|
|
S RM0=$G(^RMPR(664.1,RMPRDA,2,DA,0)),RMQTY=$P(RM0,U,2),RMCO=$P(RM0,U,4)
|
|
I RMQTY S RMTOCO=RMQTY*RMCO,DR="11///^S X=$G(RMTOCO);13///^S X=$G(RMHCPC)" D ^DIE
|
|
S:$G(RMGIP) $P(^RMPR(664.1,RMPRDA,2,DA,0),U,13)=RMGIP
|
|
S $P(^RMPR(664.1,RMPRDA,2,DA,3),U,4)=$G(RMLOC)
|
|
S $P(^RMPR(664.1,RMPRDA,2,DA,3),U,2)=$G(RMVEN)
|
|
G ITEM
|
|
LAB ;ASK TO POST REQUEST
|
|
I $G(REDIT),$D(RMIDA) D SET^RMPR29LS
|
|
;G:$D(RMEXIT)!('$D(RMPRDA)) EXIT
|
|
S DIR(0)="Y",DIR("A")="Would you like to review this request"
|
|
S DIR("B")="YES" D ^DIR I $D(DTOUT)!($D(DUOUT)) D SBACK Q:$G(RMCLOF) G:$G(REDIT) EXIT D RDL^RMPR29LU G EXIT
|
|
I Y=1 S IOP="HOME" D PRT^RMPR29R
|
|
;check for required fields
|
|
D CHK^RMPR29LU K RNEW G:$G(RMEDIT) TYPE D:$G(RMEXIT) RDL^RMPR29LU G:$G(RMEXIT) EXIT
|
|
K DIR S DIR(0)="Y",DIR("A")="Would you like to post this request"
|
|
S DIR("B")="YES" D ^DIR I $D(DTOUT)!($D(DUOUT)) D SBACK Q:$G(RMCLOF) G:$G(REDIT) EDT D RDL^RMPR29LU G EXIT
|
|
I +Y=0 W !,"Request not posted!!" D SBACK Q:$D(RMCLOF) D:$D(RNEW) RDL^RMPR29LU K RMPRDA G:$G(REDIT) EDT G EXIT
|
|
S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) G:RMPRWO'="" PRINT S SCR=$P(^(0),U,11)
|
|
D CR^RMPR29U(SCR) I '$D(RMPRWO) W !,"Request not posted!!" D SBACK Q:$D(RMCLOF) K RMPRDA G:$G(REDIT) EDT G EXIT
|
|
PRINT D SG^RMPR29LS
|
|
S DIK="^RMPR(664.1,",DA=RMPRDA D IX1^DIK K DIK,DA
|
|
W !! S DIR(0)="Y",DIR("A")="Would you like to print this 2529-3 request"
|
|
S DIR("B")="YES" D ^DIR I $D(DTOUT)!($D(DUOUT)) Q:$D(RMCLOF) G EXIT
|
|
I Y=1 D PRT^RMPR29R
|
|
Q:$D(RMCLOF)
|
|
;suspense record inquiry
|
|
D LINK^RMPRS
|
|
I $G(REDIT),'$D(RNEW) K RMPRDA G EDT
|
|
G CREATE
|
|
;end
|
|
;
|
|
HELP W !,"** You can only select HCPCS that have a LAB pre-determined time.",!,"** If the HCPCS you are selecting are not in the list, please send an E-mail"
|
|
W !,"** message to G.PROS-CODE@FORUM.VA.GOV to be added in the list..."
|
|
Q
|
|
;
|
|
SBACK ;set global back to its original data.
|
|
S %X="^TMP($J,RMPRDA,",%Y="^RMPR(664.1,RMPRDA," D %XY^%RCR
|
|
W !,"Update not posted...." Q
|
|
;
|
|
EXIT ;common exit
|
|
L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0)
|
|
N RMPR,RMPRSITE D KILL^XUSCLEAN Q
|