RMPOLET0.m

RMPOLET0 ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98

 ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996

 ;

START ;

 N LST,TXT,TRXS,LTRX

 ;

 Q:'$$SITE

 S LST=$$LST I 'LST G EXIT

 D:LST=2 PURGE

 D LTRCR  ; generate letter code to prosthetics letter IEN xref

 K ^TMP($J)

 ; build patient list work file from current list (GENOLST) or

 ; generate new patient letter list work file (GENLST)

 D GENLST:LST'=1,GENOLST(0):LST=1

 ;

 D SELECT^RMPOLETA

 ;       

 L -^TMP("RMPO","LETTERPRINT")

 G EXIT

 Q

 ;

SITE() ;find the site if the site is not multidivisional

 ;

 ;Initialize, if necessary

 D HOSITE^RMPOUTL0  ; output RMPO("STA") - station number

 W @IOF K ^TMP($J)

 I '$G(RMPOREC) W !!,*7,"You must choose a Home Oxygen Site.",!! Q 0

 S RMPOXITE=RMPOREC

 Q 1

 ;

LST() ;Check Letters List       

 N LST

 ;

 S LST=0

 I $D(^RMPR(665,"ALTR")) D  ; if already a patient list in existance exit

 . S %=2

 . W !,"A list of patient letters to be printed already exists",!

 . W !,"Do you wish to reprint the current list" D YN^DICN

 . I %=1 S LST=1

 . E  S %=2 W !,"Do you wish to generate a new list which will discard any edits" D YN^DICN S:%=1 LST=2

 E  S LST=3

 I LST S TXT=$S(LST=1:"work with current",LST=2:"regenerate",1:"generate new") S:'$$LOCK(TXT) LST=0

 Q LST

 ;

LTRCR ; build local array CROSS REFERENCE of H.O. letter Code to Letter

 ;

 ; ! assumes a letter code can have many letter templates but one    !

 ; ! template is of a particluar type e.g. a 30,60,90 & 120 Day H.O. !

 ; ! letters are all of type "B" : prescription pending expiry.      !

 ;

 ; O/P : LTRX("A",Letter Code,Prosthetics Letter IEN)

 ;       LTRX("B",Prosthetics Letter IEN)=Letter Code

 ;  

 N LTRIEN,REC

 ;

 S LTRIEN=0 F  S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN)) Q:LTRIEN<1  D

 . S REC=^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0),RMPOLTR=$P(REC,U),RMPOLCD=$P(REC,U,2)

 . I RMPOLCD'="",(RMPOLTR'="") S LTRX("A",RMPOLCD,RMPOLTR)="",LTRX("B",RMPOLTR)=RMPOLCD

 Q

 ;

GENLST ; generate patient letter list

 N REC,ADT,IADT

 ;

 S Z=""

 F  S Z=$O(^RMPR(665,"AHO",Z)) Q:Z=""  D

 .S RMPODFN=0

 . F  S RMPODFN=$O(^RMPR(665,"AHO",Z,RMPODFN)) Q:RMPODFN=""  D

 .. N TRXS

 .. ;

 .. Q:$P(^RMPR(665,RMPODFN,"RMPOA"),U,7)'=RMPOXITE  ; ignore patient from another station

 .. ;Get patient demographic data

 .. S DFN=RMPODFN K VADM D DEM^VADPT

 .. ;Do not collect patient if expired

 .. Q:$G(VADM(6))

 .. S REC=$G(^RMPR(665,RMPODFN,"RMPOA")) Q:REC=""  ; not a H.O. patient

 .. S ADT=$P(REC,U,2),IADT=$P(REC,U,3)  ; get Activation & InActivation DaTes

 .. Q:ADT=""  ; quit if not an active H.O. patient

 .. D FNDTRX  ; build Xref of transactions (TRX) to letter type for this patient

 .. S RMPORX=$P($G(^RMPR(665,RMPODFN,"RMPOB",0)),U,3)  ; get active prescription

 .. ; check if new patient or inactivation letter required

 .. Q:$$NACT

 .. ; get active patient prescription and evaluate letter requirement

 .. Q:'$D(^RMPR(665,RMPODFN,"RMPOB",0))

 .. Q:RMPORX<1  ; quit if no active prescription    

 .. D EXPR

 Q

 ;

