RMPOLZ ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
;;3.0;PROSTHETICS;**29,44,46,55,179**;Feb 09, 1996;Build 7
;
; ODJ - patch 55 - Ensure we only include prescriptions which are
; due to expire after the number of days set up
; in site params. cf nois UNY-1000-11685
;
; RMPR*3.0*179 - Modify station check to use internal station ien found in node
; ^RMPR(665,RMPODFN,"RMPOA"), PIECE 7. Also, mimic include check
; for original list to be same as new list, by reverse ordering
; script lookup so check goes from newest back to oldest scripts.
;
FORGD ; Foreground processing of list
N JOB,TRXS,LTRX,SITE,LST
K ^TMP($J)
S JOB=0 ; foreground flag set
; get site
Q:'$$SITE^RMPOLZA("")
; get lock on ^TMP("RMPO",$J,RMPOXITE,"LETTERPRINT")
Q:'$$LOCK^RMPOLZA
; get list parameters
D LST^RMPOLZC I 'LST K ^TMP("VALM VIDEO",$J) Q
I (LST=1),(RL=2) D PURGE^RMPOLZC
D GNLST
; Listman control module
N QT,LSTN
S QT=0 F D Q:QT
. S RMPOLCD="" ; clear letter type code
. ; call "RMPO Letter Type" list to select letter type
. D EN^RMPOLY
. I RMPOLCD="" S QT=1 Q ; quit if no letter type is selected
. Q:$G(QT)=1
. S ^TMP($J,RMPOXITE,"EXIT")=0 ; clear exit to menu flag
. ; call "RMPO Letter" list to manage list and print letters
. ;D EN^RMPOLT
. S QT=^TMP($J,RMPOXITE,"EXIT") ; quit to menu if user requests exit
L -^TMP("RMPO",$J,RMPOXITE,"LETTERPRINT") D EXIT
Q
;
BCKGD ; Background processing of list
N JOB,TRXS,LTRX,SITE
S JOB=1 ; background flag set
S RMPOXITE=0 F S RMPOXITE=$O(^RMPR(669.9,RMPOXITE)) Q:RMPOXITE<1 D
. Q:'$$SITE^RMPOLZA(RMPOXITE)
. Q:'$$LOCK^RMPOLZA
. ; generate list & print letters then clear work file
. D LST^RMPOLZC D GNLST S RMPOLCD=""
. F S RMPOLCD=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD)) Q:RMPOLCD="" D ^RMPOLZB
. K ^TMP($J,RMPOXITE)
D EXIT
Q
;
EXIT ;
K ^TMP($J),DTOUT,DUOUT,DIRUT,DIROUT,LTRX,TRXS
K ANS,DIC,X1,X2,Y,ZTSAVE,POP,X,DFN,VADM,VAPA,%,ANSW,%ZIS
Q
;
GNLST ; generate new or recreate original list
; Input: None
; Output:
; ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR^RMPODFN^RMPO
D LTRCR^RMPOLZC() ; generate letter code to prosthetics letter IEN xref
; build patient list work file from current list (GENOLST) or
; generate new patient letter list work file (GENLST)
I (LST=1),(RL=2) D NEWLST
I (LST=2),(RL=2) D ORGLST
I (LST=1),(RL=0) D ORGLST
Q
;
NEWLST ; generate NEW patient letter list
N RECA,RECB,ADT,IADT W !,"Generating a new list..."
I $G(LST) D
.K ^RMPR(669.9,RMPOXITE,"RMPOXBAT1"),^RMPR(669.9,RMPOXITE,"RMPOXBAT2")
.K ^RMPR(669.9,RMPOXITE,"RMPOXBAT3")
.S ^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0)="^669.9002P^^^"
.S ^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0)="^669.972P^^^"
.S ^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0)="^669.974P^^^"
S ADT="" F S ADT=$O(^RMPR(665,"AHO",ADT)) Q:ADT="" D
. S RMPODFN=0 F S RMPODFN=$O(^RMPR(665,"AHO",ADT,RMPODFN)) Q:RMPODFN<1 D
. . Q:$P(^RMPR(665,RMPODFN,"RMPOA"),U,7)'=RMPOXITE ; ignore patient from another station RMPR*3.0*179
. . ;Get patient demographic data
. . S DFN=RMPODFN K VADM D DEM^VADPT Q:$G(VADM(6))
. . ;Do not collect patient if inactive
. . S RECA=$G(^RMPR(665,RMPODFN,"RMPOA")),IADT=$P(RECA,U,3) Q:$G(IADT)
. . D FNDTRX ; build Xref of transactions (TRX) to letter type
. . ; get active patient prescription and evaluate letter requirement
. . S RMPORX=$$RXAC^RMPOLZC(RMPODFN)
. . Q:'RMPORX
. . S RECB=$G(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0))
. . S RMDEXP=$P(RECB,U,3),RMDACT=$P(RECB,U,1)
. . I $G(LST) D CHECKA
. . I '$G(LST) D CHECK1
Q
;
ORGLST ; Generate work file using ORIGINAL patient letter list
N LTRIEN,STA W !,"Generating an original list..."
F RI="RMPOXBAT1","RMPOXBAT2","RMPOXBAT3" S RMPO=0 F S RMPO=$O(^RMPR(669.9,RMPOXITE,RI,RMPO)) Q:RMPO'>0 D
. ;I JOB,'$D(LTRX("B",RMPOLTR)) Q
. S RMPODFN=$G(^RMPR(669.9,RMPOXITE,RI,RMPO,0))
. S RECA=$G(^RMPR(665,RMPODFN,"RMPOA")),ADT=$P(RECA,U,2),IADT=$P(RECA,U,3)
. Q:$G(IADT)
. S RMPOLCD=$S(RI="RMPOXBAT1":"A",RI="RMPOXBAT2":"B",RI="RMPOXBAT3":"C",1:"") Q:RMPOLCD=""
. S RMPOLTR=$G(LTRX("C",RMPOLCD)) Q:'$G(RMPOLTR)
. S STA=$P(^RMPR(665,RMPODFN,"RMPOA"),U,7) Q:STA'=RMPOXITE ; ignore patients from another station RMPR*3.0*179
. D PRTCHK
. I '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT) Q ;(patch 55)
. S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET","B",RMPOLTR,0))
. Q:'$D(^DPT(RMPODFN,0))
. S:$D(^DPT(RMPODFN,0)) RMPONAM=$E($P(^DPT(RMPODFN,0),U,1),1,15)
. D EXTRCT^RMPOLZA S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
Q
;
FNDTRX ; find letter TRX & hold in local array
; output: ^TMP($J,DFN,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 valid H.O. letter transaction
. S RMPOLCD=LTRX("B",RMPOLTR) ; get H.O. Letter Code given H.O. Letter #
. S ^TMP($J,RMPODFN,RMPOLCD,RMPOLTR,$P(^RMPR(665.4,TRX,0),U,3))="" ; create local array
Q
;
; calc. if any patient prescription should get letter (patch 55)
INCLUDE(RMPODFN,RMPOLCD,LTRX,RMDPRT,RMFPRT,RMPORX,RMDACT) ;
N RMPRINCL,RECB,RMDEXP,RMPOX
S RMPRINCL=0,RMPOX=0
S RMPORX=9999
F S RMPORX=$O(^RMPR(665,RMPODFN,"RMPOB",RMPORX),-1) Q:'+RMPORX D Q:RMPRINCL!RMPOX ;RMPR*3.0*179
. S RECB=$G(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0))
. S RMDEXP=+$P(RECB,U,3) ;prescription expiry date
. Q:'RMDEXP
. S RMDACT=$P(RECB,U,1)
. I RMDEXP>LTRX("D",RMPOLCD) S RMPOX=1 Q ;expiry after include period
. Q:RMDEXP<DT ;expiry before todays date
. I $G(RMFPRT)'="",(RMDPRT>RMDACT) Q
. S RMPRINCL=1
. Q
Q RMPRINCL
;
CHECKA ; check if patient needs all types of letter.
F RMPOLCD="A","B","C" D
. S (RMDTE,RMPOLTR)=0,RMPOLTR=$O(LTRX("A",RMPOLCD,RMPOLTR)) Q:'$G(RMPOLTR)
. S RMDTE=$O(^TMP($J,RMPODFN,RMPOLCD,RMPOLTR,0))
. I RMPOLCD="B",$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT1","B",RMPODFN)) Q
. I RMPOLCD="C"&($D(^RMPR(669.9,RMPOXITE,"RMPOXBAT2","B",RMPODFN))!$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT1","B",RMPODFN))) Q
. D PRTCHK
. I '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT) Q ;(patch 55)
. I RMDPIEC="",RMFPIEC="" Q
. Q:RMDTE>RMDACT Q:'$D(^DPT(RMPODFN,0))
. S:$D(^DPT(RMPODFN,0)) RMPONAM=$E($P(^DPT(RMPODFN,0),U,1),1,15)
. S RMCOD=$S(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
. Q:$D(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
. K DD,DO S DA(1)=RMPOXITE,DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
. S DIC(0)="L",X=RMPODFN,DLAYGO=669.9 D FILE^DICN Q:'$D(DA) S RMPO=DA K DIC,DA,X
. D EXTRCT^RMPOLZA S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
Q
;
CHECK1 ; check if patient needs a letter (only one type of letter).
S (RMDTE,LST)=0,RMPOLTR=""
S RMPOLTR=$O(LTRX("A",RMPOLCD,RMPOLTR)) Q:RMPOLTR=""
S RMDTE=$O(^TMP($J,RMPODFN,RMPOLCD,RMPOLTR,0))
I ((RMPOLCD="B")&$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT2","B",RMPODFN)))!($P(^RMPR(665,RMPODFN,"RMPOA"),U,9)>RMDACT) Q
I ((RMPOLCD="C")&$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT3","B",RMPODFN)))!($P(^RMPR(665,RMPODFN,"RMPOA"),U,11)>RMDACT) Q
D PRTCHK
I '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT) Q ;(patch 55)
I RMDPIEC="",RMFPIEC="" Q
Q:RMDTE>RMDACT
Q:'$D(^DPT(RMPODFN,0)) S:$D(^DPT(RMPODFN,0)) RMPONAM=$E($P(^DPT(RMPODFN,0),U,1),1,15)
S RMCOD=$S(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
Q:$D(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
K DD,DO S DA(1)=RMPOXITE,DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
S DIC(0)="L",X=RMPODFN,DLAYGO=669.9 D FILE^DICN Q:'$D(DA) S RMPO=DA K DIC,DA,X
D EXTRCT^RMPOLZA S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
Q
PRTCHK S (RMFPRT,RMDPRT,RMFPIEC,RMDPIEC)=""
I RMPOLCD="B",$P(RECA,U,10)="" Q
I RMPOLCD="C",$P(RECA,U,12)="" Q
S RMDPIEC=$S(RMPOLCD="A":9,RMPOLCD="B":11,RMPOLCD="C":13,1:"")
S RMFPIEC=$S(RMPOLCD="A":10,RMPOLCD="B":12,RMPOLCD="C":14,1:"")
S RMFPRT=$P(RECA,U,RMFPIEC),RMDPRT=$P(RECA,U,RMDPIEC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLZ 8369 printed Oct 16, 2024@18:31:48 Page 2
RMPOLZ ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,44,46,55,179**;Feb 09, 1996;Build 7
+2 ;
+3 ; ODJ - patch 55 - Ensure we only include prescriptions which are
+4 ; due to expire after the number of days set up
+5 ; in site params. cf nois UNY-1000-11685
+6 ;
+7 ; RMPR*3.0*179 - Modify station check to use internal station ien found in node
+8 ; ^RMPR(665,RMPODFN,"RMPOA"), PIECE 7. Also, mimic include check
+9 ; for original list to be same as new list, by reverse ordering
+10 ; script lookup so check goes from newest back to oldest scripts.
+11 ;
FORGD ; Foreground processing of list
+1 NEW JOB,TRXS,LTRX,SITE,LST
+2 KILL ^TMP($JOB)
+3 ; foreground flag set
SET JOB=0
+4 ; get site
+5 if '$$SITE^RMPOLZA("")
QUIT
+6 ; get lock on ^TMP("RMPO",$J,RMPOXITE,"LETTERPRINT")
+7 if '$$LOCK^RMPOLZA
QUIT
+8 ; get list parameters
+9 DO LST^RMPOLZC
IF 'LST
KILL ^TMP("VALM VIDEO",$JOB)
QUIT
+10 IF (LST=1)
IF (RL=2)
DO PURGE^RMPOLZC
+11 DO GNLST
+12 ; Listman control module
+13 NEW QT,LSTN
+14 SET QT=0
FOR
Begin DoDot:1
+15 ; clear letter type code
SET RMPOLCD=""
+16 ; call "RMPO Letter Type" list to select letter type
+17 DO EN^RMPOLY
+18 ; quit if no letter type is selected
IF RMPOLCD=""
SET QT=1
QUIT
+19 if $GET(QT)=1
QUIT
+20 ; clear exit to menu flag
SET ^TMP($JOB,RMPOXITE,"EXIT")=0
+21 ; call "RMPO Letter" list to manage list and print letters
+22 ;D EN^RMPOLT
+23 ; quit to menu if user requests exit
SET QT=^TMP($JOB,RMPOXITE,"EXIT")
End DoDot:1
if QT
QUIT
+24 LOCK -^TMP("RMPO",$JOB,RMPOXITE,"LETTERPRINT")
DO EXIT
+25 QUIT
+26 ;
BCKGD ; Background processing of list
+1 NEW JOB,TRXS,LTRX,SITE
+2 ; background flag set
SET JOB=1
+3 SET RMPOXITE=0
FOR
SET RMPOXITE=$ORDER(^RMPR(669.9,RMPOXITE))
if RMPOXITE<1
QUIT
Begin DoDot:1
+4 if '$$SITE^RMPOLZA(RMPOXITE)
QUIT
+5 if '$$LOCK^RMPOLZA
QUIT
+6 ; generate list & print letters then clear work file
+7 DO LST^RMPOLZC
DO GNLST
SET RMPOLCD=""
+8 FOR
SET RMPOLCD=$ORDER(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD))
if RMPOLCD=""
QUIT
DO ^RMPOLZB
+9 KILL ^TMP($JOB,RMPOXITE)
End DoDot:1
+10 DO EXIT
+11 QUIT
+12 ;
EXIT ;
+1 KILL ^TMP($JOB),DTOUT,DUOUT,DIRUT,DIROUT,LTRX,TRXS
+2 KILL ANS,DIC,X1,X2,Y,ZTSAVE,POP,X,DFN,VADM,VAPA,%,ANSW,%ZIS
+3 QUIT
+4 ;
GNLST ; generate new or recreate original list
+1 ; Input: None
+2 ; Output:
+3 ; ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR^RMPODFN^RMPO
+4 ; generate letter code to prosthetics letter IEN xref
DO LTRCR^RMPOLZC()
+5 ; build patient list work file from current list (GENOLST) or
+6 ; generate new patient letter list work file (GENLST)
+7 IF (LST=1)
IF (RL=2)
DO NEWLST
+8 IF (LST=2)
IF (RL=2)
DO ORGLST
+9 IF (LST=1)
IF (RL=0)
DO ORGLST
+10 QUIT
+11 ;
NEWLST ; generate NEW patient letter list
+1 NEW RECA,RECB,ADT,IADT
WRITE !,"Generating a new list..."
+2 IF $GET(LST)
Begin DoDot:1
+3 KILL ^RMPR(669.9,RMPOXITE,"RMPOXBAT1"),^RMPR(669.9,RMPOXITE,"RMPOXBAT2")
+4 KILL ^RMPR(669.9,RMPOXITE,"RMPOXBAT3")
+5 SET ^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0)="^669.9002P^^^"
+6 SET ^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0)="^669.972P^^^"
+7 SET ^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0)="^669.974P^^^"
End DoDot:1
+8 SET ADT=""
FOR
SET ADT=$ORDER(^RMPR(665,"AHO",ADT))
if ADT=""
QUIT
Begin DoDot:1
+9 SET RMPODFN=0
FOR
SET RMPODFN=$ORDER(^RMPR(665,"AHO",ADT,RMPODFN))
if RMPODFN<1
QUIT
Begin DoDot:2
+10 ; ignore patient from another station RMPR*3.0*179
if $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,7)'=RMPOXITE
QUIT
+11 ;Get patient demographic data
+12 SET DFN=RMPODFN
KILL VADM
DO DEM^VADPT
if $GET(VADM(6))
QUIT
+13 ;Do not collect patient if inactive
+14 SET RECA=$GET(^RMPR(665,RMPODFN,"RMPOA"))
SET IADT=$PIECE(RECA,U,3)
if $GET(IADT)
QUIT
+15 ; build Xref of transactions (TRX) to letter type
DO FNDTRX
+16 ; get active patient prescription and evaluate letter requirement
+17 SET RMPORX=$$RXAC^RMPOLZC(RMPODFN)
+18 if 'RMPORX
QUIT
+19 SET RECB=$GET(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0))
+20 SET RMDEXP=$PIECE(RECB,U,3)
SET RMDACT=$PIECE(RECB,U,1)
+21 IF $GET(LST)
DO CHECKA
+22 IF '$GET(LST)
DO CHECK1
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
ORGLST ; Generate work file using ORIGINAL patient letter list
+1 NEW LTRIEN,STA
WRITE !,"Generating an original list..."
+2 FOR RI="RMPOXBAT1","RMPOXBAT2","RMPOXBAT3"
SET RMPO=0
FOR
SET RMPO=$ORDER(^RMPR(669.9,RMPOXITE,RI,RMPO))
if RMPO'>0
QUIT
Begin DoDot:1
+3 ;I JOB,'$D(LTRX("B",RMPOLTR)) Q
+4 SET RMPODFN=$GET(^RMPR(669.9,RMPOXITE,RI,RMPO,0))
+5 SET RECA=$GET(^RMPR(665,RMPODFN,"RMPOA"))
SET ADT=$PIECE(RECA,U,2)
SET IADT=$PIECE(RECA,U,3)
+6 if $GET(IADT)
QUIT
+7 SET RMPOLCD=$SELECT(RI="RMPOXBAT1":"A",RI="RMPOXBAT2":"B",RI="RMPOXBAT3":"C",1:"")
if RMPOLCD=""
QUIT
+8 SET RMPOLTR=$GET(LTRX("C",RMPOLCD))
if '$GET(RMPOLTR)
QUIT
+9 ; ignore patients from another station RMPR*3.0*179
SET STA=$PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,7)
if STA'=RMPOXITE
QUIT
+10 DO PRTCHK
+11 ;(patch 55)
IF '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT)
QUIT
+12 SET LTRIEN=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOLET","B",RMPOLTR,0))
+13 if '$DATA(^DPT(RMPODFN,0))
QUIT
+14 if $DATA(^DPT(RMPODFN,0))
SET RMPONAM=$EXTRACT($PIECE(^DPT(RMPODFN,0),U,1),1,15)
+15 DO EXTRCT^RMPOLZA
SET ^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
End DoDot:1
+16 QUIT
+17 ;
FNDTRX ; find letter TRX & hold in local array
+1 ; output: ^TMP($J,DFN,H.O. Letter Code,Prosthetics Letter,Transaction Printed Date)
+2 NEW TRX
SET TRX=0
FOR
SET TRX=$ORDER(^RMPR(665.4,"B",RMPODFN,TRX))
if TRX=""
QUIT
Begin DoDot:1
+3 ; ignore letters from a different station
if $PIECE(^RMPR(665.4,TRX,0),U,6)'=RMPO("STA")
QUIT
+4 ; ignore if not a valid H.O. letter transaction
SET RMPOLTR=$PIECE(^RMPR(665.4,TRX,0),U,2)
if '$DATA(LTRX("B",RMPOLTR))
QUIT
+5 ; get H.O. Letter Code given H.O. Letter #
SET RMPOLCD=LTRX("B",RMPOLTR)
+6 ; create local array
SET ^TMP($JOB,RMPODFN,RMPOLCD,RMPOLTR,$PIECE(^RMPR(665.4,TRX,0),U,3))=""
End DoDot:1
+7 QUIT
+8 ;
+9 ; calc. if any patient prescription should get letter (patch 55)
INCLUDE(RMPODFN,RMPOLCD,LTRX,RMDPRT,RMFPRT,RMPORX,RMDACT) ;
+1 NEW RMPRINCL,RECB,RMDEXP,RMPOX
+2 SET RMPRINCL=0
SET RMPOX=0
+3 SET RMPORX=9999
+4 ;RMPR*3.0*179
FOR
SET RMPORX=$ORDER(^RMPR(665,RMPODFN,"RMPOB",RMPORX),-1)
if '+RMPORX
QUIT
Begin DoDot:1
+5 SET RECB=$GET(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0))
+6 ;prescription expiry date
SET RMDEXP=+$PIECE(RECB,U,3)
+7 if 'RMDEXP
QUIT
+8 SET RMDACT=$PIECE(RECB,U,1)
+9 ;expiry after include period
IF RMDEXP>LTRX("D",RMPOLCD)
SET RMPOX=1
QUIT
+10 ;expiry before todays date
if RMDEXP<DT
QUIT
+11 IF $GET(RMFPRT)'=""
IF (RMDPRT>RMDACT)
QUIT
+12 SET RMPRINCL=1
+13 QUIT
End DoDot:1
if RMPRINCL!RMPOX
QUIT
+14 QUIT RMPRINCL
+15 ;
CHECKA ; check if patient needs all types of letter.
+1 FOR RMPOLCD="A","B","C"
Begin DoDot:1
+2 SET (RMDTE,RMPOLTR)=0
SET RMPOLTR=$ORDER(LTRX("A",RMPOLCD,RMPOLTR))
if '$GET(RMPOLTR)
QUIT
+3 SET RMDTE=$ORDER(^TMP($JOB,RMPODFN,RMPOLCD,RMPOLTR,0))
+4 IF RMPOLCD="B"
IF $DATA(^RMPR(669.9,RMPOXITE,"RMPOXBAT1","B",RMPODFN))
QUIT
+5 IF RMPOLCD="C"&($DATA(^RMPR(669.9,RMPOXITE,"RMPOXBAT2","B",RMPODFN))!$DATA(^RMPR(669.9,RMPOXITE,"RMPOXBAT1","B",RMPODFN)))
QUIT
+6 DO PRTCHK
+7 ;(patch 55)
IF '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT)
QUIT
+8 IF RMDPIEC=""
IF RMFPIEC=""
QUIT
+9 if RMDTE>RMDACT
QUIT
if '$DATA(^DPT(RMPODFN,0))
QUIT
+10 if $DATA(^DPT(RMPODFN,0))
SET RMPONAM=$EXTRACT($PIECE(^DPT(RMPODFN,0),U,1),1,15)
+11 SET RMCOD=$SELECT(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
+12 if $DATA(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
QUIT
+13 KILL DD,DO
SET DA(1)=RMPOXITE
SET DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
+14 SET DIC(0)="L"
SET X=RMPODFN
SET DLAYGO=669.9
DO FILE^DICN
if '$DATA(DA)
QUIT
SET RMPO=DA
KILL DIC,DA,X
+15 DO EXTRCT^RMPOLZA
SET ^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
End DoDot:1
+16 QUIT
+17 ;
CHECK1 ; check if patient needs a letter (only one type of letter).
+1 SET (RMDTE,LST)=0
SET RMPOLTR=""
+2 SET RMPOLTR=$ORDER(LTRX("A",RMPOLCD,RMPOLTR))
if RMPOLTR=""
QUIT
+3 SET RMDTE=$ORDER(^TMP($JOB,RMPODFN,RMPOLCD,RMPOLTR,0))
+4 IF ((RMPOLCD="B")&$DATA(^RMPR(669.9,RMPOXITE,"RMPOXBAT2","B",RMPODFN)))!($PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,9)>RMDACT)
QUIT
+5 IF ((RMPOLCD="C")&$DATA(^RMPR(669.9,RMPOXITE,"RMPOXBAT3","B",RMPODFN)))!($PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,11)>RMDACT)
QUIT
+6 DO PRTCHK
+7 ;(patch 55)
IF '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT)
QUIT
+8 IF RMDPIEC=""
IF RMFPIEC=""
QUIT
+9 if RMDTE>RMDACT
QUIT
+10 if '$DATA(^DPT(RMPODFN,0))
QUIT
if $DATA(^DPT(RMPODFN,0))
SET RMPONAM=$EXTRACT($PIECE(^DPT(RMPODFN,0),U,1),1,15)
+11 SET RMCOD=$SELECT(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
+12 if $DATA(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
QUIT
+13 KILL DD,DO
SET DA(1)=RMPOXITE
SET DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
+14 SET DIC(0)="L"
SET X=RMPODFN
SET DLAYGO=669.9
DO FILE^DICN
if '$DATA(DA)
QUIT
SET RMPO=DA
KILL DIC,DA,X
+15 DO EXTRCT^RMPOLZA
SET ^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
+16 QUIT
PRTCHK SET (RMFPRT,RMDPRT,RMFPIEC,RMDPIEC)=""
+1 IF RMPOLCD="B"
IF $PIECE(RECA,U,10)=""
QUIT
+2 IF RMPOLCD="C"
IF $PIECE(RECA,U,12)=""
QUIT
+3 SET RMDPIEC=$SELECT(RMPOLCD="A":9,RMPOLCD="B":11,RMPOLCD="C":13,1:"")
+4 SET RMFPIEC=$SELECT(RMPOLCD="A":10,RMPOLCD="B":12,RMPOLCD="C":14,1:"")
+5 SET RMFPRT=$PIECE(RECA,U,RMFPIEC)
SET RMDPRT=$PIECE(RECA,U,RMDPIEC)
+6 QUIT
