RMPOLF0 ;HIN CIOFO/RVD-DRIVER FOR HO LETTERS ;06/22/99
;;3.0;PROSTHETICS;**29,55,115,159**;Feb 09, 1996;Build 2
;
; ODJ - patch 55 - 1/29/01 - replace 121 hard code mail symbol with
; call to site param. extrinsic
; see nois AUG-1097-32118
;
D HOME^%ZIS S RMPRIN=0
K VADM,^TMP("RL",$J)
S Y=DT D DD^%DT S NAME=Y D TRANS^RMPRUTL1 S (RMPODT,RMPODATE)=RMPRNAME
D PIKSOM Q:$$QUIT I Y="" S VALMBCK="R" Q
M ^TMP("RL",$J)=^TMP($J)
S LFNS=Y I 'JOB D FULL^VALM1
;
QUED ;
F ZI=1:1:$L(LFNS,",")-1 D
. S LFN=$P(LFNS,",",ZI) Q:LFN'>0
. S RMPONAM="",CNT=0 F S RMPONAM=$O(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
.. S RMPOLTR=$P(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
.. S RMPODFN=$P(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
.. S RMDA=$P(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,3)
.. S CNT=CNT+1
.. S:CNT=LFN ^TMP("RL",$J,RMPOXITE,"LTR",RMPONAM)=RMPODFN_"^"_RMPOLTR_"^"_RMDA
S (RMBLNK,RMPONAM)="",RMQUIT=0
F S RMPONAM=$O(^TMP("RL",$J,RMPOXITE,"LTR",RMPONAM)) Q:RMPONAM=""!$G(RMQUIT) D CUM
;end
EXIT ;
K LFNS,LFN,ZI,RTN,DIR,RMLET,^TMP($J)
K %X,RMPRFFL,RMPRHED,RMPRPRIN,%Y,RMPRDEL,RMPRRVA,DIC,RMPRFA,KILL,DIE,DA
K DR,DIK,RMPR1,RMPR2,RMPRDATE,RMPRIN,RMPRL,RMPRNAME,RMPRU,RMPRDELE,FR
K RMPREND,VADM,VAPA,VA,NAME,RMPRGO,NAME1,RMPONAM
K RMPRDEN,RMPRFLAG,RMPRNAM1,RMPRNAM2,RMPRFF,J,RP,RO,RZ D KVAR^VADPT
M ^TMP($J)=^TMP("RL",$J) K ^TMP("RL",$J)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q:$D(ZTQUEUED)
D HOME^%ZIS D CLEAN^VALM10,INIT^RMPOLT S VALMBCK="R"
Q
;
CUM ;
K RMPRNT S RDATA=^TMP("RL",$J,RMPOXITE,"LTR",RMPONAM)
S DFN=$P(RDATA,U,1),RMPOLTR=$P(RDATA,U,2),RMDA=$P(RDATA,U,3)
S RMREC=^TMP("RL",$J,RMPOXITE,"RMPODEMO",DFN)
S RMPORX=$P(RMREC,U,6) S:RMPORX="" RMPORX="Not on file"
S RMPORXDT=$P(RMREC,U,4)
I RMPORXDT="" S RMPORXDT="n/a"
E S Y=RMPORXDT X ^DD("DD") S RMPORXDT=Y
S RMPRFA=RMPOLTR
D DEM^VADPT,ADD^VADPT
F RI=1:1:21 S ^TMP($J,"DW",RI,0)=" "
S RMPRHED=$G(^TMP("RL",$J,RMPOXITE,"HEADER",RMPOLTR))
W @IOF I 'RMPRHED G HEADER
S ^TMP($J,"DW",1,0)="|SETTAB(""C"")|"
S ^TMP($J,"DW",2,0)="|TAB|Department of Veterans Affairs"
S NAME=$P(^RMPR(669.9,RMPOXITE,2),U,4) I NAME]"" S NAME=$S($D(^DIC(5,NAME)):$P(^DIC(5,NAME,0),U),1:"STATE") S RMFXN=$$PARS^RMPRUTL1(NAME)
S ^TMP($J,"DW",3,0)="|TAB|"_$P(^RMPR(669.9,RMPOXITE,0),U)
S ^TMP($J,"DW",4,0)="|TAB|"_$P(^RMPR(669.9,RMPOXITE,2),U,2)
S ^TMP($J,"DW",5,0)="|TAB|"_$P(^RMPR(669.9,RMPOXITE,2),U,3)_", "_RMFXN_" "_$P(^RMPR(669.9,RMPOXITE,2),U,5) K RMFXN
S ^TMP($J,"DW",9,0)="|SETTAB(5,50)||TAB|"_RMPODT
S STATNID=$P(^RMPR(669.9,RMPOXITE,0),U,2) I $D(^DIC(4,STATNID,99)) S STATNID=$P(^DIC(4,STATNID,99),U)
S ^TMP($J,"DW",11,0)="|TAB|"_$P(VADM(1),",",2)_" "_$P(VADM(1),",",1)_"|TAB|In Reply Refer To: "_STATNID_"/"_$$ROU^RMPRUTIL(RMPOXITE)
K STATNID
S ^TMP($J,"DW",12,0)="|TAB|"_VAPA(1)
I VAPA(2)]"" S ^TMP($J,"DW",13,0)="|TAB|"_VAPA(2)_"|TAB|"_VADM(1),^TMP($J,"DW",14,0)="|TAB|"_VAPA(4)_","_" "_$P(VAPA(5),U,2)_" "_VAPA(6)
E S ^TMP($J,"DW",13,0)="|TAB|"_VAPA(4)_","_" "_$P(VAPA(5),U,2)_" "_VAPA(6)_"|TAB|"_VADM(1)
;
S ^TMP($J,"DW",15,0)="|TAB|"_RMBLNK_"|TAB|"_DFN
S ^TMP($J,"DW",16,0)="|TAB|"_RMBLNK_"|TAB|Current Home Oxygen Rx#: "_RMPORX
S ^TMP($J,"DW",17,0)="|TAB|"_RMBLNK_"|TAB|Rx Expiration Date: "_RMPORXDT
;
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
D NAME^RMPOLF1
Q
QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT
Q
PIKSOM ; ALLOW SELECTION FROM DISPLAYED ENTRIES
K DIR S DIR(0)="LO^"_VALMBG_":"_VALMLST D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLF0 3833 printed Sep 23, 2025@20:07:08 Page 2
RMPOLF0 ;HIN CIOFO/RVD-DRIVER FOR HO LETTERS ;06/22/99
+1 ;;3.0;PROSTHETICS;**29,55,115,159**;Feb 09, 1996;Build 2
+2 ;
+3 ; ODJ - patch 55 - 1/29/01 - replace 121 hard code mail symbol with
+4 ; call to site param. extrinsic
+5 ; see nois AUG-1097-32118
+6 ;
+7 DO HOME^%ZIS
SET RMPRIN=0
+8 KILL VADM,^TMP("RL",$JOB)
+9 SET Y=DT
DO DD^%DT
SET NAME=Y
DO TRANS^RMPRUTL1
SET (RMPODT,RMPODATE)=RMPRNAME
+10 DO PIKSOM
if $$QUIT
QUIT
IF Y=""
SET VALMBCK="R"
QUIT
+11 MERGE ^TMP("RL",$JOB)=^TMP($JOB)
+12 SET LFNS=Y
IF 'JOB
DO FULL^VALM1
+13 ;
QUED ;
+1 FOR ZI=1:1:$LENGTH(LFNS,",")-1
Begin DoDot:1
+2 SET LFN=$PIECE(LFNS,",",ZI)
if LFN'>0
QUIT
+3 SET RMPONAM=""
SET CNT=0
FOR
SET RMPONAM=$ORDER(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM))
if RMPONAM=""
QUIT
Begin DoDot:2
+4 SET RMPOLTR=$PIECE(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
+5 SET RMPODFN=$PIECE(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
+6 SET RMDA=$PIECE(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,3)
+7 SET CNT=CNT+1
+8 if CNT=LFN
SET ^TMP("RL",$JOB,RMPOXITE,"LTR",RMPONAM)=RMPODFN_"^"_RMPOLTR_"^"_RMDA
End DoDot:2
End DoDot:1
+9 SET (RMBLNK,RMPONAM)=""
SET RMQUIT=0
+10 FOR
SET RMPONAM=$ORDER(^TMP("RL",$JOB,RMPOXITE,"LTR",RMPONAM))
if RMPONAM=""!$GET(RMQUIT)
QUIT
DO CUM
+11 ;end
EXIT ;
+1 KILL LFNS,LFN,ZI,RTN,DIR,RMLET,^TMP($JOB)
+2 KILL %X,RMPRFFL,RMPRHED,RMPRPRIN,%Y,RMPRDEL,RMPRRVA,DIC,RMPRFA,KILL,DIE,DA
+3 KILL DR,DIK,RMPR1,RMPR2,RMPRDATE,RMPRIN,RMPRL,RMPRNAME,RMPRU,RMPRDELE,FR
+4 KILL RMPREND,VADM,VAPA,VA,NAME,RMPRGO,NAME1,RMPONAM
+5 KILL RMPRDEN,RMPRFLAG,RMPRNAM1,RMPRNAM2,RMPRFF,J,RP,RO,RZ
DO KVAR^VADPT
+6 MERGE ^TMP($JOB)=^TMP("RL",$JOB)
KILL ^TMP("RL",$JOB)
+7 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
if $DATA(ZTQUEUED)
QUIT
+8 DO HOME^%ZIS
DO CLEAN^VALM10
DO INIT^RMPOLT
SET VALMBCK="R"
+9 QUIT
+10 ;
CUM ;
+1 KILL RMPRNT
SET RDATA=^TMP("RL",$JOB,RMPOXITE,"LTR",RMPONAM)
+2 SET DFN=$PIECE(RDATA,U,1)
SET RMPOLTR=$PIECE(RDATA,U,2)
SET RMDA=$PIECE(RDATA,U,3)
+3 SET RMREC=^TMP("RL",$JOB,RMPOXITE,"RMPODEMO",DFN)
+4 SET RMPORX=$PIECE(RMREC,U,6)
if RMPORX=""
SET RMPORX="Not on file"
+5 SET RMPORXDT=$PIECE(RMREC,U,4)
+6 IF RMPORXDT=""
SET RMPORXDT="n/a"
+7 IF '$TEST
SET Y=RMPORXDT
XECUTE ^DD("DD")
SET RMPORXDT=Y
+8 SET RMPRFA=RMPOLTR
+9 DO DEM^VADPT
DO ADD^VADPT
+10 FOR RI=1:1:21
SET ^TMP($JOB,"DW",RI,0)=" "
+1 SET RMPRHED=$GET(^TMP("RL",$JOB,RMPOXITE,"HEADER",RMPOLTR))
+2 WRITE @IOF
IF 'RMPRHED
GOTO HEADER
+3 SET ^TMP($JOB,"DW",1,0)="|SETTAB(""C"")|"
+4 SET ^TMP($JOB,"DW",2,0)="|TAB|Department of Veterans Affairs"
+5 SET NAME=$PIECE(^RMPR(669.9,RMPOXITE,2),U,4)
IF NAME]""
SET NAME=$SELECT($DATA(^DIC(5,NAME)):$PIECE(^DIC(5,NAME,0),U),1:"STATE")
SET RMFXN=$$PARS^RMPRUTL1(NAME)
+6 SET ^TMP($JOB,"DW",3,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPOXITE,0),U)
+7 SET ^TMP($JOB,"DW",4,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPOXITE,2),U,2)
+8 SET ^TMP($JOB,"DW",5,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPOXITE,2),U,3)_", "_RMFXN_" "_$PIECE(^RMPR(669.9,RMPOXITE,2),U,5)
KILL RMFXN
+1 SET ^TMP($JOB,"DW",9,0)="|SETTAB(5,50)||TAB|"_RMPODT
+2 SET STATNID=$PIECE(^RMPR(669.9,RMPOXITE,0),U,2)
IF $DATA(^DIC(4,STATNID,99))
SET STATNID=$PIECE(^DIC(4,STATNID,99),U)
+3 SET ^TMP($JOB,"DW",11,0)="|TAB|"_$PIECE(VADM(1),",",2)_" "_$PIECE(VADM(1),",",1)_"|TAB|In Reply Refer To: "_STATNID_"/"_$$ROU^RMPRUTIL(RMPOXITE)
+4 KILL STATNID
+5 SET ^TMP($JOB,"DW",12,0)="|TAB|"_VAPA(1)
+6 IF VAPA(2)]""
SET ^TMP($JOB,"DW",13,0)="|TAB|"_VAPA(2)_"|TAB|"_VADM(1)
SET ^TMP($JOB,"DW",14,0)="|TAB|"_VAPA(4)_","_" "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
+7 IF '$TEST
SET ^TMP($JOB,"DW",13,0)="|TAB|"_VAPA(4)_","_" "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)_"|TAB|"_VADM(1)
+8 ;
+9 SET ^TMP($JOB,"DW",15,0)="|TAB|"_RMBLNK_"|TAB|"_DFN
+10 SET ^TMP($JOB,"DW",16,0)="|TAB|"_RMBLNK_"|TAB|Current Home Oxygen Rx#: "_RMPORX
+11 SET ^TMP($JOB,"DW",17,0)="|TAB|"_RMBLNK_"|TAB|Rx Expiration Date: "_RMPORXDT
+12 ;
+13 SET NAME=$PIECE(VADM(1),",")
+14 IF $PIECE(NAME," ",2)?1A.A
Begin DoDot:1
+15 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
+16 IF '$TEST
DO TRANS^RMPRUTL1
+17 DO NAME^RMPOLF1
+18 QUIT
QUIT() SET QUIT=$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT QUIT
+1 QUIT
PIKSOM ; ALLOW SELECTION FROM DISPLAYED ENTRIES
+1 KILL DIR
SET DIR(0)="LO^"_VALMBG_":"_VALMLST
DO ^DIR
+2 QUIT