GENOLST(BTYP) ; Generate work file from current patient letter list

 N LTRIEN

 ;

 S RMPOLTR=0 F  S RMPOLTR=$O(^RMPR(665,"ALTR",RMPOLTR)) Q:RMPOLTR=""  D

 . S RMPODFN=0 F  S RMPODFN=$O(^RMPR(665,"ALTR",RMPOLTR,RMPODFN)) Q:RMPODFN=""  D

 . . S STA=$P(^RMPR(665,RMPODFN,0),U,2) Q:STA'=RMPO("STA")  ; ignore patients from another station

 . . S REC=$G(^RMPR(665,RMPODFN,"RMPOA")),ADT=$P(REC,U,2),IADT=$P(REC,U,3)

 . . S RMPORX=$P($G(^RMPR(665,RMPODFN,"RMPOB",0)),U,3)

 . . S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET","B",RMPOLTR,0))

 . . S RMPOLCD=$P(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0),U,2)

 . . D EXTRCT(BTYP) S ^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR

 Q

 ;

NACT() ; check if new patient letter or inactivation letter is required

 N FND,LST,DTE

 ;

 F RMPOLCD="A","C" D  Q:LST  ; Quit if letter placed on list

 . S (LST,FND)=0,RMPOLTR="",DTE=$S(RMPOLCD="A":ADT,1:IADT)

 . F  S RMPOLTR=$O(LTRX("A",RMPOLCD,RMPOLTR)) Q:RMPOLTR=""  D  Q:FND  Q:LST  ; for each VALID H.O. letter of given Letter Code

 . . I $O(TRXS(RMPOLCD,RMPOLTR,(DTE-1))) S FND=1 Q  ; quit if letter printed on or after de/activation

 . . D EXTRCT(0) S ^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR S LST=1 ; add person to list as requiring appropriate letter

 Q FND

 ;

EXPR ; check if prescription is pending expiry

 N REC,LTR,EXP

 ;

 S RMPOLCD="B",REC=^RMPR(665,RMPODFN,"RMPOB",RMPORX,0)

 S RMPOEXP=$P(REC,U,3) Q:RMPOEXP<DT  ; quit if prescription already expired

 S X1=RMPOEXP,X2=DT D ^%DTC S RMPODAYS=X-1

 S RMPODAYS=$O(^RMPR(669.9,"ALTDY",RMPODAYS))

 Q:RMPODAYS=""  ;no letter for this expiry pending period (zero to n days)

 Q:'$D(^RMPR(669.9,"ALTDY",RMPODAYS,RMPOXITE))  ; ignore letters defined for other sites

 S LTR=$O(^RMPR(669.9,"ALTDY",RMPODAYS,RMPOXITE,0)) ;get FIRST letter assoc. with this expiry period

 S RMPOLTR=$P(^RMPR(669.9,RMPOXITE,"RMPOLET",LTR,0),U) ; get H.O. letter

 Q:$D(TRXS(RMPOLCD,RMPOLTR))  ; H.O. letter for this expiry period has been sent

 D EXTRCT(0) S ^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR

 Q

 ;

EXTRCT(BTYP)  ;

 ;

 ; I/P : Build TYPe - 0=List, 1=Letter 

 ;

 ; quit if already generated demographic details for a patient

 Q:$D(^TMP($J,"RMPODEMO",RMPODFN))

 ;

 N INAME,INFO

 ;

 S INAME="",DFN=RMPODFN

 K VADM D DEM^VADPT,ADD^VADPT

 S NAME=VADM(1)_U_RMPODFN

 ; 

 ; if patient has an active prescription get date entered & expiry date else set dates = NULL

 I RMPORX'="" S RMPOEXP=$P(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0),U,3),RMPORXDT=$P(^(0),U)

 E  S (RMPOEXP,RMPORXDT)=""

 ;

 ; get primary item

 S INAME="",RMPOITEM=$O(^RMPR(665,"AC","Y",RMPODFN,0))

 I RMPOITEM'="" D

 . S RMPOITEM=$P(^RMPR(665,RMPODFN,"RMPOC",RMPOITEM,0),U),RMPOITEM=$P(^RMPR(661,RMPOITEM,0),U)

 . S INAME=$P(^PRC(441,RMPOITEM,0),U,2)

 ;

 ;set the ^TMP($J,"RMPODEMO" global with patient demographics

 S INFO=VADM(1)_U_$P(VADM(2),U,2)_U_ADT_U_RMPOEXP_U_INAME

 S:BTYP=1 INFO=INFO_U_RMPORX_U_RMPORXDT_U_DT_U_$P(VADM(5),U)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)_U_VAPA(4)_U_$P(VAPA(5),U,2)_U_VAPA(6)

 S ^TMP($J,"RMPODEMO",RMPODFN)=INFO

 Q

