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