Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPOLZB

RMPOLZB.m

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