FNDTRX  ; find letter TRX & hold in local array

 ;

 ; I/P : NONE

 ; O/P : TRXS(H.O. Letter Code,Prosthetics Letter,Transaction Printed Date)

 ;

 N TRX

 ;

 S TRX=0 F  S TRX=$O(^RMPR(665.4,"B",RMPODFN,TRX)) Q:TRX=""  D

 . 

 . Q:$P(^RMPR(665.4,TRX,0),U,6)'=RMPO("STA")  ; ignore letters from a different station

 . S RMPOLTR=$P(^RMPR(665.4,TRX,0),U,2) Q:'$D(LTRX("B",RMPOLTR))  ; ignore if not a H.O. letter transaction

 . S RMPOLCD=LTRX("B",RMPOLTR)  ; get H.O. Letter Code given H.O. Letter #

 . S TRXS(RMPOLCD,RMPOLTR,$P(^RMPR(665.4,TRX,0),U,3))=""  ; create local array

 Q

 ;

PURGE ; Purge current patient letter list

 S RMPOLTR=0 F  S RMPOLTR=$O(^RMPR(665,"ALTR",RMPOLTR)) Q:RMPOLTR=""  D

 . S RMPODFN=0 F  S RMPODFN=$O(^RMPR(665,"ALTR",RMPOLTR,RMPODFN)) Q:RMPODFN=""  D UPDLTR(RMPODFN,"@")

 Q

 ;

LOCK(TXT)  ;

 ; lock virtual list record 

 L +^TMP("RMPO","LETTERPRINT"):0 I '$T W !,"Cannot "_TXT_" list as list edit or printing is in progress" Q 0

 Q 1

 ;

UPDLTR(DA,VAL)  ; Update 'Letter to be sent' in Prosthetics Patient File

 ;

 ; I/P :

 ;     VAL - value to be inserted into field

 ;

 S DR="19.13///"_VAL,DIE="^RMPR(665," D ^DIE

 Q

 ;

EXIT G EXIT^RMPOLETA

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPOLET0   7319     printed  Feb 18, 2025@23:57:23                                                                                                                                                                                                    Page 2

RMPOLET0  ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98

 +1       ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996

 +2       ;

START     ;

 +1        NEW LST,TXT,TRXS,LTRX

 +2       ;

 +3        if '$$SITE

               QUIT 

 +4        SET LST=$$LST

           IF 'LST

               GOTO EXIT

 +5        if LST=2

               DO PURGE

 +6       ; generate letter code to prosthetics letter IEN xref

           DO LTRCR

 +7        KILL ^TMP($JOB)

 +8       ; build patient list work file from current list (GENOLST) or

 +9       ; generate new patient letter list work file (GENLST)

 +10       if LST'=1

               DO GENLST

           if LST=1

               DO GENOLST(0)

 +11      ;

 +12       DO SELECT^RMPOLETA

 +13      ;       

 +14       LOCK -^TMP("RMPO","LETTERPRINT")

 +15       GOTO EXIT

 +16       QUIT 

 +17      ;

SITE()    ;find the site if the site is not multidivisional

 +1       ;

 +2       ;Initialize, if necessary

 +3       ; output RMPO("STA") - station number

           DO HOSITE^RMPOUTL0

 +4        WRITE @IOF

           KILL ^TMP($JOB)

 +5        IF '$GET(RMPOREC)

               WRITE !!,*7,"You must choose a Home Oxygen Site.",!!

               QUIT 0

 +6        SET RMPOXITE=RMPOREC

 +7        QUIT 1

 +8       ;

