RMPV0RMPRPAT5 ; OIT/JDA - Adapted from RMPRPAT5; Dec 01, 2024@21:44:41
;;1.0;PROSTHETICS VISION 4 SIGHT II;**2**;Jan 31, 2025;Build 38
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Reference to file #665 supported by ICR #6537
; Reference to file #2 (^DPT) supported by ICR #7019
;
RMPRPAT5 ;PHX/RFM-DISPLAY/PRINT CRITICAL COMMENTS ;8/29/1994
;;3.0;PROSTHETICS;**20**;Feb 09, 1996
I '$D(RMPRDFN) D GETPAT^RMPV0RMPRUTIL
; start truncate line
D:$E(IOST)["C" WRITEIND^RMPVIO("@IOF") I '$D(^RMPR(665,RMPRDFN,8,1,0)) D
. D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("PATIENT: "),WRITE^RMPVIO($P(^DPT(RMPRDFN,0),U)),WRITECTL^RMPVIO("?60")
. D WRITE^RMPVIO("CRITICAL COMMENTS"),WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("No Patient Critical Comments Recorded for this patient!"),WRITECTL^RMPVIO("!!") S RMPRCCO=1 G CRI
; end truncation
D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("PATIENT: "),WRITE^RMPVIO($P(^DPT(RMPRDFN,0),U)),WRITECTL^RMPVIO("?60"),WRITE^RMPVIO("CRITICAL COMMENTS"),WRITECTL^RMPVIO("!!")
S RO=0 F S RO=$O(^RMPR(665,RMPRDFN,8,RO)) Q:RO="" D WRI
; line truncated
CRI S %=2 D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("Would you like to Add/Edit Patient Critical Comments") D YNDICN^RMPVFM D:%=0 WRITECTL^RMPVIO("!"),WRITE^RMPVIO("Enter `YES or `NO`")
G CRI:%=0,EXIT^RMPV0RMPRPAT:$D(DTOUT),EDIT:%=1 I %=2!(%=-1) D WRITEIND^RMPVIO("@IOF") G ASK1^RMPV0RMPRPAT
; end truncation
WRI D WRITECTL^RMPVIO("!"),WRITE^RMPVIO(^RMPR(665,RMPRDFN,8,RO,0)) Q
EDIT I $D(RMPRCCO) S DIE=665,DA=RMPRDFN,DR=30 D %DIE^RMPVFM G RMPRPAT5
K DIC S DIC="^RMPR(665,RMPRDFN,8," D ENDIWE^RMPVFM G RMPRPAT5
Q
DIS Q:'$D(RMPRDFN) I $D(RMPRDD) K RMPRDD Q
D WRITE^RMPVIO($C(7)),WRITE^RMPVIO($C(7)),WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("Disability Code has not been entered for this Patient! You must enter a")
D WRITECTL^RMPVIO("!"),WRITE^RMPVIO("Prosthetic Disability Code to continue.") D EN^RMPV0RMPRDIS I '$D(^RMPR(665,RMPRDFN,1,0)) S RMPRKILL=1 Q
I $D(^RMPR(665,RMPRDFN,1,0)),'$O(^(0)) S RMPRKILL=1 Q
DISP ;DISPLAY DISABILITY CODES
Q:'$D(^RMPR(665,RMPRDFN,1,0)) I '$O(^(0)) Q
D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("Current Disability Codes are: ")
D WRITECTL^RMPVIO("!") S RO=0 F I=1:1 S RO=$O(^RMPR(665,RMPRDFN,1,RO)) Q:RO'>0!($D(RMPRQ)) D WRI1
Q
WRI1 I I>4 D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO("*More Disability Codes on File, See Screen 1") S RMPRQ=1 Q
I $D(^RMPR(662,$P(^RMPR(665,RMPRDFN,1,RO,0),U,1),0)) D WRITECTL^RMPVIO("!"),WRITE^RMPVIO($P(^(0),U,1)) D
. S J=$P(^RMPR(665,RMPRDFN,1,RO,0),U,4)
. D WRITECTL^RMPVIO("?15"),WRITE^RMPVIO($S(J=1:"SC VIETNAM",J=2:"ALL OTHER S/C",J=3:"NSC A&A",J=4:"OTHERS ELIG",J=5:"V.I.S.T.",J=6:"VOC REHAB",J=7:"PHC",J=8:"INPATIENT",J=9:"EMPLOYEE",J=10:"PRIMA FACIA",1:"UNK"))
. D WRITECTL^RMPVIO("?30"),WRITE^RMPVIO($S($P(^RMPR(665,RMPRDFN,1,RO,0),U,3)=1:"S/C",$P(^(0),U,3)=2:"NSC",1:"UNK"))
. S J=$P(^RMPR(665,RMPRDFN,1,RO,0),U,5)
. D WRITECTL^RMPVIO("?36"),WRITE^RMPVIO($S(J=1:"PL-96-151",J=2:"PL-91-500",J=3:"PL-97-37",J=4:"PL-94-581",J=5:"HOUSEBOUND",J=6:"PL-91-102",J=7:"PL-91-666",J=8:"PL-104-262 (ELIG. REFORM",1:""))
I $P(^RMPR(665,RMPRDFN,1,RO,0),U,10) D WRITECTL^RMPVIO("?50"),WRITE^RMPVIO("Deleted...")
Q
NPC ;CHECK ALL DISABILITY CODES MARKED DELETED
K RA F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,1,RI)) Q:RI'>0 I $D(^(RI,0)) S RA=1 I '$P(^(0),U,10) K RA Q
; start truncate
I $D(RA) D WRITECTL^RMPVIO("!!"),WRITE^RMPVIO($C(7)),WRITECTL^RMPVIO("?5"),WRITE^RMPVIO("The Patient's Disability Codes have been Marked as Deleted.") D
. D WRITECTL^RMPVIO("!"),WRITECTL^RMPVIO("?5"),WRITE^RMPVIO("No Purchasing may be done for this patient") S RMPRKILL=1 H 3
; end truncation
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPV0RMPRPAT5 3690 printed May 25, 2026@12:50:54 Page 2
RMPV0RMPRPAT5 ; OIT/JDA - Adapted from RMPRPAT5; Dec 01, 2024@21:44:41
+1 ;;1.0;PROSTHETICS VISION 4 SIGHT II;**2**;Jan 31, 2025;Build 38
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Reference to file #665 supported by ICR #6537
+5 ; Reference to file #2 (^DPT) supported by ICR #7019
+6 ;
RMPRPAT5 ;PHX/RFM-DISPLAY/PRINT CRITICAL COMMENTS ;8/29/1994
+1 ;;3.0;PROSTHETICS;**20**;Feb 09, 1996
+2 IF '$DATA(RMPRDFN)
DO GETPAT^RMPV0RMPRUTIL
+3 ; start truncate line
+4 if $EXTRACT(IOST)["C"
DO WRITEIND^RMPVIO("@IOF")
IF '$DATA(^RMPR(665,RMPRDFN,8,1,0))
Begin DoDot:1
+5 DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("PATIENT: ")
DO WRITE^RMPVIO($PIECE(^DPT(RMPRDFN,0),U))
DO WRITECTL^RMPVIO("?60")
+6 DO WRITE^RMPVIO("CRITICAL COMMENTS")
DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("No Patient Critical Comments Recorded for this patient!")
DO WRITECTL^RMPVIO("!!")
SET RMPRCCO=1
GOTO CRI
End DoDot:1
+7 ; end truncation
+8 DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("PATIENT: ")
DO WRITE^RMPVIO($PIECE(^DPT(RMPRDFN,0),U))
DO WRITECTL^RMPVIO("?60")
DO WRITE^RMPVIO("CRITICAL COMMENTS")
DO WRITECTL^RMPVIO("!!")
+9 SET RO=0
FOR
SET RO=$ORDER(^RMPR(665,RMPRDFN,8,RO))
if RO=""
QUIT
DO WRI
+10 ; line truncated
CRI SET %=2
DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("Would you like to Add/Edit Patient Critical Comments")
DO YNDICN^RMPVFM
if %=0
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("Enter `YES or `NO`")
+1 if %=0
GOTO CRI
if $DATA(DTOUT)
GOTO EXIT^RMPV0RMPRPAT
if %=1
GOTO EDIT
IF %=2!(%=-1)
DO WRITEIND^RMPVIO("@IOF")
GOTO ASK1^RMPV0RMPRPAT
+2 ; end truncation
WRI DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO(^RMPR(665,RMPRDFN,8,RO,0))
QUIT
EDIT IF $DATA(RMPRCCO)
SET DIE=665
SET DA=RMPRDFN
SET DR=30
DO %DIE^RMPVFM
GOTO RMPRPAT5
+1 KILL DIC
SET DIC="^RMPR(665,RMPRDFN,8,"
DO ENDIWE^RMPVFM
GOTO RMPRPAT5
+2 QUIT
DIS if '$DATA(RMPRDFN)
QUIT
IF $DATA(RMPRDD)
KILL RMPRDD
QUIT
+1 DO WRITE^RMPVIO($CHAR(7))
DO WRITE^RMPVIO($CHAR(7))
DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("Disability Code has not been entered for this Patient! You must enter a")
+2 DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO("Prosthetic Disability Code to continue.")
DO EN^RMPV0RMPRDIS
IF '$DATA(^RMPR(665,RMPRDFN,1,0))
SET RMPRKILL=1
QUIT
+3 IF $DATA(^RMPR(665,RMPRDFN,1,0))
IF '$ORDER(^(0))
SET RMPRKILL=1
QUIT
DISP ;DISPLAY DISABILITY CODES
+1 if '$DATA(^RMPR(665,RMPRDFN,1,0))
QUIT
IF '$ORDER(^(0))
QUIT
+2 DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("Current Disability Codes are: ")
+3 DO WRITECTL^RMPVIO("!")
SET RO=0
FOR I=1:1
SET RO=$ORDER(^RMPR(665,RMPRDFN,1,RO))
if RO'>0!($DATA(RMPRQ))
QUIT
DO WRI1
+4 QUIT
WRI1 IF I>4
DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO("*More Disability Codes on File, See Screen 1")
SET RMPRQ=1
QUIT
+1 IF $DATA(^RMPR(662,$PIECE(^RMPR(665,RMPRDFN,1,RO,0),U,1),0))
DO WRITECTL^RMPVIO("!")
DO WRITE^RMPVIO($PIECE(^(0),U,1))
Begin DoDot:1
+2 SET J=$PIECE(^RMPR(665,RMPRDFN,1,RO,0),U,4)
+3 DO WRITECTL^RMPVIO("?15")
DO WRITE^RMPVIO($SELECT(J=1:"SC VIETNAM",J=2:"ALL OTHER S/C",J=3:"NSC A&A",J=4:"OTHERS ELIG",J=5:"V.I.S.T.",J=6:"VOC REHAB",J=7:"PHC",J=8:"INPATIENT",J=9:"EMPLOYEE",J=10:"PRIMA FACIA",1:"UNK"))
+4 DO WRITECTL^RMPVIO("?30")
DO WRITE^RMPVIO($SELECT($PIECE(^RMPR(665,RMPRDFN,1,RO,0),U,3)=1:"S/C",$PIECE(^(0),U,3)=2:"NSC",1:"UNK"))
+5 SET J=$PIECE(^RMPR(665,RMPRDFN,1,RO,0),U,5)
+6 DO WRITECTL^RMPVIO("?36")
DO WRITE^RMPVIO($SELECT(J=1:"PL-96-151",J=2:"PL-91-500",J=3:"PL-97-37",J=4:"PL-94-581",J=5:"HOUSEBOUND",J=6:"PL-91-102",J=7:"PL-91-666",J=8:"PL-104-262 (ELIG. REFORM",1:""))
End DoDot:1
+7 IF $PIECE(^RMPR(665,RMPRDFN,1,RO,0),U,10)
DO WRITECTL^RMPVIO("?50")
DO WRITE^RMPVIO("Deleted...")
+8 QUIT
NPC ;CHECK ALL DISABILITY CODES MARKED DELETED
+1 KILL RA
FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RMPRDFN,1,RI))
if RI'>0
QUIT
IF $DATA(^(RI,0))
SET RA=1
IF '$PIECE(^(0),U,10)
KILL RA
QUIT
+2 ; start truncate
+3 IF $DATA(RA)
DO WRITECTL^RMPVIO("!!")
DO WRITE^RMPVIO($CHAR(7))
DO WRITECTL^RMPVIO("?5")
DO WRITE^RMPVIO("The Patient's Disability Codes have been Marked as Deleted.")
Begin DoDot:1
+4 DO WRITECTL^RMPVIO("!")
DO WRITECTL^RMPVIO("?5")
DO WRITE^RMPVIO("No Purchasing may be done for this patient")
SET RMPRKILL=1
HANG 3
End DoDot:1
+5 ; end truncation
