189 lines
7.0 KiB
Mathematica
189 lines
7.0 KiB
Mathematica
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
|
|
|