RMPOPAT2 ;HINES CIO/RVD-DISPLAY PATIENT ITEM ACTIVITY ;9/16/02 11:16
;;3.0;PROSTHETICS;**70,99**;Feb 09, 1996
;RVD 7/5/02 patch #70 - Go to RMPOPAT if Read Only 2319, and
;
;DBIA # 800 - for this routine, the agreement covers the field #.01 NAME
; file #440.
;DBIA # 801 - for this routine, the agreement covers the field
; #.05 Short Description, file #441.
;DBIA # 10090 - Fileman read on file #4, field #99
D HDR
K ^UTILITY("DIQ1",$J) N DIC,DIQ
S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT
MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN)
S B=0
F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
. S BC=0
. F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D
. .Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA")
. .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1)
. .S ND=$P($G(^RMPR(660,BC,1)),U,4)
. .I ND S ND=$P(^RMPR(661.1,ND,0),U,8)
. .S:ND="" ND=2
. .S:GN="" GN=BC
. .S ^TMP($J,"AG",GN,ND,BC)=B
S B=""
F S B=$O(^TMP($J,"AG",B)) Q:B'>0 D
.S BC=""
.F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D
. .Q:BC=2
. .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B)
. .S HC="",GTCST=0
. .K HCC1
. .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D
. . .S HCC=0
. . .;changes for Surgical Implants
. . .S BDC=""
. . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D
. . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16)
. . . .I BDC=1&(HC'=2) S HCC1=HCC
. . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
. . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC)
. .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1
. .K GTCST,^TMP($J,"AGG")
K ^TMP($J,"AG"),BDC
S B=0,RC=1
F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D
.S RK=0
.F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D
. .Q:$D(^RMPO(665.72,"AC",RK))
. .S IT(RC)=RK
. .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3)
. .S RC=RC+1
S RK=0,RZ=0
K ^TMP($J,"TT"),B
;
G:'$D(IT) END
DIS ;DISPLAY APPLIANCES OR REPAIRS
I $G(RK)="" S RK="",RC=""
I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS
END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT
;
I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS
;
EXIT K I,J,L,R0,IT,RA,RMPRSTN,RMYSAV,DIQ,^UTILITY("DIQ1",$J)
Q:'$D(RMPRDFN)
W !
I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPOPAT
S FL=4 G ASK2^RMPOPAT
Q
PRT MERGE RMYSAV=Y
S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7)
S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11)
S DEL=$P(Y,U,12)
S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"")
;lab source of procurement
I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D
.I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q
.I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q
.I RMPRLPRO="S" S RMPRLPRO="SHOE" Q
.I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q
.I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q
.I RMPRLPRO="D" S RMPRLPRO="DDC" Q
;form requested on
S FRM=$P(Y,U,13),REM=$P(Y,U,18)
S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3)
S TYPE=$P($G(^RMPR(660,AN,1)),U,4)
;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"")
I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+"
S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS=""
S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL=""
W !,RK,". ",DATE,?13,QTY,?17
W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
;historical item
I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10)
W ?30,TRANS,?31,TRANS1
;display source of procurement for 2529-3 under vendor header
I $D(RMPRLPRO) W ?33,RMPRLPRO
I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10)
K RMPRLPRO
W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10)
I STA'="" D
.S DIC="^DIC(4,",DIQ(0)="E",DR=99,DIQ="RMPRSTN",DA=STA D EN^DIQ1
.W:$D(RMPRSTN(4,STA,99,"E")) ?45,RMPRSTN(4,STA,99,"E")
W ?50,$E(SN,1,9),?60,DEL
I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3)
W ?71,$J($FN($S(CST'="":CST,$P(RMYSAV,U,17):$P(RMYSAV,U,17),1:""),"T",2),9)
W:REM]"" !,?3,REM
I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ
Q
OVER ;
N ANS
S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^"
I ANS="^^" S ANS="^" G ASK1^RMPOPAT Q
I ANS="^" G ASK1^RMPOPAT Q
I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q
I ANS="" Q
I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER
I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPOPAT3
S RK=$P(IT(ANS),U,2)
Q
HDR ;Print Header, Screen 4
W @IOF
S PAGE=3
W !,$E(RMPRNAM,1,20),?23,"SSN: "
W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10)
W ?42,"DOB: "
S Y=RMPRDOB X ^DD("DD") W Y K Y
W ?61,"CLAIM# ",$G(RMPRCNUM)
W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOPAT2 5497 printed Sep 23, 2025@20:07:23 Page 2
RMPOPAT2 ;HINES CIO/RVD-DISPLAY PATIENT ITEM ACTIVITY ;9/16/02 11:16
+1 ;;3.0;PROSTHETICS;**70,99**;Feb 09, 1996
+2 ;RVD 7/5/02 patch #70 - Go to RMPOPAT if Read Only 2319, and
+3 ;
+4 ;DBIA # 800 - for this routine, the agreement covers the field #.01 NAME
+5 ; file #440.
+6 ;DBIA # 801 - for this routine, the agreement covers the field
+7 ; #.05 Short Description, file #441.
+8 ;DBIA # 10090 - Fileman read on file #4, field #99
+9 DO HDR
+10 KILL ^UTILITY("DIQ1",$JOB)
NEW DIC,DIQ
+11 SET (RA,AN,ANS,RK,RZ)=0
KILL ^TMP($JOB,"TT"),^TMP($JOB,"AG"),IT
+12 MERGE ^TMP($JOB,"TT")=^RMPR(660,"AC",RMPRDFN)
+13 SET B=0
+14 FOR
SET B=$ORDER(^TMP($JOB,"TT",B))
if B'>0
QUIT
Begin DoDot:1
+15 SET BC=0
+16 FOR
SET BC=$ORDER(^TMP($JOB,"TT",B,BC))
if BC'>0
QUIT
Begin DoDot:2
+17 if $PIECE($GET(^RMPR(660,BC,0)),U,10)'=RMPR("STA")
QUIT
+18 SET GN=$PIECE($GET(^RMPR(660,BC,"AMS")),U,1)
+19 SET ND=$PIECE($GET(^RMPR(660,BC,1)),U,4)
+20 IF ND
SET ND=$PIECE(^RMPR(661.1,ND,0),U,8)
+21 if ND=""
SET ND=2
+22 if GN=""
SET GN=BC
+23 SET ^TMP($JOB,"AG",GN,ND,BC)=B
End DoDot:2
End DoDot:1
+24 SET B=""
+25 FOR
SET B=$ORDER(^TMP($JOB,"AG",B))
if B'>0
QUIT
Begin DoDot:1
+26 SET BC=""
+27 FOR
SET BC=$ORDER(^TMP($JOB,"AG",B,BC))
if BC'>0
QUIT
Begin DoDot:2
+28 if BC=2
QUIT
+29 MERGE ^TMP($JOB,"AGG")=^TMP($JOB,"AG",B)
+30 SET HC=""
SET GTCST=0
+31 KILL HCC1
+32 FOR
SET HC=$ORDER(^TMP($JOB,"AGG",HC))
if HC'>0
QUIT
Begin DoDot:3
+33 SET HCC=0
+34 ;changes for Surgical Implants
+35 SET BDC=""
+36 FOR BDC=1:1
SET HCC=$ORDER(^TMP($JOB,"AGG",HC,HCC))
if HCC'>0
QUIT
Begin DoDot:4
+37 SET GTCST=GTCST+$PIECE(^RMPR(660,HCC,0),U,16)
+38 IF BDC=1&(HC'=2)
SET HCC1=HCC
+39 IF BDC'=1
KILL ^TMP($JOB,"TT",^TMP($JOB,"AGG",HC,HCC),HCC)
+40 IF HC=2
KILL ^TMP($JOB,"TT",^TMP($JOB,"AGG",HC,HCC),HCC)
End DoDot:4
End DoDot:3
+41 IF $GET(HCC1)
SET $PIECE(^TMP($JOB,"TT",^TMP($JOB,"AGG",1,HCC1),HCC1),U,3)=GTCST
KILL HCC1
+42 KILL GTCST,^TMP($JOB,"AGG")
End DoDot:2
End DoDot:1
+43 KILL ^TMP($JOB,"AG"),BDC
+44 SET B=0
SET RC=1
+45 FOR
SET B=$ORDER(^TMP($JOB,"TT",B))
if B'>0
QUIT
Begin DoDot:1
+46 SET RK=0
+47 FOR
SET RK=$ORDER(^TMP($JOB,"TT",B,RK))
if RK'>0
QUIT
Begin DoDot:2
+48 if $DATA(^RMPO(665.72,"AC",RK))
QUIT
+49 SET IT(RC)=RK
+50 IF $PIECE(^TMP($JOB,"TT",B,RK),U,3)
SET $PIECE(IT(RC),U,3)=$PIECE(^TMP($JOB,"TT",B,RK),U,3)
+51 SET RC=RC+1
End DoDot:2
End DoDot:1
+52 SET RK=0
SET RZ=0
+53 KILL ^TMP($JOB,"TT"),B
+54 ;
+55 if '$DATA(IT)
GOTO END
DIS ;DISPLAY APPLIANCES OR REPAIRS
+1 IF $GET(RK)=""
SET RK=""
SET RC=""
+2 IF (RK+1'>RC)&($GET(IT(RK+1)))
SET RK=RK+1
SET AN=+IT(RK)
SET Y=^RMPR(660,AN,0)
DO PRT
if ((IOSL-4)<$Y)
DO OVER
if '$DATA(ANS)!(ANS=U)!($DATA(DUOUT))!($DATA(DTOUT))
GOTO EXIT
GOTO DIS
END IF RC=0
WRITE !,"No Appliances or Repairs exist for this veteran!",!!
HANG 3
GOTO EXIT
+1 ;
+2 IF RC>0
WRITE !!,"End of Appliance/Repair records for this veteran!"
DO OVER
IF $GET(RK)+1'>$GET(RC)&($GET(IT($GET(RK)+1)))
DO DIS
+3 ;
EXIT KILL I,J,L,R0,IT,RA,RMPRSTN,RMYSAV,DIQ,^UTILITY("DIQ1",$JOB)
+1 if '$DATA(RMPRDFN)
QUIT
+2 WRITE !
+3 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO ASK1^RMPOPAT
+4 SET FL=4
GOTO ASK2^RMPOPAT
+5 QUIT
PRT MERGE RMYSAV=Y
+1 SET DATE=$PIECE(Y,U,3)
SET TYPE=$PIECE(Y,U,6)
SET QTY=$PIECE(Y,U,7)
+2 SET VEN=$PIECE(Y,U,9)
SET TRANS=$PIECE(Y,U,4)
SET STA=$PIECE(Y,U,10)
SET SN=$PIECE(Y,U,11)
+3 SET DEL=$PIECE(Y,U,12)
+4 SET CST=$SELECT($PIECE(Y,U,16)'="":$PIECE(Y,U,16),$DATA(^RMPR(660,AN,"LB")):$PIECE(^RMPR(660,AN,"LB"),U,9),1:"")
+5 ;lab source of procurement
+6 IF $DATA(^RMPR(660,AN,"LB"))
SET RMPRLPRO=$PIECE(^("LB"),U,3)
Begin DoDot:1
+7 IF RMPRLPRO="O"
SET RMPRLPRO="ORTHOTIC"
QUIT
+8 IF RMPRLPRO="R"
SET RMPRLPRO="RESTORATION"
QUIT
+9 IF RMPRLPRO="S"
SET RMPRLPRO="SHOE"
QUIT
+10 IF RMPRLPRO="W"
SET RMPRLPRO="WHEELCHAIR"
QUIT
+11 IF RMPRLPRO="N"
SET RMPRLPRO="FOOT CENTER"
QUIT
+12 IF RMPRLPRO="D"
SET RMPRLPRO="DDC"
QUIT
End DoDot:1
+13 ;form requested on
+14 SET FRM=$PIECE(Y,U,13)
SET REM=$PIECE(Y,U,18)
+15 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_$EXTRACT(DATE,2,3)
+16 SET TYPE=$PIECE($GET(^RMPR(660,AN,1)),U,4)
+17 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"")
+18 SET AMIS=$PIECE(Y,U,15)
SET VEN=$SELECT(VEN="":"",$DATA(^PRC(440,VEN,0)):$PIECE(^(0),U,1),1:"")
+19 IF $DATA(^RMPR(660.1,"AC",AN))
IF $PIECE(^RMPR(660.1,$ORDER(^RMPR(660.1,"AC",AN,0)),0),U,11)]""
SET AMIS=AMIS_"+"
+20 SET TRANS=$SELECT(TRANS]"":TRANS,1:"")
SET TRANS1=""
if TRANS="X"
SET TRANS1=TRANS
SET TRANS=""
+21 SET DEL=$EXTRACT(DEL,4,5)_"/"_$EXTRACT(DEL,6,7)_"/"_$EXTRACT(DEL,2,3)
if DEL="//"
SET DEL=""
+22 WRITE !,RK,". ",DATE,?13,QTY,?17
+23 WRITE AMIS_$SELECT(TYPE'="":$EXTRACT($PIECE($GET(^RMPR(661.1,TYPE,0)),U,2),1,10),$PIECE(Y,U,26)="D":"DELIVERY",$PIECE(Y,U,26)="P":"PICKUP",$PIECE(Y,U,17):"SHIPPING",1:"")
+24 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"")
+25 ;historical item
+26 IF TYPE=""&($DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST")))
WRITE $EXTRACT($PIECE(^("HST"),U,1),1,10)
+27 WRITE ?30,TRANS,?31,TRANS1
+28 ;display source of procurement for 2529-3 under vendor header
+29 IF $DATA(RMPRLPRO)
WRITE ?33,RMPRLPRO
+30 IF '$DATA(RMPRLPRO)
IF VEN'=""
WRITE ?33,$EXTRACT(VEN,1,10)
+31 KILL RMPRLPRO
+32 if $DATA(^RMPR(660,$PIECE(IT(RK),U,1),"HST"))
WRITE $EXTRACT($PIECE(^("HST"),U,3),1,10)
+33 IF STA'=""
Begin DoDot:1
+34 SET DIC="^DIC(4,"
SET DIQ(0)="E"
SET DR=99
SET DIQ="RMPRSTN"
SET DA=STA
DO EN^DIQ1
+35 if $DATA(RMPRSTN(4,STA,99,"E"))
WRITE ?45,RMPRSTN(4,STA,99,"E")
End DoDot:1
+36 WRITE ?50,$EXTRACT(SN,1,9),?60,DEL
+37 IF $PIECE(IT(RK),U,3)
SET CST=$PIECE(IT(RK),U,3)
+38 WRITE ?71,$JUSTIFY($FNUMBER($SELECT(CST'="":CST,$PIECE(RMYSAV,U,17):$PIECE(RMYSAV,U,17),1:""),"T",2),9)
+39 if REM]""
WRITE !,?3,REM
+40 IF $PIECE(IT(RK),U,2)=""
SET $PIECE(IT(RK),U,2)=RZ
+41 QUIT
OVER ;
+1 NEW ANS
+2 SET RZ=RK
WRITE !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. "
READ ANS:DTIME
if '$TEST
SET ANS="^"
+3 IF ANS="^^"
SET ANS="^"
GOTO ASK1^RMPOPAT
QUIT
+4 IF ANS="^"
GOTO ASK1^RMPOPAT
QUIT
+5 IF ANS=""
IF RK+1'>RC&($GET(IT(RK+1)))
DO HDR
QUIT
+6 IF ANS=""
QUIT
+7 IF ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS)
WRITE $CHAR(7),!," Must be between 1 and ",RK," to be valid"
GOTO OVER
+8 IF ANS>0
IF (ANS<(RK+1))
SET AN=ANS
SET RZ=RK
DO ^RMPOPAT3
+9 SET RK=$PIECE(IT(ANS),U,2)
+10 QUIT
HDR ;Print Header, Screen 4
+1 WRITE @IOF
+2 SET PAGE=3
+3 WRITE !,$EXTRACT(RMPRNAM,1,20),?23,"SSN: "
+4 WRITE $EXTRACT(RMPRSSN,1,3)_"-"_$EXTRACT(RMPRSSN,4,5)_"-"_$EXTRACT(RMPRSSN,6,10)
+5 WRITE ?42,"DOB: "
+6 SET Y=RMPRDOB
XECUTE ^DD("DD")
WRITE Y
KILL Y
+7 WRITE ?61,"CLAIM# ",$GET(RMPRCNUM)
+8 WRITE !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost"
+9 QUIT
