RMPOLET2 ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
;;3.0;PROSTHETICS;**29,55,159**;Feb 09, 1996;Build 2
;
; ODJ - patch 55 - 1/30/01 - replace hard code 121 mail symbol with
; site param. extrinsic (AUG-1097-32118)
;
START ;
N HEAD,REC,POS
;
K ^TMP($J)
Q:'$$SITE^RMPOLET0
;
D GENOLST^RMPOLET0(1) ;generate list of patient to print
;
I '$D(^TMP($J)) D G EXIT
. W !!,"There are no letters to print for this site."
. W !!,"Use the 'List of Patients' option to create a list.",!!,$C(7)
;
Q:'$$LOCK^RMPOLET0("work with current")
;
F D ASKHEAD Q:%'=0
S HEAD=% W @IOF
S %ZIS="Q" D ^%ZIS Q:$G(POP)=1
I $D(IO("Q")) D Q:'$$QUEUE^RMPOLET1(ZTDESC,ZTRTN,.ZTSAVE) D HOME^%ZIS Q
. K ZTSAVE
. S ZTDESC="RMPO : Patient Letter Print"
. S ZTRTN="PRINT^RMPOLET2("_HEAD_")"
. S (ZTSAVE("RMPOXITE"),ZTSAVE("RMPOSITE"),ZTSAVE("RMPO("),ZTSAVE("^TMP($J,"))=""
D PRINT(HEAD),EXIT
Q
ASKHEAD ;
S %=1 W !,"Would you like a letterhead printed on the letters"
D YN^DICN
Q:%<0
I %=0 W !,"Answer 'Yes' for a header, 'No' for no header."
Q
;
PRINT(HEAD) ; Print H.O. correspondence
N DATE
;
U IO(0) S Y=DT X ^DD("DD") S DATE=Y D:HEAD=1 HEADER
;
S RMPOLCD="" F S RMPOLCD=$O(^TMP($J,"RMPOLST",RMPOLCD)) Q:RMPOLCD="" D
. S RMPODFN="" F S RMPODFN=$O(^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)) Q:RMPODFN="" D
. . S RMPOLTR=^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)
. . S REC=^TMP($J,"RMPODEMO",RMPODFN) D BODY
;
Q
BODY ; Set up array for filing and print letter
N I,LN,LNCT,SP,Y,NAME,SURNM,FRSTNM
;
S $P(SP," ",80)=" ",LNCT=0
I HEAD'=1 F I=1:1:5 D LINE("")
E D
. F I=1:1:5 D LINE("")
. D LINE($E(SP,1,POS(1))_HEAD(1)),LINE($E(SP,1,POS(2))_HEAD(2))
. D LINE($E(SP,1,POS(3))_HEAD(3)),LINE($E(SP,1,POS(4))_HEAD(4))
. F I=1:1:4 D LINE("")
D LINE(DATE),LINE("")
S NAME=$P(REC,U),SURNM=$P(NAME,",",2),FRSTNM=$P(NAME,",")
S LN=$E(FRSTNM_" "_SURNM_SP,1,40)_"In Reply Refer To: "_RMPO("NAME")_"/"_$$ROU^RMPRUTIL(RMPOXITE)
D LINE(LN)
S LN=$P(REC,U,10),LN=$E(LN_SP,1,40)
D LINE(LN)
S LN=$P(REC,U,11) I LN]"" S LN=$E(LN_SP,1,40) D LINE(LN)
I $P(REC,U,12)]"" D LINE($P(REC,U,12))
;
; City, State, Zip
D LINE($P(REC,U,13)_", "_$P(REC,U,14)_" "_$P(REC,U,15))
;I $P(REC,U,11)="",$P(REC,U,12)="" D LINE($E(SP,1,40)_$P(RMPODFN,U))
S RMPORX=$P(REC,U,6) S:RMPORX="" RMPORX="Not on file"
D LINE($E(SP,1,40)_FRSTNM_" "_SURNM)
D LINE($E(SP,1,40)_"Current Home Oxygen Rx#: "_RMPORX)
S LN=$E(SP,1,40)_"Rx Expiration Date: "
S RMPORXDT=$P(REC,U,4)
I RMPORXDT="" S RMPORXDT="n/a"
E S Y=RMPORXDT X ^DD("DD") S RMPORXDT=Y
D LINE(LN_RMPORXDT),LINE("")
D LINE("Dear "_$S($P(REC,U,9)="F":"Ms. ",1:"Mr. ")_SURNM_":")
D LINE(""),LINE("")
;
; print letter template
S I=0 F S I=$O(^RMPR(665.2,RMPOLTR,1,I)) Q:'I D LINE(^(I,0))
;
; Update Correspondence Tracking
; DO NOT remove patient from list is correspondence update unsuccessful.
S X=$$FILE^RMPOLETU(RMPODFN,"^TMP($J,""LINE"")",LNCT,RMPOLTR)
I 'X W !,"<<< Error"_+X_":"_$P(X,";",2)_" Patient #"_RMPODFN_" ! >>>",*7 Q
;
D UPDLTR^RMPOLET0(RMPODFN,"@") ; Clear "letter to be sent" field in RMPR(665
;
I IOST["C-" R !!,"Press <ENTER> to continue",ANS:DTIME Q:'$T
Q
;
LINE(X) S LNCT=LNCT+1,^TMP($J,"LINE",LNCT,0)=" "_X
W !,?9,X
Q
;
S HEAD(1)="Department of Veterans Affairs",POS(1)=45-($L(HEAD(1))\2)
S HEAD(2)=RMPO("NAME"),POS(2)=45-($L(HEAD(2))\2) ;name of VAMC
S HEAD(3)=RMPO("ADD"),POS(3)=45-($L(HEAD(3))\2) ;street address of VAMC
S HEAD(4)=RMPO("CITY"),POS(4)=45-($L(HEAD(4))\2) ;city,state and zip of VAMC
Q
;
EXIT ;Clean up and quit
;
;Close printer
D ^%ZISC
;
; clear lock of virtual control record
L -^TMP("RMPO",$J,"LETTERPRINT")
;
;Kill off variables
K ^TMP($J),%ZIS,Y,ZTSAVE,ZTRTN,RMPO,ZTDESC,L,LET
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLET2 3861 printed Sep 23, 2025@20:07:05 Page 2
RMPOLET2 ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,55,159**;Feb 09, 1996;Build 2
+2 ;
+3 ; ODJ - patch 55 - 1/30/01 - replace hard code 121 mail symbol with
+4 ; site param. extrinsic (AUG-1097-32118)
+5 ;
START ;
+1 NEW HEAD,REC,POS
+2 ;
+3 KILL ^TMP($JOB)
+4 if '$$SITE^RMPOLET0
QUIT
+5 ;
+6 ;generate list of patient to print
DO GENOLST^RMPOLET0(1)
+7 ;
+8 IF '$DATA(^TMP($JOB))
Begin DoDot:1
+9 WRITE !!,"There are no letters to print for this site."
+10 WRITE !!,"Use the 'List of Patients' option to create a list.",!!,$CHAR(7)
End DoDot:1
GOTO EXIT
+11 ;
+12 if '$$LOCK^RMPOLET0("work with current")
QUIT
+13 ;
+14 FOR
DO ASKHEAD
if %'=0
QUIT
+15 SET HEAD=%
WRITE @IOF
+16 SET %ZIS="Q"
DO ^%ZIS
if $GET(POP)=1
QUIT
+17 IF $DATA(IO("Q"))
Begin DoDot:1
+18 KILL ZTSAVE
+19 SET ZTDESC="RMPO : Patient Letter Print"
+20 SET ZTRTN="PRINT^RMPOLET2("_HEAD_")"
+21 SET (ZTSAVE("RMPOXITE"),ZTSAVE("RMPOSITE"),ZTSAVE("RMPO("),ZTSAVE("^TMP($J,"))=""
End DoDot:1
if '$$QUEUE^RMPOLET1(ZTDESC,ZTRTN,.ZTSAVE)
QUIT
DO HOME^%ZIS
QUIT
+22 DO PRINT(HEAD)
DO EXIT
+23 QUIT
ASKHEAD ;
+1 SET %=1
WRITE !,"Would you like a letterhead printed on the letters"
+2 DO YN^DICN
+3 if %<0
QUIT
+4 IF %=0
WRITE !,"Answer 'Yes' for a header, 'No' for no header."
+5 QUIT
+6 ;
PRINT(HEAD) ; Print H.O. correspondence
+1 NEW DATE
+2 ;
+3 USE IO(0)
SET Y=DT
XECUTE ^DD("DD")
SET DATE=Y
if HEAD=1
DO HEADER
+4 ;
+5 SET RMPOLCD=""
FOR
SET RMPOLCD=$ORDER(^TMP($JOB,"RMPOLST",RMPOLCD))
if RMPOLCD=""
QUIT
Begin DoDot:1
+6 SET RMPODFN=""
FOR
SET RMPODFN=$ORDER(^TMP($JOB,"RMPOLST",RMPOLCD,RMPODFN))
if RMPODFN=""
QUIT
Begin DoDot:2
+7 SET RMPOLTR=^TMP($JOB,"RMPOLST",RMPOLCD,RMPODFN)
+8 SET REC=^TMP($JOB,"RMPODEMO",RMPODFN)
DO BODY
End DoDot:2
End DoDot:1
+9 ;
+10 QUIT
BODY ; Set up array for filing and print letter
+1 NEW I,LN,LNCT,SP,Y,NAME,SURNM,FRSTNM
+2 ;
+3 SET $PIECE(SP," ",80)=" "
SET LNCT=0
+4 IF HEAD'=1
FOR I=1:1:5
DO LINE("")
+5 IF '$TEST
Begin DoDot:1
+6 FOR I=1:1:5
DO LINE("")
+7 DO LINE($EXTRACT(SP,1,POS(1))_HEAD(1))
DO LINE($EXTRACT(SP,1,POS(2))_HEAD(2))
+8 DO LINE($EXTRACT(SP,1,POS(3))_HEAD(3))
DO LINE($EXTRACT(SP,1,POS(4))_HEAD(4))
+9 FOR I=1:1:4
DO LINE("")
End DoDot:1
+10 DO LINE(DATE)
DO LINE("")
+11 SET NAME=$PIECE(REC,U)
SET SURNM=$PIECE(NAME,",",2)
SET FRSTNM=$PIECE(NAME,",")
+12 SET LN=$EXTRACT(FRSTNM_" "_SURNM_SP,1,40)_"In Reply Refer To: "_RMPO("NAME")_"/"_$$ROU^RMPRUTIL(RMPOXITE)
+13 DO LINE(LN)
+14 SET LN=$PIECE(REC,U,10)
SET LN=$EXTRACT(LN_SP,1,40)
+15 DO LINE(LN)
+16 SET LN=$PIECE(REC,U,11)
IF LN]""
SET LN=$EXTRACT(LN_SP,1,40)
DO LINE(LN)
+17 IF $PIECE(REC,U,12)]""
DO LINE($PIECE(REC,U,12))
+18 ;
+19 ; City, State, Zip
+20 DO LINE($PIECE(REC,U,13)_", "_$PIECE(REC,U,14)_" "_$PIECE(REC,U,15))
+21 ;I $P(REC,U,11)="",$P(REC,U,12)="" D LINE($E(SP,1,40)_$P(RMPODFN,U))
+22 SET RMPORX=$PIECE(REC,U,6)
if RMPORX=""
SET RMPORX="Not on file"
+23 DO LINE($EXTRACT(SP,1,40)_FRSTNM_" "_SURNM)
+24 DO LINE($EXTRACT(SP,1,40)_"Current Home Oxygen Rx#: "_RMPORX)
+25 SET LN=$EXTRACT(SP,1,40)_"Rx Expiration Date: "
+26 SET RMPORXDT=$PIECE(REC,U,4)
+27 IF RMPORXDT=""
SET RMPORXDT="n/a"
+28 IF '$TEST
SET Y=RMPORXDT
XECUTE ^DD("DD")
SET RMPORXDT=Y
+29 DO LINE(LN_RMPORXDT)
DO LINE("")
+30 DO LINE("Dear "_$SELECT($PIECE(REC,U,9)="F":"Ms. ",1:"Mr. ")_SURNM_":")
+31 DO LINE("")
DO LINE("")
+32 ;
+33 ; print letter template
+34 SET I=0
FOR
SET I=$ORDER(^RMPR(665.2,RMPOLTR,1,I))
if 'I
QUIT
DO LINE(^(I,0))
+35 ;
+36 ; Update Correspondence Tracking
+37 ; DO NOT remove patient from list is correspondence update unsuccessful.
+38 SET X=$$FILE^RMPOLETU(RMPODFN,"^TMP($J,""LINE"")",LNCT,RMPOLTR)
+39 IF 'X
WRITE !,"<<< Error"_+X_":"_$PIECE(X,";",2)_" Patient #"_RMPODFN_" ! >>>",*7
QUIT
+40 ;
+41 ; Clear "letter to be sent" field in RMPR(665
DO UPDLTR^RMPOLET0(RMPODFN,"@")
+42 ;
+43 IF IOST["C-"
READ !!,"Press <ENTER> to continue",ANS:DTIME
if '$TEST
QUIT
+44 QUIT
+45 ;
LINE(X) SET LNCT=LNCT+1
SET ^TMP($JOB,"LINE",LNCT,0)=" "_X
+1 WRITE !,?9,X
+2 QUIT
+3 ;
+1 SET HEAD(1)="Department of Veterans Affairs"
SET POS(1)=45-($LENGTH(HEAD(1))\2)
+2 ;name of VAMC
SET HEAD(2)=RMPO("NAME")
SET POS(2)=45-($LENGTH(HEAD(2))\2)
+3 ;street address of VAMC
SET HEAD(3)=RMPO("ADD")
SET POS(3)=45-($LENGTH(HEAD(3))\2)
+4 ;city,state and zip of VAMC
SET HEAD(4)=RMPO("CITY")
SET POS(4)=45-($LENGTH(HEAD(4))\2)
+5 QUIT
+6 ;
EXIT ;Clean up and quit
+1 ;
+2 ;Close printer
+3 DO ^%ZISC
+4 ;
+5 ; clear lock of virtual control record
+6 LOCK -^TMP("RMPO",$JOB,"LETTERPRINT")
+7 ;
+8 ;Kill off variables
+9 KILL ^TMP($JOB),%ZIS,Y,ZTSAVE,ZTRTN,RMPO,ZTDESC,L,LET
+10 QUIT