LST()     ;Check Letters List       

 +1        NEW LST

 +2       ;

 +3        SET LST=0

 +4       ; if already a patient list in existance exit

           IF $DATA(^RMPR(665,"ALTR"))

               Begin DoDot:1

 +5                SET %=2

 +6                WRITE !,"A list of patient letters to be printed already exists",!

 +7                WRITE !,"Do you wish to reprint the current list"

                   DO YN^DICN

 +8                IF %=1

                       SET LST=1

 +9               IF '$TEST

                       SET %=2

                       WRITE !,"Do you wish to generate a new list which will discard any edits"

                       DO YN^DICN

                       if %=1

                           SET LST=2

               End DoDot:1

 +10      IF '$TEST

               SET LST=3

 +11       IF LST

               SET TXT=$SELECT(LST=1:"work with current",LST=2:"regenerate",1:"generate new")

               if '$$LOCK(TXT)

                   SET LST=0

 +12       QUIT LST

 +13      ;

LTRCR     ; build local array CROSS REFERENCE of H.O. letter Code to Letter

 +1       ;

 +2       ; ! assumes a letter code can have many letter templates but one    !

 +3       ; ! template is of a particluar type e.g. a 30,60,90 & 120 Day H.O. !

 +4       ; ! letters are all of type "B" : prescription pending expiry.      !

 +5       ;

 +6       ; O/P : LTRX("A",Letter Code,Prosthetics Letter IEN)

 +7       ;       LTRX("B",Prosthetics Letter IEN)=Letter Code

 +8       ;  

 +9        NEW LTRIEN,REC

 +10      ;

 +11       SET LTRIEN=0

           FOR 

               SET LTRIEN=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN))

               if LTRIEN<1

                   QUIT 

               Begin DoDot:1

 +12               SET REC=^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0)

                   SET RMPOLTR=$PIECE(REC,U)

                   SET RMPOLCD=$PIECE(REC,U,2)

 +13               IF RMPOLCD'=""

                       IF (RMPOLTR'="")

                           SET LTRX("A",RMPOLCD,RMPOLTR)=""

                           SET LTRX("B",RMPOLTR)=RMPOLCD

               End DoDot:1

 +14       QUIT 

 +15      ;

GENLST    ; generate patient letter list

 +1        NEW REC,ADT,IADT

 +2       ;

 +3        SET Z=""

 +4        FOR 

               SET Z=$ORDER(^RMPR(665,"AHO",Z))

               if Z=""

                   QUIT 

               Begin DoDot:1

 +5                SET RMPODFN=0

 +6                FOR 

                       SET RMPODFN=$ORDER(^RMPR(665,"AHO",Z,RMPODFN))

                       if RMPODFN=""

                           QUIT 

                       Begin DoDot:2

 +7                        NEW TRXS

 +8       ;

 +9       ; ignore patient from another station

                           if $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,7)'=RMPOXITE

                               QUIT 

 +10      ;Get patient demographic data

 +11                       SET DFN=RMPODFN

                           KILL VADM

                           DO DEM^VADPT

 +12      ;Do not collect patient if expired

 +13                       if $GET(VADM(6))

                               QUIT 

 +14      ; not a H.O. patient

                           SET REC=$GET(^RMPR(665,RMPODFN,"RMPOA"))

                           if REC=""

                               QUIT 

 +15      ; get Activation & InActivation DaTes

                           SET ADT=$PIECE(REC,U,2)

                           SET IADT=$PIECE(REC,U,3)

 +16      ; quit if not an active H.O. patient

                           if ADT=""

                               QUIT 

 +17      ; build Xref of transactions (TRX) to letter type for this patient

                           DO FNDTRX

 +18      ; get active prescription

                           SET RMPORX=$PIECE($GET(^RMPR(665,RMPODFN,"RMPOB",0)),U,3)

 +19      ; check if new patient or inactivation letter required

 +20                       if $$NACT

                               QUIT 

 +21      ; get active patient prescription and evaluate letter requirement

 +22                       if '$DATA(^RMPR(665,RMPODFN,"RMPOB",0))

                               QUIT 

 +23      ; quit if no active prescription    

                           if RMPORX<1

                               QUIT 

 +24                       DO EXPR

                       End DoDot:2

               End DoDot:1

 +25       QUIT 

 +26      ;

