RMPRFO ;PHX/RFM,HPL-DRIVER FOR PROSTHETIC LETTERS ; 1/5/04 1:41pm
;;3.0;PROSTHETICS;**55,77,82,105**;Feb 09, 1996
;
; ODJ - patch 55 - 1/29/01 - replace hard code 121 mail symbol with
; call to extrinsic to read site param.
; nois AUG-1097-32118
;RVD patch #77 - remove link to suspense
;KAM patch #82 - remove SSN from Patient Correspondence print
N RMPRAA68 K ^TMP($J,1),^TMP($J,"RMPR") D HOME^%ZIS S RMPRIN=0
K RMPRFF,DFN
S RMPRDEL="S RMPRGO=$S($D(^RMPR(665.4,RMPRIN,0)):""DEL^RMPRFO1"",1:""EXIT^RMPRFO1"") G @RMPRGO"
I '$D(RMPRFF)!($G(DFN)="") D DIV4^RMPRSIT G:$D(X) EXIT^RMPRFO1 S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Select PATIENT: "
I $D(RMPRFF)&($G(DFN)>0) S DIC="^DPT(",DIC(0)="N"
D ^DIC G:Y<0 EXIT^RMPRFO1
K DIC S DFN=+Y
CUM K ^TMP($J,1),^TMP($J,"RMPR")
S Y=DT D DD^%DT S NAME=Y D TRANS^RMPRUTL1 S RMPRDATE=RMPRNAME
S DIC="^RMPR(665.2,",DIC(0)="AEMQ",DIC("A")="Select FORM LETTER TYPE: " D ^DIC G:Y<0 EXIT^RMPRFO1
K DIC S RMPRFA=+Y
S RMPRTY=$P(Y,U,2)
I $P(^RMPR(665.2,RMPRFA,0),U,3) D VEN^RMPRFO3 D EXIT^RMPRFO1 Q
D DEM^VADPT,ADD^VADPT
F RI=1:1:17 S ^TMP($J,1,RI,0)=" "
HEAD1 S %=1 W !,"Would you like a header on this letter" D YN^DICN S RMPRAA68=% G:RMPRAA68<0 EXIT^RMPRFO1
I RMPRAA68=0 W !,"Answer `YES` for a header, `NO` for no header" G HEAD1
W @IOF I RMPRAA68=2 S RMPRHED=1 G HEADER
S ^TMP($J,1,1,0)="|SETTAB(""C"")|"
S ^TMP($J,1,2,0)="|TAB|Department of Veterans Affairs"
S NAME=$P(^RMPR(669.9,RMPRSITE,2),U,4) I NAME]"" S NAME=$S($D(^DIC(5,NAME)):$P(^DIC(5,NAME,0),U),1:"STATE") W $$PARS^RMPRUTL1(NAME)
S ^TMP($J,1,3,0)="|TAB|"_$P(^RMPR(669.9,RMPRSITE,0),U)
S ^TMP($J,1,4,0)="|TAB|"_$P(^RMPR(669.9,RMPRSITE,2),U,2)
S ^TMP($J,1,5,0)="|TAB|"_$P(^RMPR(669.9,RMPRSITE,2),U,3)_", "_FIXDNAME_" "_$P(^RMPR(669.9,RMPRSITE,2),U,5) K FIXDNAME
I '$D(RMPRHED) D
. S ^TMP($J,1,11,0)="|TAB|"_$P(VADM(1),",",2)_" "_$P(VADM(1),",",1)_"|TAB|In Reply Refer To: "_$$STA^RMPRUTIL_"/"_$$ROU^RMPRUTIL(RMPRSITE)
. Q
E D
. S ^TMP($J,1,11,0)="|TAB|"_$P(VADM(1),",",2)_" "_$P(VADM(1),",",1)_"|TAB|"_" "_$$STA^RMPRUTIL_"/"_$$ROU^RMPRUTIL(RMPRSITE)
. Q
S ^TMP($J,1,12,0)="|TAB|"_VAPA(1)
I VAPA(2)]"" S ^TMP($J,1,13,0)="|TAB|"_VAPA(2)_"|TAB|"_VADM(1),^TMP($J,1,14,0)="|TAB|"_VAPA(4)_","_" "_$P(VAPA(5),U,2)_" "_VAPA(6)
E S ^TMP($J,1,13,0)="|TAB|"_VAPA(4)_","_" "_$P(VAPA(5),U,2)_" "_VAPA(6)_"|TAB|"_VADM(1)
S NAME=$P(VADM(1),",")
I $P(NAME," ",2)?1A.A D
.S NAME1=NAME,NAME=$P(NAME," ",1) D TRANS^RMPRUTL1 S RMPRNAM1=RMPRNAME,NAME=NAME1,NAME=$P(NAME," ",2) D TRANS^RMPRUTL1 S RMPRNAM2=RMPRNAME,RMPRNAME=RMPRNAM1_" "_RMPRNAM2
E D TRANS^RMPRUTL1
G NAME^RMPRFO1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRFO 2762 printed Dec 13, 2024@02:34:42 Page 2
RMPRFO ;PHX/RFM,HPL-DRIVER FOR PROSTHETIC LETTERS ; 1/5/04 1:41pm
+1 ;;3.0;PROSTHETICS;**55,77,82,105**;Feb 09, 1996
+2 ;
+3 ; ODJ - patch 55 - 1/29/01 - replace hard code 121 mail symbol with
+4 ; call to extrinsic to read site param.
+5 ; nois AUG-1097-32118
+6 ;RVD patch #77 - remove link to suspense
+7 ;KAM patch #82 - remove SSN from Patient Correspondence print
+8 NEW RMPRAA68
KILL ^TMP($JOB,1),^TMP($JOB,"RMPR")
DO HOME^%ZIS
SET RMPRIN=0
+9 KILL RMPRFF,DFN
+10 SET RMPRDEL="S RMPRGO=$S($D(^RMPR(665.4,RMPRIN,0)):""DEL^RMPRFO1"",1:""EXIT^RMPRFO1"") G @RMPRGO"
+11 IF '$DATA(RMPRFF)!($GET(DFN)="")
DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT^RMPRFO1
SET DIC="^DPT("
SET DIC(0)="AEMQ"
SET DIC("A")="Select PATIENT: "
+12 IF $DATA(RMPRFF)&($GET(DFN)>0)
SET DIC="^DPT("
SET DIC(0)="N"
+13 DO ^DIC
if Y<0
GOTO EXIT^RMPRFO1
+14 KILL DIC
SET DFN=+Y
CUM KILL ^TMP($JOB,1),^TMP($JOB,"RMPR")
+1 SET Y=DT
DO DD^%DT
SET NAME=Y
DO TRANS^RMPRUTL1
SET RMPRDATE=RMPRNAME
+2 SET DIC="^RMPR(665.2,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select FORM LETTER TYPE: "
DO ^DIC
if Y<0
GOTO EXIT^RMPRFO1
+3 KILL DIC
SET RMPRFA=+Y
+4 SET RMPRTY=$PIECE(Y,U,2)
+5 IF $PIECE(^RMPR(665.2,RMPRFA,0),U,3)
DO VEN^RMPRFO3
DO EXIT^RMPRFO1
QUIT
+6 DO DEM^VADPT
DO ADD^VADPT
+7 FOR RI=1:1:17
SET ^TMP($JOB,1,RI,0)=" "
HEAD1 SET %=1
WRITE !,"Would you like a header on this letter"
DO YN^DICN
SET RMPRAA68=%
if RMPRAA68<0
GOTO EXIT^RMPRFO1
+1 IF RMPRAA68=0
WRITE !,"Answer `YES` for a header, `NO` for no header"
GOTO HEAD1
+2 WRITE @IOF
IF RMPRAA68=2
SET RMPRHED=1
GOTO HEADER
+3 SET ^TMP($JOB,1,1,0)="|SETTAB(""C"")|"
+4 SET ^TMP($JOB,1,2,0)="|TAB|Department of Veterans Affairs"
+5 SET NAME=$PIECE(^RMPR(669.9,RMPRSITE,2),U,4)
IF NAME]""
SET NAME=$SELECT($DATA(^DIC(5,NAME)):$PIECE(^DIC(5,NAME,0),U),1:"STATE")
WRITE $$PARS^RMPRUTL1(NAME)
+6 SET ^TMP($JOB,1,3,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPRSITE,0),U)
+7 SET ^TMP($JOB,1,4,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPRSITE,2),U,2)
+8 SET ^TMP($JOB,1,5,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPRSITE,2),U,3)_", "_FIXDNAME_" "_$PIECE(^RMPR(669.9,RMPRSITE,2),U,5)
KILL FIXDNAME
+1 IF '$DATA(RMPRHED)
Begin DoDot:1
+2 SET ^TMP($JOB,1,11,0)="|TAB|"_$PIECE(VADM(1),",",2)_" "_$PIECE(VADM(1),",",1)_"|TAB|In Reply Refer To: "_$$STA^RMPRUTIL_"/"_$$ROU^RMPRUTIL(RMPRSITE)
+3 QUIT
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET ^TMP($JOB,1,11,0)="|TAB|"_$PIECE(VADM(1),",",2)_" "_$PIECE(VADM(1),",",1)_"|TAB|"_" "_$$STA^RMPRUTIL_"/"_$$ROU^RMPRUTIL(RMPRSITE)
+6 QUIT
End DoDot:1
+7 SET ^TMP($JOB,1,12,0)="|TAB|"_VAPA(1)
+8 IF VAPA(2)]""
SET ^TMP($JOB,1,13,0)="|TAB|"_VAPA(2)_"|TAB|"_VADM(1)
SET ^TMP($JOB,1,14,0)="|TAB|"_VAPA(4)_","_" "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
+9 IF '$TEST
SET ^TMP($JOB,1,13,0)="|TAB|"_VAPA(4)_","_" "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)_"|TAB|"_VADM(1)
+10 SET NAME=$PIECE(VADM(1),",")
+11 IF $PIECE(NAME," ",2)?1A.A
Begin DoDot:1
+12 SET NAME1=NAME
SET NAME=$PIECE(NAME," ",1)
DO TRANS^RMPRUTL1
SET RMPRNAM1=RMPRNAME
SET NAME=NAME1
SET NAME=$PIECE(NAME," ",2)
DO TRANS^RMPRUTL1
SET RMPRNAM2=RMPRNAME
SET RMPRNAME=RMPRNAM1_" "_RMPRNAM2
End DoDot:1
+13 IF '$TEST
DO TRANS^RMPRUTL1
+14 GOTO NAME^RMPRFO1
