RMPOLZC ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
;;3.0;PROSTHETICS;**55**;Feb 09, 1996
;
; ODJ - patch 55 - Need to split RMPOLZ as over 10K
;
Q
;
LST ; Check Letters List
; Input:
; JOB - 1: job, 0: interactive
; Output:
; LST(list parameters) - 0: no action
; 1: use current list
; 2: create new list
S (RL,RMLSTF,LST)=0,%=2
S RMBAT1=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0))
S RMBAT2=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0))
S RMBAT3=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0))
I $G(RMBAT1)!$G(RMBAT2)!$G(RMBAT3) S RMLSTF=1 ; if already a patient list in existance exit
I JOB S LST=1 Q ; use current list as default if run in background
LST1 I RMLSTF W !,"A list of patient letters to be printed already exists",!,"Do you wish to manage the current list" D YN^DICN
S:%=1 LST=1 S:%=-1 LST=0 S:%=2 RL=2 I %=0 W !,"Answer with 'Y' or 'N' " S %=2 G LST1
LST2 I RL=2 S %=2 W !,"Do you wish to generate a new list which will discard any edits" D YN^DICN S:%=1 LST=1 S:%=2 LST=2 S:%=-1 LST=0 I %=0 W !,"Answer with 'Y' or 'N' " S %=2 G LST2
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^RMPOLZA(RMPODFN,"@")
Q
;
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. !
; Input:
; JOB - 1: job, 0: interactive
; Output:
; LTRX("A",Letter Code,Prosthetics Letter IEN)
; LTRX("B",Prosthetics Letter IEN)=Letter Code
; LTRX("C",Letter Code)=Prosthetics Letter IEN
; LTRX("D",Letter Code)=days till expiry (patch 55)
; ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)= 0: No Letter header
N LTRIEN,REC,HEAD,X1,X2,X,%H,%T,%,%I,RMPONOW
D NOW^%DTC S RMPONOW=X
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)
. ; if run is backgrd and letters are NOT to be autogenerated then do not list
. ; the letter as a valid H.O. letter
. I JOB,'$P(REC,U,4) Q
. S RMPOLTR=$P(REC,U),RMPOLCD=$P(REC,U,2),RMPOGEN=$P(REC,U,4)
. I RMPOLCD=""!(RMPOLTR="")!('$G(RMPOGEN)) Q
. S ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)=$P(REC,U,5)
. S LTRX("A",RMPOLCD,RMPOLTR)="",LTRX("B",RMPOLTR)=RMPOLCD
. S LTRX("C",RMPOLCD)=RMPOLTR
. ;
. ; calc. a date after which prescription expiry dates will
. ; not generate a given letter
. S X1=RMPONOW,X2=$P(REC,U,3) D C^%DTC
. S LTRX("D",RMPOLCD)=X
Q
;
; Get active prescription
RXAC(RMPRPAT) ;
N RMPRX,RMPRS,X,%,%H,%I,RMPROK,RMDACT,RMDEXP,TODAY,RMPRIEN
D NOW^%DTC
S TODAY=X
S RMPRIEN=0
S RMPRX=":"
F S RMPRX=$O(^RMPR(665,RMPRPAT,"RMPOB",RMPRX),-1) Q:'+RMPRX D Q:RMPRIEN
. S RMPRS=^RMPR(665,RMPRPAT,"RMPOB",RMPRX,0)
. S RMDACT=$P(RMPRS,"^",1)
. S RMDEXP=$P(RMPRS,"^",3)
. I RMDACT'="",RMDACT'>TODAY D
.. I RMDEXP="" S RMPRIEN=RMPRX Q
.. I RMDEXP>TODAY S RMPRIEN=RMPRX Q
.. Q
. Q
Q RMPRIEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLZC 3310 printed Dec 13, 2024@02:31:11 Page 2
RMPOLZC ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
+1 ;;3.0;PROSTHETICS;**55**;Feb 09, 1996
+2 ;
+3 ; ODJ - patch 55 - Need to split RMPOLZ as over 10K
+4 ;
+5 QUIT
+6 ;
LST ; Check Letters List
+1 ; Input:
+2 ; JOB - 1: job, 0: interactive
+3 ; Output:
+4 ; LST(list parameters) - 0: no action
+5 ; 1: use current list
+6 ; 2: create new list
+7 SET (RL,RMLSTF,LST)=0
SET %=2
+8 SET RMBAT1=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0))
+9 SET RMBAT2=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0))
+10 SET RMBAT3=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0))
+11 ; if already a patient list in existance exit
IF $GET(RMBAT1)!$GET(RMBAT2)!$GET(RMBAT3)
SET RMLSTF=1
+12 ; use current list as default if run in background
IF JOB
SET LST=1
QUIT
LST1 IF RMLSTF
WRITE !,"A list of patient letters to be printed already exists",!,"Do you wish to manage the current list"
DO YN^DICN
+1 if %=1
SET LST=1
if %=-1
SET LST=0
if %=2
SET RL=2
IF %=0
WRITE !,"Answer with 'Y' or 'N' "
SET %=2
GOTO LST1
LST2 IF RL=2
SET %=2
WRITE !,"Do you wish to generate a new list which will discard any edits"
DO YN^DICN
if %=1
SET LST=1
if %=2
SET LST=2
if %=-1
SET LST=0
IF %=0
WRITE !,"Answer with 'Y' or 'N' "
SET %=2
GOTO LST2
+1 QUIT
+2 ;
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^RMPOLZA(RMPODFN,"@")
End DoDot:1
+3 QUIT
+4 ;
LTRCR() ; build local array CROSS REFERENCE of H.O. letter Code to Letter
+1 ; ! assumes a letter code can have many letter templates but one !
+2 ; ! template is of a particluar type e.g. a 30,60,90 & 120 Day H.O. !
+3 ; ! letters are all of type "B" : prescription pending expiry. !
+4 ; Input:
+5 ; JOB - 1: job, 0: interactive
+6 ; Output:
+7 ; LTRX("A",Letter Code,Prosthetics Letter IEN)
+8 ; LTRX("B",Prosthetics Letter IEN)=Letter Code
+9 ; LTRX("C",Letter Code)=Prosthetics Letter IEN
+10 ; LTRX("D",Letter Code)=days till expiry (patch 55)
+11 ; ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)= 0: No Letter header
+12 NEW LTRIEN,REC,HEAD,X1,X2,X,%H,%T,%,%I,RMPONOW
+13 DO NOW^%DTC
SET RMPONOW=X
+14 SET LTRIEN=0
FOR
SET LTRIEN=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN))
if LTRIEN<1
QUIT
Begin DoDot:1
+15 SET REC=^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0)
+16 ; if run is backgrd and letters are NOT to be autogenerated then do not list
+17 ; the letter as a valid H.O. letter
+18 IF JOB
IF '$PIECE(REC,U,4)
QUIT
+19 SET RMPOLTR=$PIECE(REC,U)
SET RMPOLCD=$PIECE(REC,U,2)
SET RMPOGEN=$PIECE(REC,U,4)
+20 IF RMPOLCD=""!(RMPOLTR="")!('$GET(RMPOGEN))
QUIT
+21 SET ^TMP($JOB,RMPOXITE,"HEADER",RMPOLTR)=$PIECE(REC,U,5)
+22 SET LTRX("A",RMPOLCD,RMPOLTR)=""
SET LTRX("B",RMPOLTR)=RMPOLCD
+23 SET LTRX("C",RMPOLCD)=RMPOLTR
+24 ;
+25 ; calc. a date after which prescription expiry dates will
+26 ; not generate a given letter
+27 SET X1=RMPONOW
SET X2=$PIECE(REC,U,3)
DO C^%DTC
+28 SET LTRX("D",RMPOLCD)=X
End DoDot:1
+29 QUIT
+30 ;
+31 ; Get active prescription
RXAC(RMPRPAT) ;
+1 NEW RMPRX,RMPRS,X,%,%H,%I,RMPROK,RMDACT,RMDEXP,TODAY,RMPRIEN
+2 DO NOW^%DTC
+3 SET TODAY=X
+4 SET RMPRIEN=0
+5 SET RMPRX=":"
+6 FOR
SET RMPRX=$ORDER(^RMPR(665,RMPRPAT,"RMPOB",RMPRX),-1)
if '+RMPRX
QUIT
Begin DoDot:1
+7 SET RMPRS=^RMPR(665,RMPRPAT,"RMPOB",RMPRX,0)
+8 SET RMDACT=$PIECE(RMPRS,"^",1)
+9 SET RMDEXP=$PIECE(RMPRS,"^",3)
+10 IF RMDACT'=""
IF RMDACT'>TODAY
Begin DoDot:2
+11 IF RMDEXP=""
SET RMPRIEN=RMPRX
QUIT
+12 IF RMDEXP>TODAY
SET RMPRIEN=RMPRX
QUIT
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
if RMPRIEN
QUIT
+15 QUIT RMPRIEN