GENOLST(BTYP) ; Generate work file from current patient letter list

 +1        NEW LTRIEN

 +2       ;

 +3        SET RMPOLTR=0

           FOR 

               SET RMPOLTR=$ORDER(^RMPR(665,"ALTR",RMPOLTR))

               if RMPOLTR=""

                   QUIT 

               Begin DoDot:1

 +4                SET RMPODFN=0

                   FOR 

                       SET RMPODFN=$ORDER(^RMPR(665,"ALTR",RMPOLTR,RMPODFN))

                       if RMPODFN=""

                           QUIT 

                       Begin DoDot:2

 +5       ; ignore patients from another station

                           SET STA=$PIECE(^RMPR(665,RMPODFN,0),U,2)

                           if STA'=RMPO("STA")

                               QUIT 

 +6                        SET REC=$GET(^RMPR(665,RMPODFN,"RMPOA"))

                           SET ADT=$PIECE(REC,U,2)

                           SET IADT=$PIECE(REC,U,3)

 +7                        SET RMPORX=$PIECE($GET(^RMPR(665,RMPODFN,"RMPOB",0)),U,3)

 +8                        SET LTRIEN=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOLET","B",RMPOLTR,0))

 +9                        SET RMPOLCD=$PIECE(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0),U,2)

 +10                       DO EXTRCT(BTYP)

                           SET ^TMP($JOB,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR

                       End DoDot:2

               End DoDot:1

 +11       QUIT 

 +12      ;

NACT()    ; check if new patient letter or inactivation letter is required

 +1        NEW FND,LST,DTE

 +2       ;

 +3       ; Quit if letter placed on list

           FOR RMPOLCD="A","C"

               Begin DoDot:1

 +4                SET (LST,FND)=0

                   SET RMPOLTR=""

                   SET DTE=$SELECT(RMPOLCD="A":ADT,1:IADT)

 +5       ; for each VALID H.O. letter of given Letter Code

                   FOR 

                       SET RMPOLTR=$ORDER(LTRX("A",RMPOLCD,RMPOLTR))

                       if RMPOLTR=""

                           QUIT 

                       Begin DoDot:2

 +6       ; quit if letter printed on or after de/activation

                           IF $ORDER(TRXS(RMPOLCD,RMPOLTR,(DTE-1)))

                               SET FND=1

                               QUIT 

 +7       ; add person to list as requiring appropriate letter

                           DO EXTRCT(0)

                           SET ^TMP($JOB,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR

                           SET LST=1

                       End DoDot:2

                       if FND

                           QUIT 

                       if LST

                           QUIT 

               End DoDot:1

               if LST

                   QUIT 

 +8        QUIT FND

 +9       ;

EXPR      ; check if prescription is pending expiry

 +1        NEW REC,LTR,EXP

 +2       ;

 +3        SET RMPOLCD="B"

           SET REC=^RMPR(665,RMPODFN,"RMPOB",RMPORX,0)

 +4       ; quit if prescription already expired

           SET RMPOEXP=$PIECE(REC,U,3)

           if RMPOEXP<DT

               QUIT 

 +5        SET X1=RMPOEXP

           SET X2=DT

           DO ^%DTC

           SET RMPODAYS=X-1

 +6        SET RMPODAYS=$ORDER(^RMPR(669.9,"ALTDY",RMPODAYS))

 +7       ;no letter for this expiry pending period (zero to n days)

           if RMPODAYS=""

               QUIT 

 +8       ; ignore letters defined for other sites

           if '$DATA(^RMPR(669.9,"ALTDY",RMPODAYS,RMPOXITE))

               QUIT 

 +9       ;get FIRST letter assoc. with this expiry period

           SET LTR=$ORDER(^RMPR(669.9,"ALTDY",RMPODAYS,RMPOXITE,0))

 +10      ; get H.O. letter

           SET RMPOLTR=$PIECE(^RMPR(669.9,RMPOXITE,"RMPOLET",LTR,0),U)

 +11      ; H.O. letter for this expiry period has been sent

           if $DATA(TRXS(RMPOLCD,RMPOLTR))

               QUIT 

 +12       DO EXTRCT(0)

           SET ^TMP($JOB,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR

 +13       QUIT 

 +14      ;

EXTRCT(BTYP) ;

 +1       ;

 +2       ; I/P : Build TYPe - 0=List, 1=Letter 

 +3       ;

 +4       ; quit if already generated demographic details for a patient

 +5        if $DATA(^TMP($JOB,"RMPODEMO",RMPODFN))

               QUIT 

 +6       ;

 +7        NEW INAME,INFO

 +8       ;

 +9        SET INAME=""

           SET DFN=RMPODFN

 +10       KILL VADM

           DO DEM^VADPT

           DO ADD^VADPT

 +11       SET NAME=VADM(1)_U_RMPODFN

 +12      ; 

 +13      ; if patient has an active prescription get date entered & expiry date else set dates = NULL

 +14       IF RMPORX'=""

               SET RMPOEXP=$PIECE(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0),U,3)

               SET RMPORXDT=$PIECE(^(0),U)

 +15      IF '$TEST

               SET (RMPOEXP,RMPORXDT)=""

 +16      ;

 +17      ; get primary item

 +18       SET INAME=""

           SET RMPOITEM=$ORDER(^RMPR(665,"AC","Y",RMPODFN,0))

 +19       IF RMPOITEM'=""

               Begin DoDot:1

 +20               SET RMPOITEM=$PIECE(^RMPR(665,RMPODFN,"RMPOC",RMPOITEM,0),U)

                   SET RMPOITEM=$PIECE(^RMPR(661,RMPOITEM,0),U)

 +21               SET INAME=$PIECE(^PRC(441,RMPOITEM,0),U,2)

               End DoDot:1

 +22      ;

 +23      ;set the ^TMP($J,"RMPODEMO" global with patient demographics

 +24       SET INFO=VADM(1)_U_$PIECE(VADM(2),U,2)_U_ADT_U_RMPOEXP_U_INAME

 +25       if BTYP=1

               SET INFO=INFO_U_RMPORX_U_RMPORXDT_U_DT_U_$PIECE(VADM(5),U)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)_U_VAPA(4)_U_$PIECE(VAPA(5),U,2)_U_VAPA(6)

 +26       SET ^TMP($JOB,"RMPODEMO",RMPODFN)=INFO

 +27       QUIT 

FNDTRX    ; find letter TRX & hold in local array

 +1       ;

 +2       ; I/P : NONE

 +3       ; O/P : TRXS(H.O. Letter Code,Prosthetics Letter,Transaction Printed Date)

 +4       ;

 +5        NEW TRX

 +6       ;

 +7        SET TRX=0

           FOR 

               SET TRX=$ORDER(^RMPR(665.4,"B",RMPODFN,TRX))

               if TRX=""

                   QUIT 

               Begin DoDot:1

 +8  +9   ; ignore letters from a different station

                   if $PIECE(^RMPR(665.4,TRX,0),U,6)'=RMPO("STA")

                       QUIT 

 +10      ; ignore if not a H.O. letter transaction

                   SET RMPOLTR=$PIECE(^RMPR(665.4,TRX,0),U,2)

                   if '$DATA(LTRX("B",RMPOLTR))

                       QUIT 

 +11      ; get H.O. Letter Code given H.O. Letter #

                   SET RMPOLCD=LTRX("B",RMPOLTR)

 +12      ; create local array

                   SET TRXS(RMPOLCD,RMPOLTR,$PIECE(^RMPR(665.4,TRX,0),U,3))=""

               End DoDot:1

 +13       QUIT 

 +14      ;

PURGE     ; Purge current patient letter list

 +1        SET RMPOLTR=0

           FOR 

               SET RMPOLTR=$ORDER(^RMPR(665,"ALTR",RMPOLTR))

               if RMPOLTR=""

                   QUIT 

               Begin DoDot:1

 +2                SET RMPODFN=0

                   FOR 

                       SET RMPODFN=$ORDER(^RMPR(665,"ALTR",RMPOLTR,RMPODFN))

                       if RMPODFN=""

                           QUIT 

                       DO UPDLTR(RMPODFN,"@")

               End DoDot:1

 +3        QUIT 

 +4       ;

LOCK(TXT) ;

 +1       ; lock virtual list record 

 +2        LOCK +^TMP("RMPO","LETTERPRINT"):0

           IF '$TEST

               WRITE !,"Cannot "_TXT_" list as list edit or printing is in progress"

               QUIT 0

 +3        QUIT 1

 +4       ;

UPDLTR(DA,VAL) ; Update 'Letter to be sent' in Prosthetics Patient File

 +1       ;

 +2       ; I/P :

 +3       ;     VAL - value to be inserted into field

 +4       ;

 +5        SET DR="19.13///"_VAL

           SET DIE="^RMPR(665,"

           DO ^DIE

 +6        QUIT 

 +7       ;

EXIT       GOTO EXIT^RMPOLETA

 +1