RMPRPAT1 ;PHX/HNB/RFM/JLT-DISPLAY PATIENT INFO ;8/29/1994
;;3.0;PROSTHETICS;**29,162**;Feb 09, 1996;Build 5
W @IOF S PAGE=2
K VADM S DFN=RMPRDFN N VAHOW D DEM^VADPT
K VAEL S DFN=RMPRDFN N VAHOW D ELIG^VADPT
K R5 S %X="^RMPR(665,"_RMPRDFN_",",%Y="R5(" D %XY^%RCR K %X,%Y S DFN=RMPRDFN
I $G(^RMPR(664,+$O(^RMPR(664,"C",RMPRDFN,0)),"RMPO"))="Y" W !,"<<<HOME OXYGEN PATIENT>>>>"
W !,$E(RMPRNAM,1,20),?23,"SSN: ",$P(VADM(2),U,2)
W ?42,"DOB: ",$P(VADM(3),U,2)
W ?61,"CLAIM# ",VAEL(7)
I '$D(R5(10)) S R5(10)=""
W !!,"PSC Issue Card: ",?17,"Appliance",?30,"Ht ",$P(R5(10),U,1),?37,"Wt ",$P(R5(10),U,2),?45,"Eyes ",$P(R5(10),U,3),?54,"Hair ",$P(R5(10),U,4),?66,"Serial Number" S J=0
F S J=$O(R5(5,J)) Q:J'>0 W ! S Y=$P(R5(5,J,0),U,1) I $P(R5(5,J,0),U,4) D
.D DD^%DT W Y,?17,$S($P(R5(5,J,0),U,2)]"":$E($P(R5(5,J,0),U,2),1,47),1:$E($P(^PRC(441,$P(^RMPR(661,$P(R5(5,J,0),U,4),0),U,1),0),U,2),1,47)),?66,$E($P(R5(5,J,0),U,3),1,12)
S R0=$P(R5(0),U,8) W !!,"Clothing Allowance: "
I $D(R5(6)),$O(R5(6,0))>0 F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,6,"B",RI)) Q:RI'>0 S RA=$O(^RMPR(665,RMPRDFN,6,"B",RI,0)),RR5=R5(6,RA,0),RR5=RR5 D
.W ?22,"Date: ",$E(RR5,4,5)_"-"_$E(RR5,6,7)_"-"_$E(RR5,2,3)," ",$S($P(RR5,U,2)["E":"ELIGIBLE",$P(RR5,U,2)["N":"NOT-ELIGIBLE",1:"UNKNOWN")," ",$S($P(RR5,U,3)["S":"STATIC",$P(RR5,U,3)["N":"NON-STATIC",1:"UNKNOWN")
.I $P(RR5,U,5) S Y=$P(RR5,U,5) D DD^%DT W !,?22,"Date of Exam: ",Y W:$P(RR5,U,6) " Examiner: ",$E($P(^VA(200,$P(RR5,U,6),0),U,1),1,30)
.W !,?22,"Desc: "
.W $S($D(R5(6,RA,1)):$P(R5(6,RA,1),U),1:""),!
I '$D(R5(6)) W "NONE LISTED",!
S RO="" F S RO=$O(^RMPR(667,"C",RMPRDFN,RO)) Q:RO="" D
.Q:$P(^RMPR(667,RO,2),U,1)=0
.W:'$D(RMPRFLG) !,"Automobile(s)",?16,"Make",?29,"Model",?43,"Vehicle ID#",?62,"Date Processed"
.W:$P(^RMPR(667,RO,0),U,6)'="" !?16,$E($P(^RMPR(667.2,$P(^RMPR(667,RO,0),U,6),0),U,1),1,11),?29,$E($P(^RMPR(667,RO,0),U,7),1,10),?43,$P(^RMPR(667,RO,0),U,1) S Y=$P(^RMPR(667,RO,0),U,8) D DD^%DT W ?64,Y S RMPRFLG=1
K KILL,RMPRFLG
W !!,"Items Returned: ",?16,"Date",?29,"Item",?56
W "Serial",?68,"Status"
D:$D(^RMPR(665,RMPRDFN,7,0)) OLD
I $D(^RMPR(660.1,"C",RMPRDFN)),'$D(KILL) S RO=0 F I=1:1 S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO=""!($D(KILL)) D WRIL
W ! K I,J,L,R0
N DIR S DIR(0)="E" D ^DIR
S FL=3 G ASK2^RMPRPAT
;G ^RMPRPAT0:ANS=1,^RMPRPAT1:ANS=2,^RMPRPAT2:ANS=3,^RMPRPAT2:ANS="",EXIT^RMPRPAT Q
WRIL ;ASK TO SEE MORE RETURNED ITEMS
I $E(IOST)["C",I=4 S %=2 W !,"Would you like to see more returned items" D YN^DICN I %=-1!(%=2) S KILL=1 Q
I $E(IOST)["C",I=4,%=0 W !,"Enter `YES` or `NO`" G WRIL
I $D(^RMPR(660.1,RO)),+$P(^RMPR(660.1,RO,0),U,11) D
.S Y=$P(^RMPR(660.1,RO,0),U,11)
.D DD^%DT W !?16,Y
.W:+$P(^RMPR(660.1,RO,0),U,3) ?29,$E($P(^PRC(441,$P(^RMPR(661,$P(^(0),U,3),0),U),0),U,2),1,20)
.W:$P(^RMPR(660.1,RO,0),U,21) ?29,$E(^RMPR(667.1,$P(^(0),U,21),0),1,25) W ?56,$E($P(^RMPR(660.1,RO,0),U,6),1,10)
.W ?68,$S($P(^RMPR(660.1,RO,0),U,14)=1:"RETURNED",$P(^(0),U,14)=2:"CONDEMNED",$P(^(0),U,14)=3:"TURNED-IN",$P(^(0),U,14)=4:"LOST",$P(^(0),U,14)=5:"BROKEN",1:"UNKNOWN")
Q
OLD ;DISPLAY OLD RETURNED ITEMS
S RO=0 F I=1:1 S RO=$O(^RMPR(665,RMPRDFN,7,RO)) Q:RO=""!($D(KILL)) D OLD1
Q
OLD1 I I=4,$E(IOST)["C" S %=2 W !,"Would you like to see more returned items" D YN^DICN I %=-1!(%=2) S KILL=1 Q
I I=4,$E(IOST)["C",%=0 W !,"Enter `YES` or `NO`" G OLD1
I $D(^RMPR(665,RMPRDFN,7,RO,0)) S Y=$P(^(0),U) D DD^%DT W !?16,$E(Y,1,12),?29,$E($P(^RMPR(665,RMPRDFN,7,RO,0),U,4),1,20)
RTNSTA ;DISPLAYS STATUS OF TRACKED ITEM ON PATIENT'S 10-2319
I S R0=$P(^RMPR(665,RMPRDFN,7,RO,0),U,2) W ?68,$S(R0=1:"RETURNED",R0=2:"CONDENMED",R0=3:"TURNED-IN",R0=4:"LOST",R0=5:"BROKEN",1:"UNKNOWN")
Q
HELP ;DISPLAY HELP FOR SCREENS
N RMPR90DP,RMPR90I W !,"Select One of the Following: ",! S RMPR90DP=$P(DIR(0),U,2,999) F RMPR90I=1:1:RCNT W !,?5,$P($P(RMPR90DP,";",RMPR90I),":",1),?14,$P($P(RMPR90DP,";",RMPR90I),":",2)
W !
Q
ASK1 ;SET DIR AND FOR SCREEN NUMBER DISPLAY
;patch *162 added RCNT variable and check to control 7 or 8 activity display depending on option entered.
K DIR S DIR("A")="Enter 10-2319 screen to VIEW (1-"_$G(RCNT)_"),'^' to EXIT, or 'return' to continue: "
N % S DIR(0)="SAO^1:PATIENT DEMOGRAPHICS;2:CLINIC ENROLLMENTS/CORRESPONDENCE;3:ENTITLEMENT INFORMATION;4:APPLIANCE TRANSACTIONS;5:AUTO ADAPTIVE INFORMATION;6:CRITICAL COMMENTS;7:ADD/EDIT DISABILITY CODE"
I $G(RCNT)=8 S DIR(0)=DIR(0)_";8:HOME OXYGEN ITEMS;"
S DIR("?")="Enter a screen number (1-"_$G(RCNT)_") OR '^' TO EXIT."
I $D(RFLG) S $P(DIR(0),U,1)="SO" S:$D(DIR("A")) DIR("A")=$P(DIR("A"),":",1)_" " K DIR("?")
S RFLG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPAT1 4651 printed Sep 23, 2025@20:11:47 Page 2
RMPRPAT1 ;PHX/HNB/RFM/JLT-DISPLAY PATIENT INFO ;8/29/1994
+1 ;;3.0;PROSTHETICS;**29,162**;Feb 09, 1996;Build 5
+2 WRITE @IOF
SET PAGE=2
+3 KILL VADM
SET DFN=RMPRDFN
NEW VAHOW
DO DEM^VADPT
+4 KILL VAEL
SET DFN=RMPRDFN
NEW VAHOW
DO ELIG^VADPT
+5 KILL R5
SET %X="^RMPR(665,"_RMPRDFN_","
SET %Y="R5("
DO %XY^%RCR
KILL %X,%Y
SET DFN=RMPRDFN
+6 IF $GET(^RMPR(664,+$ORDER(^RMPR(664,"C",RMPRDFN,0)),"RMPO"))="Y"
WRITE !,"<<<HOME OXYGEN PATIENT>>>>"
+7 WRITE !,$EXTRACT(RMPRNAM,1,20),?23,"SSN: ",$PIECE(VADM(2),U,2)
+8 WRITE ?42,"DOB: ",$PIECE(VADM(3),U,2)
+9 WRITE ?61,"CLAIM# ",VAEL(7)
+10 IF '$DATA(R5(10))
SET R5(10)=""
+11 WRITE !!,"PSC Issue Card: ",?17,"Appliance",?30,"Ht ",$PIECE(R5(10),U,1),?37,"Wt ",$PIECE(R5(10),U,2),?45,"Eyes ",$PIECE(R5(10),U,3),?54,"Hair ",$PIECE(R5(10),U,4),?66,"Serial Number"
SET J=0
+12 FOR
SET J=$ORDER(R5(5,J))
if J'>0
QUIT
WRITE !
SET Y=$PIECE(R5(5,J,0),U,1)
IF $PIECE(R5(5,J,0),U,4)
Begin DoDot:1
+13 DO DD^%DT
WRITE Y,?17,$SELECT($PIECE(R5(5,J,0),U,2)]"":$EXTRACT($PIECE(R5(5,J,0),U,2),1,47),1:$EXTRACT($PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(R5(5,J,0),U,4),0),U,1),0),U,2),1,47)),?66,$EXTRACT($PIECE(R5(5,J,0),U,3),1,12)
End DoDot:1
+14 SET R0=$PIECE(R5(0),U,8)
WRITE !!,"Clothing Allowance: "
+15 IF $DATA(R5(6))
IF $ORDER(R5(6,0))>0
FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RMPRDFN,6,"B",RI))
if RI'>0
QUIT
SET RA=$ORDER(^RMPR(665,RMPRDFN,6,"B",RI,0))
SET RR5=R5(6,RA,0)
SET RR5=RR5
Begin DoDot:1
+16 WRITE ?22,"Date: ",$EXTRACT(RR5,4,5)_"-"_$EXTRACT(RR5,6,7)_"-"_$EXTRACT(RR5,2,3)," ",$SELECT($PIECE(RR5,U,2)["E":"ELIGIBLE",$PIECE(RR5,U,2)["N":"NOT-ELIGIBLE",1:"UNKNOWN")," ",$SELECT(...
... $PIECE(RR5,U,3)["S":"STATIC",$PIECE(RR5,U,3)["N":"NON-STATIC",1:"UNKNOWN")
+17 IF $PIECE(RR5,U,5)
SET Y=$PIECE(RR5,U,5)
DO DD^%DT
WRITE !,?22,"Date of Exam: ",Y
if $PIECE(RR5,U,6)
WRITE " Examiner: ",$EXTRACT($PIECE(^VA(200,$PIECE(RR5,U,6),0),U,1),1,30)
+18 WRITE !,?22,"Desc: "
+19 WRITE $SELECT($DATA(R5(6,RA,1)):$PIECE(R5(6,RA,1),U),1:""),!
End DoDot:1
+20 IF '$DATA(R5(6))
WRITE "NONE LISTED",!
+21 SET RO=""
FOR
SET RO=$ORDER(^RMPR(667,"C",RMPRDFN,RO))
if RO=""
QUIT
Begin DoDot:1
+22 if $PIECE(^RMPR(667,RO,2),U,1)=0
QUIT
+23 if '$DATA(RMPRFLG)
WRITE !,"Automobile(s)",?16,"Make",?29,"Model",?43,"Vehicle ID#",?62,"Date Processed"
+24 if $PIECE(^RMPR(667,RO,0),U,6)'=""
WRITE !?16,$EXTRACT($PIECE(^RMPR(667.2,$PIECE(^RMPR(667,RO,0),U,6),0),U,1),1,11),?29,$EXTRACT($PIECE(^RMPR(667,RO,0),U,7),1,10),?43,$PIECE(^RMPR(667,RO,0),U,1)
SET Y=$PIECE(^RMPR(667,RO,0),U,8)
DO DD^%DT
WRITE ?64,Y
SET RMPRFLG=1
End DoDot:1
+25 KILL KILL,RMPRFLG
+26 WRITE !!,"Items Returned: ",?16,"Date",?29,"Item",?56
+27 WRITE "Serial",?68,"Status"
+28 if $DATA(^RMPR(665,RMPRDFN,7,0))
DO OLD
+29 IF $DATA(^RMPR(660.1,"C",RMPRDFN))
IF '$DATA(KILL)
SET RO=0
FOR I=1:1
SET RO=$ORDER(^RMPR(660.1,"C",RMPRDFN,RO))
if RO=""!($DATA(KILL))
QUIT
DO WRIL
+30 WRITE !
KILL I,J,L,R0
+31 NEW DIR
SET DIR(0)="E"
DO ^DIR
+32 SET FL=3
GOTO ASK2^RMPRPAT
+33 ;G ^RMPRPAT0:ANS=1,^RMPRPAT1:ANS=2,^RMPRPAT2:ANS=3,^RMPRPAT2:ANS="",EXIT^RMPRPAT Q
WRIL ;ASK TO SEE MORE RETURNED ITEMS
+1 IF $EXTRACT(IOST)["C"
IF I=4
SET %=2
WRITE !,"Would you like to see more returned items"
DO YN^DICN
IF %=-1!(%=2)
SET KILL=1
QUIT
+2 IF $EXTRACT(IOST)["C"
IF I=4
IF %=0
WRITE !,"Enter `YES` or `NO`"
GOTO WRIL
+3 IF $DATA(^RMPR(660.1,RO))
IF +$PIECE(^RMPR(660.1,RO,0),U,11)
Begin DoDot:1
+4 SET Y=$PIECE(^RMPR(660.1,RO,0),U,11)
+5 DO DD^%DT
WRITE !?16,Y
+6 if +$PIECE(^RMPR(660.1,RO,0),U,3)
WRITE ?29,$EXTRACT($PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^(0),U,3),0),U),0),U,2),1,20)
+7 if $PIECE(^RMPR(660.1,RO,0),U,21)
WRITE ?29,$EXTRACT(^RMPR(667.1,$PIECE(^(0),U,21),0),1,25)
WRITE ?56,$EXTRACT($PIECE(^RMPR(660.1,RO,0),U,6),1,10)
+8 WRITE ?68,$SELECT($PIECE(^RMPR(660.1,RO,0),U,14)=1:"RETURNED",$PIECE(^(0),U,14)=2:"CONDEMNED",$PIECE(^(0),U,14)=3:"TURNED-IN",$PIECE(^(0),U,14)=4:"LOST",$PIECE(^(0),U,14)=5:"BROKEN",1:"UNKNOWN")
End DoDot:1
+9 QUIT
OLD ;DISPLAY OLD RETURNED ITEMS
+1 SET RO=0
FOR I=1:1
SET RO=$ORDER(^RMPR(665,RMPRDFN,7,RO))
if RO=""!($DATA(KILL))
QUIT
DO OLD1
+2 QUIT
OLD1 IF I=4
IF $EXTRACT(IOST)["C"
SET %=2
WRITE !,"Would you like to see more returned items"
DO YN^DICN
IF %=-1!(%=2)
SET KILL=1
QUIT
+1 IF I=4
IF $EXTRACT(IOST)["C"
IF %=0
WRITE !,"Enter `YES` or `NO`"
GOTO OLD1
+2 IF $DATA(^RMPR(665,RMPRDFN,7,RO,0))
SET Y=$PIECE(^(0),U)
DO DD^%DT
WRITE !?16,$EXTRACT(Y,1,12),?29,$EXTRACT($PIECE(^RMPR(665,RMPRDFN,7,RO,0),U,4),1,20)
RTNSTA ;DISPLAYS STATUS OF TRACKED ITEM ON PATIENT'S 10-2319
+1 IF $TEST
SET R0=$PIECE(^RMPR(665,RMPRDFN,7,RO,0),U,2)
WRITE ?68,$SELECT(R0=1:"RETURNED",R0=2:"CONDENMED",R0=3:"TURNED-IN",R0=4:"LOST",R0=5:"BROKEN",1:"UNKNOWN")
+2 QUIT
HELP ;DISPLAY HELP FOR SCREENS
+1 NEW RMPR90DP,RMPR90I
WRITE !,"Select One of the Following: ",!
SET RMPR90DP=$PIECE(DIR(0),U,2,999)
FOR RMPR90I=1:1:RCNT
WRITE !,?5,$PIECE($PIECE(RMPR90DP,";",RMPR90I),":",1),?14,$PIECE($PIECE(RMPR90DP,";",RMPR90I),":",2)
+2 WRITE !
+3 QUIT
ASK1 ;SET DIR AND FOR SCREEN NUMBER DISPLAY
+1 ;patch *162 added RCNT variable and check to control 7 or 8 activity display depending on option entered.
+2 KILL DIR
SET DIR("A")="Enter 10-2319 screen to VIEW (1-"_$GET(RCNT)_"),'^' to EXIT, or 'return' to continue: "
+3 NEW %
SET DIR(0)="SAO^1:PATIENT DEMOGRAPHICS;2:CLINIC ENROLLMENTS/CORRESPONDENCE;3:ENTITLEMENT INFORMATION;4:APPLIANCE TRANSACTIONS;5:AUTO ADAPTIVE INFORMATION;6:CRITICAL COMMENTS;7:ADD/EDIT DISABILITY CODE"
+4 IF $GET(RCNT)=8
SET DIR(0)=DIR(0)_";8:HOME OXYGEN ITEMS;"
+5 SET DIR("?")="Enter a screen number (1-"_$GET(RCNT)_") OR '^' TO EXIT."
+6 IF $DATA(RFLG)
SET $PIECE(DIR(0),U,1)="SO"
if $DATA(DIR("A"))
SET DIR("A")=$PIECE(DIR("A"),":",1)_" "
KILL DIR("?")
+7 SET RFLG=1
+8 QUIT
