source: FOIAVistA/tag/r/WOMENS_HEALTH-WV/WVRPCNO.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1WVRPCNO ;HIOFO/FT-WV NOTIFICATIONS file (790.4) RPCs ;1/7/05 15:03
2 ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998
3 ;
4 ; This routine uses the following IAs:
5 ; #10035 - FILE 2 (supported)
6 ;
7 ; This routine supports the following IAs:
8 ; NEW - 4104
9 ;
10ACCESION(WVIEN) ; Returns the external value of FILE 790.4, Field .06
11 ; Input: record ien
12 ; Output: external value of the .01 field
13 Q $P($G(^WV(790.1,+WVIEN,0)),U,1)
14 ;
15OUTCOME(WVIEN) ; Returns the external value of FILE 790.405
16 ; Input: record ien
17 ; Output: external value of the .01 field
18 Q $P($G(^WV(790.405,+WVIEN,0)),U,1)
19 ;
20PURPOSE(WVIEN) ; Returns the external value of FILE 790.404
21 ; Input: record ien
22 ; Output: external value of the .01 field
23 Q $P($G(^WV(790.404,+WVIEN,0)),U,1)
24 ;
25TYPE(WVIEN) ; Returns the external value of FILE 790.403
26 ; Input: record ien
27 ; Output: external value of the .01 field
28 Q $P($G(^WV(790.403,+WVIEN,0)),U,1)
29 ;
30NEW(WVRESULT,WVNOTPUR) ; Update procedure result, create notification,
31 ; print notification and update treatment needs.
32 ; Input: WVRESULT(n)=FILE 790.1 IEN^"A", "N" or "U" (WVRESULT array is
33 ; Optional)
34 ; where A=Abnornal, N=No Evidence of Malignancy and
35 ; U=Unsatisfactory for Dx.
36 ; n is a number greater than zero.
37 ;
38 ; WVNOTPUR(FILE 790.404 IEN,n)=FILE 790.1 IEN^"I", "L" or "P"^
39 ; FILE 3.5 NAME^DFN
40 ; where I=In-person, L=letter and P=phone call (i.e.,
41 ; notification type)
42 ; Output: None
43 ;
44 N WVCNT,WVDX,WVNODE,WVPURP,WVTYPE
45 I $O(WVRESULT(0)) D
46 .S WVCNT=0
47 .F S WVCNT=$O(WVRESULT(WVCNT)) Q:'WVCNT D
48 ..S WVDX=$$GETDXIEN^WVRPCNO1($P(WVRESULT(WVCNT),U,2))
49 ..D SETRESLT^WVRPCPR($P(WVRESULT(WVCNT),U,1),WVDX)
50 ..Q
51 .Q
52 Q:'$O(WVNOTPUR(0))
53 S WVPURP=0
54 F S WVPURP=$O(WVNOTPUR(WVPURP)) Q:'WVPURP D
55 .S WVCNT=0
56 .F S WVCNT=$O(WVNOTPUR(WVPURP,WVCNT)) Q:'WVCNT D
57 ..S WVNODE=$G(WVNOTPUR(WVPURP,WVCNT))
58 ..Q:WVNODE=""
59 ..;resolve type code to an IEN
60 ..S WVTYPE=$P(WVNODE,U,2)
61 ..I $P(WVNODE,U,2)'="CPRS" S WVTYPE=$$GETYPIEN^WVRPCNO1($P(WVNODE,U,2))
62 ..;throw away printer value if not a letter
63 ..I $P(WVNODE,U,2)'="L" S $P(WVNODE,U,3)=""
64 ..D ADD($P(WVNODE,U,1),WVPURP,WVTYPE,$P(WVNODE,U,3),$P(WVNODE,U,4))
65 ..Q
66 .Q
67 Q
68ADD(WVIEN,WVPURP,WVTYPE,WVPRINTR,WVDFN) ; Create a new notification entry
69 ; in FILE 790.4.
70 ; Input: WVIEN - FILE 790.1 IEN [Required]
71 ; WVPURP - FILE 790.404 IEN [Required]
72 ; WVTYPE - FILE 790.403 IEN [Required]
73 ; WVPRINTR - FILE 3.5 NAME (device) [Optional]
74 ; WVDFN - FILE 790 IEN [Optional]
75 ; Output: <None>
76 ;
77 N BRDD,BRTX,CRDD,CRTX,DA,DFN,DLAYGO
78 N WVDA7904,WVDXFLAG,WVERR,WVERRADD,WVFAC,WVFDA,WVFDAIEN
79 N WVLDAT,WVLPRG,WVNODE,WVNPFLAG,WVOUTCUM,WVPDATE,WVTXFLAG
80 I $G(WVIEN)>0 D
81 .S WVNODE=$G(^WV(790.1,+$G(WVIEN),0))
82 .Q:WVNODE=""
83 .S WVDFN=$P(WVNODE,U,2)
84 .S WVFAC=+$P(WVNODE,U,10)
85 .S WVPDATE=$P(WVNODE,U,12) ;procedure date
86 .Q
87 Q:'$G(WVDFN)
88 S WVNPFLAG=0 ;new patient flag
89 I '$D(^WV(790,+$G(WVDFN),0)) D Q:'WVNPFLAG ;patient not in WH package
90 .Q:$P($G(^DPT(WVDFN,0)),U,2)'="F" ;not female
91 .Q:'$D(^WV(790.02,DUZ(2))) ;no site parameters
92 .Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) ;no default case mgr
93 .S DFN=WVDFN
94 .Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check
95 .S WVERRADD=1
96 .D AUTOADD^WVPATE(WVDFN,DUZ(2),.WVERRADD) ;add patient to FILE 790
97 .I WVERRADD>0 S WVNPFLAG=1 ;patient added
98 .Q
99 I '$D(^WV(790.404,+$G(WVPURP),0)) Q ;purpose
100 I '$G(WVFAC) S WVFAC=DUZ(2) ;facility ien
101 S WVDXFLAG=$P($G(^WV(790.02,+WVFAC,0)),U,11,12)
102 S WVTXFLAG=$P(WVDXFLAG,U,2) ;update treatment needs?
103 S WVDXFLAG=$P(WVDXFLAG,U,1) ;update results/dx?
104 S:$G(WVPDATE)'>0 WVPDATE=DT ;use today if no procedure date
105 I $G(WVTYPE)="CPRS" G TX
106 I '$D(^WV(790.403,+$G(WVTYPE),0)) Q ;type
107 S WVOUTCUM=""
108 I $G(WVPRINTR)]"" S WVOUTCUM=$$GETOIEN^WVRPCNO1("Letter Sent")
109 ; create File 790.4 entry
110 S WVFDA(790.4,"+1,",.01)=WVDFN ;DFN
111 S WVFDA(790.4,"+1,",.02)=DT ;date opened
112 S WVFDA(790.4,"+1,",.03)=WVTYPE ;type
113 S WVFDA(790.4,"+1,",.04)=WVPURP ;purpose
114 S WVFDA(790.4,"+1,",.05)=WVOUTCUM ;outcome
115 S WVFDA(790.4,"+1,",.06)=$G(WVIEN) ;wh accession #
116 S WVFDA(790.4,"+1,",.07)=$S($G(WVFAC):$G(WVFAC),1:DUZ(2)) ;facility
117 S WVFDA(790.4,"+1,",.08)=DT ;date closed
118 I $P($G(^WV(790.403,+$G(WVTYPE),0)),U,2)=1 D
119 .S WVFDA(790.4,"+1,",.11)=DT ;print date
120 .Q
121 S WVFDA(790.4,"+1,",.13)=DT ;complete by date
122 S WVFDA(790.4,"+1,",.14)="c" ;status
123 D UPDATE^DIE("","WVFDA","WVFDAIEN","WVERR")
124 S WVDA7904=WVFDAIEN(1)
125 ;
126TX ; update treatment needs
127 I WVTXFLAG=1 D
128 .S WVNODE=$G(^WV(790.404,WVPURP,0))
129 .S BRTX=$S($P(WVNODE,U,7)]"":$P(WVNODE,U,7),1:"") ;breast tx need
130 .S BRDD=$S($P(WVNODE,U,8)]"":$P(WVNODE,U,8),1:"") ;breast tx due date
131 .S CRTX=$S($P(WVNODE,U,9)]"":$P(WVNODE,U,9),1:"") ;cervical tx need
132 .S CRDD=$S($P(WVNODE,U,10)]"":$P(WVNODE,U,10),1:"") ;cervical tx due date
133 .D BRTX^WVRPCPT(WVDFN,BRTX,BRDD,CRTX,CRDD,WVPDATE) ;update tx needs & due dates
134 .Q
135 ; print notification?
136 Q:$G(WVPRINTR)="" ;no printer defined
137 Q:$P($G(^WV(790.403,+$G(WVTYPE),0)),U,2)'=1 ;not printable
138 S WVPRINTR=$P(WVPRINTR,";",2)
139 Q:WVPRINTR=""
140 D DEVICE^WVRPCNO1(WVDA7904,WVPRINTR) ;print letter
141 Q
Note: See TracBrowser for help on using the repository browser.