source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOLZC.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1RMPOLZC ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
2 ;;3.0;PROSTHETICS;**55**;Feb 09, 1996
3 ;
4 ; ODJ - patch 55 - Need to split RMPOLZ as over 10K
5 ;
6 Q
7 ;
8LST ; Check Letters List
9 ; Input:
10 ; JOB - 1: job, 0: interactive
11 ; Output:
12 ; LST(list parameters) - 0: no action
13 ; 1: use current list
14 ; 2: create new list
15 S (RL,RMLSTF,LST)=0,%=2
16 S RMBAT1=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0))
17 S RMBAT2=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0))
18 S RMBAT3=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0))
19 I $G(RMBAT1)!$G(RMBAT2)!$G(RMBAT3) S RMLSTF=1 ; if already a patient list in existance exit
20 I JOB S LST=1 Q ; use current list as default if run in background
21LST1 I RMLSTF W !,"A list of patient letters to be printed already exists",!,"Do you wish to manage the current list" D YN^DICN
22 S:%=1 LST=1 S:%=-1 LST=0 S:%=2 RL=2 I %=0 W !,"Answer with 'Y' or 'N' " S %=2 G LST1
23LST2 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
24 Q
25 ;
26PURGE ; Purge current patient letter list
27 S RMPOLTR=0 F S RMPOLTR=$O(^RMPR(665,"ALTR",RMPOLTR)) Q:RMPOLTR="" D
28 . S RMPODFN=0 F S RMPODFN=$O(^RMPR(665,"ALTR",RMPOLTR,RMPODFN)) Q:RMPODFN="" D UPDLTR^RMPOLZA(RMPODFN,"@")
29 Q
30 ;
31LTRCR() ; build local array CROSS REFERENCE of H.O. letter Code to Letter
32 ; ! assumes a letter code can have many letter templates but one !
33 ; ! template is of a particluar type e.g. a 30,60,90 & 120 Day H.O. !
34 ; ! letters are all of type "B" : prescription pending expiry. !
35 ; Input:
36 ; JOB - 1: job, 0: interactive
37 ; Output:
38 ; LTRX("A",Letter Code,Prosthetics Letter IEN)
39 ; LTRX("B",Prosthetics Letter IEN)=Letter Code
40 ; LTRX("C",Letter Code)=Prosthetics Letter IEN
41 ; LTRX("D",Letter Code)=days till expiry (patch 55)
42 ; ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)= 0: No Letter header
43 N LTRIEN,REC,HEAD,X1,X2,X,%H,%T,%,%I,RMPONOW
44 D NOW^%DTC S RMPONOW=X
45 S LTRIEN=0 F S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN)) Q:LTRIEN<1 D
46 . S REC=^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0)
47 . ; if run is backgrd and letters are NOT to be autogenerated then do not list
48 . ; the letter as a valid H.O. letter
49 . I JOB,'$P(REC,U,4) Q
50 . S RMPOLTR=$P(REC,U),RMPOLCD=$P(REC,U,2),RMPOGEN=$P(REC,U,4)
51 . I RMPOLCD=""!(RMPOLTR="")!('$G(RMPOGEN)) Q
52 . S ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)=$P(REC,U,5)
53 . S LTRX("A",RMPOLCD,RMPOLTR)="",LTRX("B",RMPOLTR)=RMPOLCD
54 . S LTRX("C",RMPOLCD)=RMPOLTR
55 . ;
56 . ; calc. a date after which prescription expiry dates will
57 . ; not generate a given letter
58 . S X1=RMPONOW,X2=$P(REC,U,3) D C^%DTC
59 . S LTRX("D",RMPOLCD)=X
60 Q
61 ;
62 ; Get active prescription
63RXAC(RMPRPAT) ;
64 N RMPRX,RMPRS,X,%,%H,%I,RMPROK,RMDACT,RMDEXP,TODAY,RMPRIEN
65 D NOW^%DTC
66 S TODAY=X
67 S RMPRIEN=0
68 S RMPRX=":"
69 F S RMPRX=$O(^RMPR(665,RMPRPAT,"RMPOB",RMPRX),-1) Q:'+RMPRX D Q:RMPRIEN
70 . S RMPRS=^RMPR(665,RMPRPAT,"RMPOB",RMPRX,0)
71 . S RMDACT=$P(RMPRS,"^",1)
72 . S RMDEXP=$P(RMPRS,"^",3)
73 . I RMDACT'="",RMDACT'>TODAY D
74 .. I RMDEXP="" S RMPRIEN=RMPRX Q
75 .. I RMDEXP>TODAY S RMPRIEN=RMPRX Q
76 .. Q
77 . Q
78 Q RMPRIEN
Note: See TracBrowser for help on using the repository browser.