RMPR29LU ;HIN/RVD-LAB ISSUE FROM STOCK UTILITY;5/27/1998
;;3.0;PROSTHETICS;**33,37,44**;Feb 09, 1996
;Per VHA Directive 10-93-142, this routine should not be modified.
LIS K ^UTILITY("DIQ1",$J),HLD,DIC
S (RMPRDFN,DFN,Y)=$P(^RMPR(664.1,RMPRDA,0),U,2) D DEM^VADPT
S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U),RMPRDOB=$P(VADM(3),U)
Q:$G(RMPRDA)'>0 S DIC="^RMPR(664.1,",DA=RMPRDA,DR=".02;.11;.04;.09;2;4;13;15;19"
D EN^DIQ1 K DIQ,DR S PAGE=1,DA=RMPRDA
F RI=0:0 S RI=$O(^RMPR(664.1,DA,2,RI)) Q:RI'>0 I $D(^(RI,0)) D
.S RM6(RI)=$G(^RMPR(664.1,DA,2,RI,0))
.S DIC="^RMPR(664.1,",DR="6"
.S DR(664.16)=".01;2;3;8;9;10;7;12;13;14;15;16;17;18",DA(664.16)=RI
.S HLD(RI)=$$ITM1^RMPR31U($P(^RMPR(664.1,DA,2,RI,0),U))
.D EN^DIQ1 K DIQ,DR
I '$D(PNK) D HD^RMPR29W
I $D(PNK) D HDC^RMPR29W
S RI=0
ITD ;ITEM DISPLAY
S RI=$O(HLD(RI)) I '$G(RI)!$G(RMEXIT) K ^UTILITY("DIQ1"),^UTILITY($J),PNK,DIR Q
W !,HLD(RI),?10,$E(^UTILITY("DIQ1",$J,664.16,RI,.01),1,15)
W ?27,$E(^UTILITY("DIQ1",$J,664.16,RI,12),1,15),?45,^(2),?50,^(3),?55,^(8),?65,^(9)
W !,?10,"HCPCS: ",^UTILITY("DIQ1",$J,664.16,RI,13)
WP ;WORD PROCESSING FIELD DISPLAY
;D:($Y+8>IOSL) ASK Q:$D(RMEXIT)
;S RWP=$O(^UTILITY("DIQ1",$J,664.16,RI,7,0))
;I RWP'>0 K HLD(RI) K D0 D ADC^RMPR293(RMPRDA,RI) D G ITD
S RLOC=^UTILITY("DIQ1",$J,664.16,RI,17)
S RGIP=^UTILITY("DIQ1",$J,664.16,RI,18)
S RMINVF=$S(RLOC'="":"PROS INVENTORY",RGIP'="":"GIP",1:"OTHER")
W:$D(RMINVF) !,?10,"*** ",RMINVF," ***"
D:($Y+8>IOSL) ASK
G ITD
;
;S X=$G(^UTILITY("DIQ1",$J,664.16,RI,7,RWP))
;K ^UTILITY($J) S DIWL=1,DIWR=60,DIWF="R" D ^DIWP Q
;
POST I RMPRGIP S PRCP("QTY")=$P(R1(0),U,7)*-1,PRCP("TYP")="R" D ^PRCPUSA
I $D(PRCP("ITEM")) W !!,"Error encountered while posting to GIP. Inventory Issue did not post..." H 10 S RMEXIT=1 G EXIT
I RMPRG'="" G GGC
L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1
S $P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
GGC S $P(RMPRI("AMS"),U,1)=RMPRG
S $P(RLB("D"),U,6)=RMTIME,$P(RLB("D"),U,7)=$J(RMLACO,0,2)
S $P(RLB("D"),U,8)=$J(RMPRCOST,0,2),RMTOTC=RMLACO+RMPRCOST
S $P(RLB("D"),U,9)=$J(RMTOTC,0,2),$P(RLB("D"),U,11)=DT,RMLAB="Y"
S RMHCPC=$P(R1(1),U,4),$P(R1(0),U,13)=15,$P(R1(0),U,16)=""
S RMSER=$P(R1(0),U,11),RMQTY=$P(R1(0),U,7) I $D(RMLOC) D ADD^RMPR5NU1
W:$D(RMLOC) !!,"Posted to inventory module.."
;posting for employee lab item count
I '$D(RMLOC) D
.K Y,DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN K DLAYGO S (RM6612,DA)=+Y
.S ^RMPR(661.2,DA,0)=DT_"^"_RMPRDFN_"^"_RMSO_"^"_RMHCPC_"^^^"_DUZ_"^^"_$P(^RMPR(661.1,RMHCPC,0),U,1)_"^^^^^^"_RMPR("STA")_"^^"
.S:$D(RMLAB) ^RMPR(661.2,DA,1)=RMTIME_"^"_$J(RMLACO,0,2)
.S DIK="^RMPR(661.2," D IX1^DIK
S DIK="^RMPR(660,",(RM660,DA)=+Y D IX1^DIK K DIC W !!,"Posted to 2319..",!
Q
DEL ;delete status 2529-3
K DIR,Y
S DIR(0)="Y",DIR("A")="Would you like to Delete this 2529-3 Entry"
S DIR("B")="NO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!(Y=0)
;delete entry in the 2319 record and mark entry in 664.1 as deleted
N BO S BO=0
F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
.S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5) Q:DA=""
.S DIK="^RMPR(660," D ^DIK
W !,?5,"Updated 10-2319" K DA,DIK
S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""D""" D ^DIE W !,?5,$C(7),"Marked As Deleted..."
S RDEL=1
Q
RDL ;delete record
;the record is only deleted from 664.1 when the user creats a new
;W !! S DIR(0)="Y",DIR("A")="Would you like to delete this Request "
;S DIR("B")="NO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!(Y=0)
S DA=0,BO=0 Q:$G(REDIT)
F S BO=$O(^RMPR(664.1,RMPRDA,2,BO)) Q:BO'>0 D
.S DA=$P(^RMPR(664.1,RMPRDA,2,BO,0),U,5) Q:DA=""
.S DIK="^RMPR(660," D ^DIK
K DIK,DA S DA=RMPRDA,DIK="^RMPR(664.1,"
D ^DIK K DIK W !!,?5,$C(7),"Deleted..."
Q
;
ASK ;
K DIR S DIR(0)="E"
S DIR("A")="Enter 'Return' to view more Items or '^' to QUIT item listing"
D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y=0) S RMEXIT=1 Q
W @IOF,RMPR("L")
Q
;
EN4 ;CREATE JOB RECORD
S RMPR("REF")=$P(^RMPR(664.1,RMPRDA,0),U,4),$P(^(0),U,20)="",RN=+$P(^(0),U,24)
K DA,D0,DD,DO S DIC="^RMPR(664.2,",DIC(0)="LZ",X=$P(^RMPR(664.1,RMPRDA,0),U,13) D FILE^DICN Q:+Y'>0
S (RM6642,DA)=+Y,RN=RN+1
K DIC,Y F RT=0:0 S RT=$O(^RMPR(664.1,RMPRDA,2,RT)) Q:RT'>0 I $D(^(RT,0)) S DA660=$P(^(0),U,5) I +DA660 D S $P(^RMPR(664.1,RMPRDA,0),U,24)=RN
.S $P(^RMPR(660,DA660,"LB"),U,5)=RM6642,DA=DA660,DIE="^RMPR(660,",DR="83///^S X=$P(^RMPR(664.1,RMPRDA,0),U,1)" D ^DIE
S $P(^RMPR(664.2,RM6642,0),U,2)=DA660,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,4)=RN,$P(^(0),U,8)=RMPR("REF") S DA=RM6642,DIK="^RMPR(664.2," D IX1^DIK
Q
EXIT ;COMMON EXIT POINT
D:($Y+8>IOSL) ASK Q:$D(RMEXIT)
;S RL=$O(^UTILITY($J,"W",DIWL,0)) I +RL W !,?10,^(RL,0) K ^(0) G EXT
K ^UTILITY($J)
Q
HCP(RD0,RD1) ;print HCPCS and GIP or Pros Inventory in -3.
Q:'$D(^RMPR(664.1,RD0,2,RD1,0))
S R643=$G(^RMPR(664.1,RD0,2,RD1,3))
S RPSAITEM=$P(R643,U,3),RPSALOC=$P(R643,U,4)
S RPHCPC=$P($G(^RMPR(664.1,RD0,2,RD1,2)),U,1)
Q:'$G(RPHCPC)
Q:'$D(^RMPR(661.1,RPHCPC,0))
S RPGIP=$P($G(^RMPR(664.1,RD0,2,RD1,0)),U,13)
W !,?9,"HCPCS: ",$P(^RMPR(661.1,RPHCPC,0),U,1)
I $G(RPSALOC),RPSAITEM'="",$D(^RMPR(661.3,RPSALOC,0)) D
.S RHDA=$O(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0)) Q:'$G(RHDA)
.S RIDA=$O(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
.S RIDES=$P($G(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
.W ?26,RIDES
I $G(RPSALOC) W !,?9,"*** Pros Inventory ***",?35,"Location: " I $D(^RMPR(661.3,RPSALOC,0)) W $P(^RMPR(661.3,RPSALOC,0),U,1)
I '$G(RPSALOC),$G(RPGIP) W !,?9,"*** GIP ***"
I '$G(RPSALOC),'$G(RPGIP) W !,?9,"*** OTHER ***"
Q
;
CHK ;CHECK DISABILITY AND ITEMS
;kill record if not all mandatory fields defined
K RKILL,RMEXIT,RMEDIT
F RCK=1,2,3,4,11,15 I $P(^RMPR(664.1,RMPRDA,0),U,RCK)="" S RKILL=1 S DA=RMPRDA,DIK="^RMPR(664.1," D ^DIK W !!,?5,$C(7),"ALL MANDATORY FIELDS NOT DEFINED FORM 2529-3 DELETED" Q
I $D(RKILL) G EXIT^RMPR29LI
;disability code missing
K DKILL
I '$D(^RMPR(664.1,RMPRDA,1))!('$O(^RMPR(664.1,RMPRDA,1,0))) S DKILL=1
F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,1,RI)) Q:RI'>0 I $P(^(RI,0),U,1)=""!($P(^(0),U,2)="") S DKILL=1
;item missing
K IKILL
I '$D(^RMPR(664.1,RMPRDA,2))!('$O(^RMPR(664.1,RMPRDA,2,0))) S IKILL=1
F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0 I $P(^(RI,0),U,1)=""!($P(^(0),U,2)="")!($P(^(0),U,4)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S IKILL=1
ER1 ;error message
I $D(DKILL) W $C(7),!!,?5,"2529-3 FORM INCOMPLETE. DISABILITY CODE INFORMATION IS MISSING!!"
I $D(IKILL) W $C(7),!!,?5,"2529-3 FORM INCOMPLETE. ITEM INFORMATION IS MISSING!!"
I $D(IKILL)!($D(DKILL)) S DIR(0)="Y",DIR("B")="YES" D
.S DIR("A")="Would you like to EDIT this 2529-3 Entry"
.D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y=0) S RMEXIT=1 Q
.S RMEDIT=1
;K DA,DIC,DIK,DIWF,DIWL,DIWR,PAGE,PNK,RCK,RI,RL,RWP,X
;G LAB^RMPR29LI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29LU 6951 printed Mar 13, 2025@21:37:08 Page 2
RMPR29LU ;HIN/RVD-LAB ISSUE FROM STOCK UTILITY;5/27/1998
+1 ;;3.0;PROSTHETICS;**33,37,44**;Feb 09, 1996
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
LIS KILL ^UTILITY("DIQ1",$JOB),HLD,DIC
+1 SET (RMPRDFN,DFN,Y)=$PIECE(^RMPR(664.1,RMPRDA,0),U,2)
DO DEM^VADPT
+2 SET RMPRNAM=$PIECE(VADM(1),U)
SET RMPRSSN=$PIECE(VADM(2),U)
SET RMPRDOB=$PIECE(VADM(3),U)
+3 if $GET(RMPRDA)'>0
QUIT
SET DIC="^RMPR(664.1,"
SET DA=RMPRDA
SET DR=".02;.11;.04;.09;2;4;13;15;19"
+4 DO EN^DIQ1
KILL DIQ,DR
SET PAGE=1
SET DA=RMPRDA
+5 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,DA,2,RI))
if RI'>0
QUIT
IF $DATA(^(RI,0))
Begin DoDot:1
+6 SET RM6(RI)=$GET(^RMPR(664.1,DA,2,RI,0))
+7 SET DIC="^RMPR(664.1,"
SET DR="6"
+8 SET DR(664.16)=".01;2;3;8;9;10;7;12;13;14;15;16;17;18"
SET DA(664.16)=RI
+9 SET HLD(RI)=$$ITM1^RMPR31U($PIECE(^RMPR(664.1,DA,2,RI,0),U))
+10 DO EN^DIQ1
KILL DIQ,DR
End DoDot:1
+11 IF '$DATA(PNK)
DO HD^RMPR29W
+12 IF $DATA(PNK)
DO HDC^RMPR29W
+13 SET RI=0
ITD ;ITEM DISPLAY
+1 SET RI=$ORDER(HLD(RI))
IF '$GET(RI)!$GET(RMEXIT)
KILL ^UTILITY("DIQ1"),^UTILITY($JOB),PNK,DIR
QUIT
+2 WRITE !,HLD(RI),?10,$EXTRACT(^UTILITY("DIQ1",$JOB,664.16,RI,.01),1,15)
+3 WRITE ?27,$EXTRACT(^UTILITY("DIQ1",$JOB,664.16,RI,12),1,15),?45,^(2),?50,^(3),?55,^(8),?65,^(9)
+4 WRITE !,?10,"HCPCS: ",^UTILITY("DIQ1",$JOB,664.16,RI,13)
WP ;WORD PROCESSING FIELD DISPLAY
+1 ;D:($Y+8>IOSL) ASK Q:$D(RMEXIT)
+2 ;S RWP=$O(^UTILITY("DIQ1",$J,664.16,RI,7,0))
+3 ;I RWP'>0 K HLD(RI) K D0 D ADC^RMPR293(RMPRDA,RI) D G ITD
+4 SET RLOC=^UTILITY("DIQ1",$JOB,664.16,RI,17)
+5 SET RGIP=^UTILITY("DIQ1",$JOB,664.16,RI,18)
+6 SET RMINVF=$SELECT(RLOC'="":"PROS INVENTORY",RGIP'="":"GIP",1:"OTHER")
+7 if $DATA(RMINVF)
WRITE !,?10,"*** ",RMINVF," ***"
+8 if ($Y+8>IOSL)
DO ASK
+9 GOTO ITD
+10 ;
+11 ;S X=$G(^UTILITY("DIQ1",$J,664.16,RI,7,RWP))
+12 ;K ^UTILITY($J) S DIWL=1,DIWR=60,DIWF="R" D ^DIWP Q
+13 ;
POST IF RMPRGIP
SET PRCP("QTY")=$PIECE(R1(0),U,7)*-1
SET PRCP("TYP")="R"
DO ^PRCPUSA
+1 IF $DATA(PRCP("ITEM"))
WRITE !!,"Error encountered while posting to GIP. Inventory Issue did not post..."
HANG 10
SET RMEXIT=1
GOTO EXIT
+2 IF RMPRG'=""
GOTO GGC
+3 LOCK +^RMPR(669.9,RMPRSITE,0):999
IF $TEST=0
SET RMPRG=DT_99
GOTO GGC
+4 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
+5 SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
GGC SET $PIECE(RMPRI("AMS"),U,1)=RMPRG
+1 SET $PIECE(RLB("D"),U,6)=RMTIME
SET $PIECE(RLB("D"),U,7)=$JUSTIFY(RMLACO,0,2)
+2 SET $PIECE(RLB("D"),U,8)=$JUSTIFY(RMPRCOST,0,2)
SET RMTOTC=RMLACO+RMPRCOST
+3 SET $PIECE(RLB("D"),U,9)=$JUSTIFY(RMTOTC,0,2)
SET $PIECE(RLB("D"),U,11)=DT
SET RMLAB="Y"
+4 SET RMHCPC=$PIECE(R1(1),U,4)
SET $PIECE(R1(0),U,13)=15
SET $PIECE(R1(0),U,16)=""
+5 SET RMSER=$PIECE(R1(0),U,11)
SET RMQTY=$PIECE(R1(0),U,7)
IF $DATA(RMLOC)
DO ADD^RMPR5NU1
+6 if $DATA(RMLOC)
WRITE !!,"Posted to inventory module.."
+7 ;posting for employee lab item count
+8 IF '$DATA(RMLOC)
Begin DoDot:1
+9 KILL Y,DD,DO
SET DIC="^RMPR(661.2,"
SET DIC(0)="L"
SET X=DT
SET DLAYGO=661.2
DO FILE^DICN
KILL DLAYGO
SET (RM6612,DA)=+Y
+10 SET ^RMPR(661.2,DA,0)=DT_"^"_RMPRDFN_"^"_RMSO_"^"_RMHCPC_"^^^"_DUZ_"^^"_$PIECE(^RMPR(661.1,RMHCPC,0),U,1)_"^^^^^^"_RMPR("STA")_"^^"
+11 if $DATA(RMLAB)
SET ^RMPR(661.2,DA,1)=RMTIME_"^"_$JUSTIFY(RMLACO,0,2)
+12 SET DIK="^RMPR(661.2,"
DO IX1^DIK
End DoDot:1
+13 SET DIK="^RMPR(660,"
SET (RM660,DA)=+Y
DO IX1^DIK
KILL DIC
WRITE !!,"Posted to 2319..",!
+14 QUIT
DEL ;delete status 2529-3
+1 KILL DIR,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Would you like to Delete this 2529-3 Entry"
+3 SET DIR("B")="NO"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!(Y=0)
QUIT
+4 ;delete entry in the 2319 record and mark entry in 664.1 as deleted
+5 NEW BO
SET BO=0
+6 FOR
SET BO=$ORDER(^RMPR(664.1,RMPRDA,2,BO))
if BO'>0
QUIT
Begin DoDot:1
+7 SET DA=$PIECE(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
if DA=""
QUIT
+8 SET DIK="^RMPR(660,"
DO ^DIK
End DoDot:1
+9 WRITE !,?5,"Updated 10-2319"
KILL DA,DIK
+10 SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///^S X=""D"""
DO ^DIE
WRITE !,?5,$CHAR(7),"Marked As Deleted..."
+11 SET RDEL=1
+12 QUIT
RDL ;delete record
+1 ;the record is only deleted from 664.1 when the user creats a new
+2 ;W !! S DIR(0)="Y",DIR("A")="Would you like to delete this Request "
+3 ;S DIR("B")="NO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!(Y=0)
+4 SET DA=0
SET BO=0
if $GET(REDIT)
QUIT
+5 FOR
SET BO=$ORDER(^RMPR(664.1,RMPRDA,2,BO))
if BO'>0
QUIT
Begin DoDot:1
+6 SET DA=$PIECE(^RMPR(664.1,RMPRDA,2,BO,0),U,5)
if DA=""
QUIT
+7 SET DIK="^RMPR(660,"
DO ^DIK
End DoDot:1
+8 KILL DIK,DA
SET DA=RMPRDA
SET DIK="^RMPR(664.1,"
+9 DO ^DIK
KILL DIK
WRITE !!,?5,$CHAR(7),"Deleted..."
+10 QUIT
+11 ;
ASK ;
+1 KILL DIR
SET DIR(0)="E"
+2 SET DIR("A")="Enter 'Return' to view more Items or '^' to QUIT item listing"
+3 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)
SET RMEXIT=1
QUIT
+4 WRITE @IOF,RMPR("L")
+5 QUIT
+6 ;
EN4 ;CREATE JOB RECORD
+1 SET RMPR("REF")=$PIECE(^RMPR(664.1,RMPRDA,0),U,4)
SET $PIECE(^(0),U,20)=""
SET RN=+$PIECE(^(0),U,24)
+2 KILL DA,D0,DD,DO
SET DIC="^RMPR(664.2,"
SET DIC(0)="LZ"
SET X=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)
DO FILE^DICN
if +Y'>0
QUIT
+3 SET (RM6642,DA)=+Y
SET RN=RN+1
+4 KILL DIC,Y
FOR RT=0:0
SET RT=$ORDER(^RMPR(664.1,RMPRDA,2,RT))
if RT'>0
QUIT
IF $DATA(^(RT,0))
SET DA660=$PIECE(^(0),U,5)
IF +DA660
Begin DoDot:1
+5 SET $PIECE(^RMPR(660,DA660,"LB"),U,5)=RM6642
SET DA=DA660
SET DIE="^RMPR(660,"
SET DR="83///^S X=$P(^RMPR(664.1,RMPRDA,0),U,1)"
DO ^DIE
End DoDot:1
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,24)=RN
+6 SET $PIECE(^RMPR(664.2,RM6642,0),U,2)=DA660
SET $PIECE(^(0),U,3)=RMPR("STA")
SET $PIECE(^(0),U,4)=RN
SET $PIECE(^(0),U,8)=RMPR("REF")
SET DA=RM6642
SET DIK="^RMPR(664.2,"
DO IX1^DIK
+7 QUIT
EXIT ;COMMON EXIT POINT
+1 if ($Y+8>IOSL)
DO ASK
if $DATA(RMEXIT)
QUIT
+2 ;S RL=$O(^UTILITY($J,"W",DIWL,0)) I +RL W !,?10,^(RL,0) K ^(0) G EXT
+3 KILL ^UTILITY($JOB)
+4 QUIT
HCP(RD0,RD1) ;print HCPCS and GIP or Pros Inventory in -3.
+1 if '$DATA(^RMPR(664.1,RD0,2,RD1,0))
QUIT
+2 SET R643=$GET(^RMPR(664.1,RD0,2,RD1,3))
+3 SET RPSAITEM=$PIECE(R643,U,3)
SET RPSALOC=$PIECE(R643,U,4)
+4 SET RPHCPC=$PIECE($GET(^RMPR(664.1,RD0,2,RD1,2)),U,1)
+5 if '$GET(RPHCPC)
QUIT
+6 if '$DATA(^RMPR(661.1,RPHCPC,0))
QUIT
+7 SET RPGIP=$PIECE($GET(^RMPR(664.1,RD0,2,RD1,0)),U,13)
+8 WRITE !,?9,"HCPCS: ",$PIECE(^RMPR(661.1,RPHCPC,0),U,1)
+9 IF $GET(RPSALOC)
IF RPSAITEM'=""
IF $DATA(^RMPR(661.3,RPSALOC,0))
Begin DoDot:1
+10 SET RHDA=$ORDER(^RMPR(661.3,RPSALOC,1,"B",RPHCPC,0))
if '$GET(RHDA)
QUIT
+11 SET RIDA=$ORDER(^RMPR(661.3,RPSALOC,1,RHDA,1,"B",RPSAITEM,0))
+12 SET RIDES=$PIECE($GET(^RMPR(661.3,RPSALOC,1,RHDA,1,RIDA,0)),U,8)
+13 WRITE ?26,RIDES
End DoDot:1
+14 IF $GET(RPSALOC)
WRITE !,?9,"*** Pros Inventory ***",?35,"Location: "
IF $DATA(^RMPR(661.3,RPSALOC,0))
WRITE $PIECE(^RMPR(661.3,RPSALOC,0),U,1)
+15 IF '$GET(RPSALOC)
IF $GET(RPGIP)
WRITE !,?9,"*** GIP ***"
+16 IF '$GET(RPSALOC)
IF '$GET(RPGIP)
WRITE !,?9,"*** OTHER ***"
+17 QUIT
+18 ;
CHK ;CHECK DISABILITY AND ITEMS
+1 ;kill record if not all mandatory fields defined
+2 KILL RKILL,RMEXIT,RMEDIT
+3 FOR RCK=1,2,3,4,11,15
IF $PIECE(^RMPR(664.1,RMPRDA,0),U,RCK)=""
SET RKILL=1
SET DA=RMPRDA
SET DIK="^RMPR(664.1,"
DO ^DIK
WRITE !!,?5,$CHAR(7),"ALL MANDATORY FIELDS NOT DEFINED FORM 2529-3 DELETED"
QUIT
+4 IF $DATA(RKILL)
GOTO EXIT^RMPR29LI
+5 ;disability code missing
+6 KILL DKILL
+7 IF '$DATA(^RMPR(664.1,RMPRDA,1))!('$ORDER(^RMPR(664.1,RMPRDA,1,0)))
SET DKILL=1
+8 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,RMPRDA,1,RI))
if RI'>0
QUIT
IF $PIECE(^(RI,0),U,1)=""!($PIECE(^(0),U,2)="")
SET DKILL=1
+9 ;item missing
+10 KILL IKILL
+11 IF '$DATA(^RMPR(664.1,RMPRDA,2))!('$ORDER(^RMPR(664.1,RMPRDA,2,0)))
SET IKILL=1
+12 FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,RMPRDA,2,RI))
if RI'>0
QUIT
IF $PIECE(^(RI,0),U,1)=""!($PIECE(^(0),U,2)="")!($PIECE(^(0),U,4)="")!($PIECE(^(0),U,7)="")!($PIECE(^(0),U,8)="")
SET IKILL=1
ER1 ;error message
+1 IF $DATA(DKILL)
WRITE $CHAR(7),!!,?5,"2529-3 FORM INCOMPLETE. DISABILITY CODE INFORMATION IS MISSING!!"
+2 IF $DATA(IKILL)
WRITE $CHAR(7),!!,?5,"2529-3 FORM INCOMPLETE. ITEM INFORMATION IS MISSING!!"
+3 IF $DATA(IKILL)!($DATA(DKILL))
SET DIR(0)="Y"
SET DIR("B")="YES"
Begin DoDot:1
+4 SET DIR("A")="Would you like to EDIT this 2529-3 Entry"
+5 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)
SET RMEXIT=1
QUIT
+6 SET RMEDIT=1
End DoDot:1
+7 ;K DA,DIC,DIK,DIWF,DIWL,DIWR,PAGE,PNK,RCK,RI,RL,RWP,X
+8 ;G LAB^RMPR29LI
+9 QUIT
