RMPOLZB ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
;;3.0;PROSTHETICS;**29,55,159**;Feb 09, 1996;Build 2
;
; ODJ - patch 55 - 1/29/01 - remove hard code 121 mail code and
; replace with extrinsic (AUG-1097-32118)
;
; Input:
;
; JOB - 0: interactive, 1: job
; RMPOLCD - Letter type code
;
; Output: None
;
; Called by:
; EN03^RMPOLT,EN02^RMPOLY
N REC,POS
; if interactive select device
I 'JOB D FULL^VALM1 Q:'$$DEV
; if print queued
I $D(IO("Q")) D Q:'$$QUEUE^RMPOLET1(ZTDESC,ZTRTN,.ZTSAVE) D HOME^%ZIS,EXIT Q
. K ZTSAVE
. S ZTDESC="RMPO : Patient Letter Print",ZTRTN="START^RMPOLZB"
. S (ZTSAVE("RMPOXITE"),ZTSAVE("JOB"),ZTSAVE("RMPOLCD"),ZTSAVE("RMPOSITE"),ZTSAVE("RMPO("),ZTSAVE("^TMP($J,RMPOXITE,"))=""
W !,"Printing...."
;
START ; Print H.O. correspondence for selected letter type
N DATE U IO
S Y=DT X ^DD("DD") S DATE=Y
D HDRL ; initialise header lines
S RMPONAM="" F S RMPONAM=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
. S RMPOLTR=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
. S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
. S REC=^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN) D BODY
D EXIT Q
;
ONE ;print a single patient
;I 'JOB D FULL^VALM1 Q:'$$DEV
;D COMMON("PIKSOM") D ^%ZISC D CLEAN^VALM10,INIT^RMPOLT,RE^VALM4 K DIR,RTN
D PIKSOM Q:$$QUIT I Y="" S VALMBCK="R" Q
S LFNS=Y I 'JOB D FULL^VALM1 Q:'$$DEV
I $D(IO("Q")) D D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 2 D HOME^%ZIS,EXIT Q
. K ZTSAVE
. S ZTDESC="RMPO : Patient Letter Print",ZTRTN="QUED^RMPOLZB"
. S (ZTSAVE("RMPOXITE"),ZTSAVE("JOB"),ZTSAVE("RMPOLCD"))=""
. S ZTSAVE("RMPOSITE")="",ZTSAVE("RMPO(")="",ZTSAVE("^TMP($J,RMPOXITE,")="",ZTSAVE("IO")="",ZTSAVE("LFNS")=""
W !!,"Printing...."
;
QUED N DATE S Y=DT X ^DD("DD") S DATE=Y D HDRL
U IO 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($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
.. S RMPOLTR=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
.. S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
.. S CNT=CNT+1
.. S:CNT=LFN ^TMP($J,RMPOXITE,"LTR",RMPONAM)=RMPODFN
S RMPONAM="" F S RMPONAM=$O(^TMP($J,RMPOXITE,"LTR",RMPONAM)) Q:RMPONAM="" D SINGLE
K LFNS,LFN,ZI,RTN,DIR,RMLET
D ^%ZISC D CLEAN^VALM10,INIT^RMPOLT,RE^VALM4
S VALMBCK="R" D EXIT Q
;
SINGLE S RMPOLTR=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
S REC=^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN)
D BODY Q
BODY ; Set up array for filing and print letter
N I,LN,LNCT,SP,HDR,X,Y,NAME,SURNM,FRSTNM
S $P(SP," ",80)=" ",LNCT=0
;
; Print text or blank lines in header
S HDR=^TMP($J,RMPOXITE,"HEADER",RMPOLTR)
I 'HDR F I=1:1:9 D LINE("")
I HDR D PHDR
;
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^RMPOLZU(RMPODFN,"^TMP("_$J_","_RMPOXITE_",""LINE"")",RMPOLTR)
I +X D Q ; quit if error
. W !!!,"<<< Error"_+X_":"_$P(X,";",2)_" Patient #"_RMPODFN_" ! >>>",*7
D UPDLTR^RMPOLZA(RMPODFN,"@") ; Clear "letter to be sent" field in RMPR(665
;
K ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)
K ^TMP($J,RMPOXITE,"LINE")
K ^TMP($J,RMPOXITE,RMPODFN)
I RMPOLCD="A" S $P(^RMPR(665,RMPODFN,"RMPOA"),U,9)=DT,$P(^("RMPOA"),U,10)="P"
I RMPOLCD="B" S $P(^RMPR(665,RMPODFN,"RMPOA"),U,11)=DT,$P(^("RMPOA"),U,12)="P"
I RMPOLCD="C" S $P(^RMPR(665,RMPODFN,"RMPOA"),U,13)=DT,$P(^("RMPOA"),U,14)="P"
W @IOF
Q
;
LINE(X) S LNCT=LNCT+1,^TMP($J,RMPOXITE,"LINE",LNCT,0)=" "_X
W !,?9,X
Q
;
HDRL ; Define header lines
S HEAD(1)="Department of Veterans Affairs",POS(1)=40-($L(HEAD(1))\2)
S HEAD(2)=RMPO("NAME"),POS(2)=40-($L(HEAD(2))\2) ;name of VAMC
S HEAD(3)=RMPO("ADD"),POS(3)=40-($L(HEAD(3))\2) ;street address of VAMC
S HEAD(4)=RMPO("CITY"),POS(4)=40-($L(HEAD(4))\2) ;city,state and zip of VAMC
Q
;
PHDR ; Print header
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("")
Q
;
DEV() ; Get device. Cannot be home device
N DEV,POP
;F S DEV=0,%ZIS="Q" D ^%ZIS Q:$G(POP)=1 S DEV=1 Q:IO(0)'=IO W "Cannot Select Home Device"
DAGAIN S DEV=0,%ZIS="MQ" K IOP D ^%ZIS Q:$G(POP)=1 DEV
I IO(0)=IO!(IOST["SLAVE") D ^%ZISC,HOME^%ZIS W "Cannot Select Home or Slave Device" G DAGAIN
S DEV=1 Q DEV
EXIT ;Clean up and quit
; if interactive close printer
D:'JOB ^%ZISC
;Kill off variables
K %ZIS,Y,ZTSAVE,ZTDESC,ZTRTN,HEAD
Q
QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT
Q
COMMON(PIKRTN) ;
D FULL^VALM1
S RTN="SINGLE^RMPOLZB"
D @PIKRTN Q:$$QUIT I Y="" S VALMBCK="R" Q
S LFNS=Y
I 'JOB Q:'$$DEV
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[HRMPOLZB 6039 printed Sep 23, 2025@20:07:19 Page 2
RMPOLZB ;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/29/01 - remove hard code 121 mail code and
+4 ; replace with extrinsic (AUG-1097-32118)
+5 ;
+6 ; Input:
+7 ;
+8 ; JOB - 0: interactive, 1: job
+9 ; RMPOLCD - Letter type code
+10 ;
+11 ; Output: None
+12 ;
+13 ; Called by:
+14 ; EN03^RMPOLT,EN02^RMPOLY
+15 NEW REC,POS
+16 ; if interactive select device
+17 IF 'JOB
DO FULL^VALM1
if '$$DEV
QUIT
+18 ; if print queued
+19 IF $DATA(IO("Q"))
Begin DoDot:1
+20 KILL ZTSAVE
+21 SET ZTDESC="RMPO : Patient Letter Print"
SET ZTRTN="START^RMPOLZB"
+22 SET (ZTSAVE("RMPOXITE"),ZTSAVE("JOB"),ZTSAVE("RMPOLCD"),ZTSAVE("RMPOSITE"),ZTSAVE("RMPO("),ZTSAVE("^TMP($J,RMPOXITE,"))=""
End DoDot:1
if '$$QUEUE^RMPOLET1(ZTDESC,ZTRTN,.ZTSAVE)
QUIT
DO HOME^%ZIS
DO EXIT
QUIT
+23 WRITE !,"Printing...."
+24 ;
START ; Print H.O. correspondence for selected letter type
+1 NEW DATE
USE IO
+2 SET Y=DT
XECUTE ^DD("DD")
SET DATE=Y
+3 ; initialise header lines
DO HDRL
+4 SET RMPONAM=""
FOR
SET RMPONAM=$ORDER(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM))
if RMPONAM=""
QUIT
Begin DoDot:1
+5 SET RMPOLTR=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
+6 SET RMPODFN=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
+7 SET REC=^TMP($JOB,RMPOXITE,"RMPODEMO",RMPODFN)
DO BODY
End DoDot:1
+8 DO EXIT
QUIT
+9 ;
ONE ;print a single patient
+1 ;I 'JOB D FULL^VALM1 Q:'$$DEV
+2 ;D COMMON("PIKSOM") D ^%ZISC D CLEAN^VALM10,INIT^RMPOLT,RE^VALM4 K DIR,RTN
+3 DO PIKSOM
if $$QUIT
QUIT
IF Y=""
SET VALMBCK="R"
QUIT
+4 SET LFNS=Y
IF 'JOB
DO FULL^VALM1
if '$$DEV
QUIT
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 KILL ZTSAVE
+7 SET ZTDESC="RMPO : Patient Letter Print"
SET ZTRTN="QUED^RMPOLZB"
+8 SET (ZTSAVE("RMPOXITE"),ZTSAVE("JOB"),ZTSAVE("RMPOLCD"))=""
+9 SET ZTSAVE("RMPOSITE")=""
SET ZTSAVE("RMPO(")=""
SET ZTSAVE("^TMP($J,RMPOXITE,")=""
SET ZTSAVE("IO")=""
SET ZTSAVE("LFNS")=""
End DoDot:1
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 2
DO HOME^%ZIS
DO EXIT
QUIT
+10 WRITE !!,"Printing...."
+11 ;
QUED NEW DATE
SET Y=DT
XECUTE ^DD("DD")
SET DATE=Y
DO HDRL
+1 USE IO
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($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM))
if RMPONAM=""
QUIT
Begin DoDot:2
+4 SET RMPOLTR=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
+5 SET RMPODFN=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
+6 SET CNT=CNT+1
+7 if CNT=LFN
SET ^TMP($JOB,RMPOXITE,"LTR",RMPONAM)=RMPODFN
End DoDot:2
End DoDot:1
+8 SET RMPONAM=""
FOR
SET RMPONAM=$ORDER(^TMP($JOB,RMPOXITE,"LTR",RMPONAM))
if RMPONAM=""
QUIT
DO SINGLE
+9 KILL LFNS,LFN,ZI,RTN,DIR,RMLET
+10 DO ^%ZISC
DO CLEAN^VALM10
DO INIT^RMPOLT
DO RE^VALM4
+11 SET VALMBCK="R"
DO EXIT
QUIT
+12 ;
SINGLE SET RMPOLTR=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
+1 SET RMPODFN=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
+2 SET REC=^TMP($JOB,RMPOXITE,"RMPODEMO",RMPODFN)
+3 DO BODY
QUIT
BODY ; Set up array for filing and print letter
+1 NEW I,LN,LNCT,SP,HDR,X,Y,NAME,SURNM,FRSTNM
+2 SET $PIECE(SP," ",80)=" "
SET LNCT=0
+3 ;
+4 ; Print text or blank lines in header
+5 SET HDR=^TMP($JOB,RMPOXITE,"HEADER",RMPOLTR)
+6 IF 'HDR
FOR I=1:1:9
DO LINE("")
+7 IF HDR
DO PHDR
+8 ;
+9 DO LINE(DATE)
DO LINE("")
+10 SET NAME=$PIECE(REC,U)
SET SURNM=$PIECE(NAME,",",2)
SET FRSTNM=$PIECE(NAME,",")
+11 SET LN=$EXTRACT(FRSTNM_" "_SURNM_SP,1,40)_"In Reply Refer To: "_RMPO("NAME")_"/"_$$ROU^RMPRUTIL(RMPOXITE)
+12 DO LINE(LN)
+13 SET LN=$PIECE(REC,U,10)
SET LN=$EXTRACT(LN_SP,1,40)
+14 DO LINE(LN)
+15 SET LN=$PIECE(REC,U,11)
IF LN]""
SET LN=$EXTRACT(LN_SP,1,40)
DO LINE(LN)
+16 IF $PIECE(REC,U,12)]""
DO LINE($PIECE(REC,U,12))
+17 ;
+18 ; City, State, Zip
+19 DO LINE($PIECE(REC,U,13)_", "_$PIECE(REC,U,14)_" "_$PIECE(REC,U,15))
+20 ;I $P(REC,U,11)="",$P(REC,U,12)="" D LINE($E(SP,1,40)_$P(RMPODFN,U))
+21 SET RMPORX=$PIECE(REC,U,6)
if RMPORX=""
SET RMPORX="Not on file"
+22 DO LINE($EXTRACT(SP,1,40)_FRSTNM_" "_SURNM)
+23 DO LINE($EXTRACT(SP,1,40)_"Current Home Oxygen Rx#: "_RMPORX)
+24 SET LN=$EXTRACT(SP,1,40)_"Rx Expiration Date: "
+25 SET RMPORXDT=$PIECE(REC,U,4)
+26 IF RMPORXDT=""
SET RMPORXDT="n/a"
+27 IF '$TEST
SET Y=RMPORXDT
XECUTE ^DD("DD")
SET RMPORXDT=Y
+28 DO LINE(LN_RMPORXDT)
DO LINE("")
+29 DO LINE("Dear "_$SELECT($PIECE(REC,U,9)="F":"Ms. ",1:"Mr. ")_SURNM_":")
+30 DO LINE("")
DO LINE("")
+31 ;
+32 ; print letter template
+33 SET I=0
FOR
SET I=$ORDER(^RMPR(665.2,RMPOLTR,1,I))
if 'I
QUIT
DO LINE(^(I,0))
+34 ;
+35 ; Update Correspondence Tracking
+36 ; DO NOT remove patient from list is correspondence update unsuccessful.
+37 SET X=$$FILE^RMPOLZU(RMPODFN,"^TMP("_$JOB_","_RMPOXITE_",""LINE"")",RMPOLTR)
+38 ; quit if error
IF +X
Begin DoDot:1
+39 WRITE !!!,"<<< Error"_+X_":"_$PIECE(X,";",2)_" Patient #"_RMPODFN_" ! >>>",*7
End DoDot:1
QUIT
+40 ; Clear "letter to be sent" field in RMPR(665
DO UPDLTR^RMPOLZA(RMPODFN,"@")
+41 ;
+42 KILL ^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)
+43 KILL ^TMP($JOB,RMPOXITE,"LINE")
+44 KILL ^TMP($JOB,RMPOXITE,RMPODFN)
+45 IF RMPOLCD="A"
SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,9)=DT
SET $PIECE(^("RMPOA"),U,10)="P"
+46 IF RMPOLCD="B"
SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,11)=DT
SET $PIECE(^("RMPOA"),U,12)="P"
+47 IF RMPOLCD="C"
SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,13)=DT
SET $PIECE(^("RMPOA"),U,14)="P"
+48 WRITE @IOF
+49 QUIT
+50 ;
LINE(X) SET LNCT=LNCT+1
SET ^TMP($JOB,RMPOXITE,"LINE",LNCT,0)=" "_X
+1 WRITE !,?9,X
+2 QUIT
+3 ;
HDRL ; Define header lines
+1 SET HEAD(1)="Department of Veterans Affairs"
SET POS(1)=40-($LENGTH(HEAD(1))\2)
+2 ;name of VAMC
SET HEAD(2)=RMPO("NAME")
SET POS(2)=40-($LENGTH(HEAD(2))\2)
+3 ;street address of VAMC
SET HEAD(3)=RMPO("ADD")
SET POS(3)=40-($LENGTH(HEAD(3))\2)
+4 ;city,state and zip of VAMC
SET HEAD(4)=RMPO("CITY")
SET POS(4)=40-($LENGTH(HEAD(4))\2)
+5 QUIT
+6 ;
PHDR ; Print header
+1 FOR I=1:1:5
DO LINE("")
+2 DO LINE($EXTRACT(SP,1,POS(1))_HEAD(1))
DO LINE($EXTRACT(SP,1,POS(2))_HEAD(2))
+3 DO LINE($EXTRACT(SP,1,POS(3))_HEAD(3))
DO LINE($EXTRACT(SP,1,POS(4))_HEAD(4))
+4 FOR I=1:1:4
DO LINE("")
+5 QUIT
+6 ;
DEV() ; Get device. Cannot be home device
+1 NEW DEV,POP
+2 ;F S DEV=0,%ZIS="Q" D ^%ZIS Q:$G(POP)=1 S DEV=1 Q:IO(0)'=IO W "Cannot Select Home Device"
DAGAIN SET DEV=0
SET %ZIS="MQ"
KILL IOP
DO ^%ZIS
if $GET(POP)=1
QUIT DEV
+1 IF IO(0)=IO!(IOST["SLAVE")
DO ^%ZISC
DO HOME^%ZIS
WRITE "Cannot Select Home or Slave Device"
GOTO DAGAIN
+2 SET DEV=1
QUIT DEV
EXIT ;Clean up and quit
+1 ; if interactive close printer
+2 if 'JOB
DO ^%ZISC
+3 ;Kill off variables
+4 KILL %ZIS,Y,ZTSAVE,ZTDESC,ZTRTN,HEAD
+5 QUIT
QUIT() SET QUIT=$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT QUIT
+1 QUIT
COMMON(PIKRTN) ;
+1 DO FULL^VALM1
+2 SET RTN="SINGLE^RMPOLZB"
+3 DO @PIKRTN
if $$QUIT
QUIT
IF Y=""
SET VALMBCK="R"
QUIT
+4 SET LFNS=Y
+5 IF 'JOB
if '$$DEV
QUIT
+6 QUIT
+7 ;
PIKSOM ; ALLOW SELECTION FROM DISPLAYED ENTRIES
+1 KILL DIR
SET DIR(0)="LO^"_VALMBG_":"_VALMLST
DO ^DIR
+2 QUIT
