source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHD3.m@ 1245

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

initial load of FOIAVistA 6/30/08 version

File size: 6.0 KB
Line 
1CRHD3 ; CAIRO/CLC - Modules to support CAIRO Hand-off Tool ;03-Apr-2008 11:22;CLC
2 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
3 ;=================================================================
4GTEMPTXT(CRHDRTN,CRHDSTR) ;
5 D GETTEXT(.CRHDRTN,.CRHDSTR,1)
6 Q
7GETTEXT(CRHDRTN,CRHDSTR,DIWF) ;
8 N CRHDFLD,CRHDUSER,CRHDDFN,CRHDVALS,CRHDTEAM,X,CRHDX1
9 N CRHDFLDN,CRHDTRG,CRHDTM,CRHDTSP,CRHDPN,CRHDFG,CRHDX
10 N CRHDLEN,CRHDCT,CRHDWLED,CRHDTMP,CRHDATTN,CRHDDIV,CRHDEX,CRHDZ0,DIWL,DIWR
11 N CRHDEXPD,CRHDFG2,CRHDLEDI,CRHDLL,CRHDLSTT,CRHDMN2,CRHDROOT,CRHDNAM
12 K CRHDRTN
13 S CRHDTRG="^CRHD(183.2)"
14 S CRHDFLD=$P(CRHDSTR,"^",1)
15 S:CRHDFLD'="" CRHDFLD=$$UP^XLFSTR(CRHDFLD)
16 S CRHDUSER=$P(CRHDSTR,"^",2)
17 S CRHDDFN=$P(CRHDSTR,"^",3)
18 S CRHDLEN=$P(CRHDSTR,"^",4)
19 I 'CRHDLEN S CRHDLEN=256
20 S CRHDDIV=$P(CRHDSTR,"^",5)
21 S DIWF=$S(+$G(DIWF):"NR",1:"R")
22 I CRHDDIV="" S CRHDDIV=+$$SITE^VASITE
23 S CRHDATTN=+$G(^DPT(+CRHDDFN,.1041))
24 Q:CRHDFLD=""
25 Q:'CRHDUSER
26 Q:'CRHDDFN
27 ;get expiration date for temp fields
28 S CRHDEX=$$GET^XPAR("DIV.`"_CRHDDIV,"CRHD TEMP FLD EXPIRE",1,"I")
29 S CRHDFLDN=$O(@CRHDTRG@("B",CRHDFLD,0))
30 Q:'CRHDFLDN
31 S CRHDFG=$O(^CRHD(183.2,"C",+CRHDDFN,CRHDFLDN,0))
32 Q:'CRHDFG
33 ;check expiration date here
34 S CRHDZ0=$G(@CRHDTRG@(CRHDFLDN,1,CRHDFG,0)),CRHDLEDI=$P(CRHDZ0,"^",5),CRHDWLED=$P(CRHDZ0,"^",4)
35 ;S CRHDEX=7
36 I 'CRHDEX S CRHDEX=7 ;if parameter not set default to 7 days
37 I CRHDEX&(CRHDLEDI) S CRHDEXPD=$$FMADD^XLFDT(CRHDLEDI,CRHDEX)
38 I $G(CRHDEXPD) I $G(CRHDEXPD)<DT D DELTMPTX^CRHD7(CRHDFLDN,CRHDFG) Q
39 ;
40 S CRHDROOT="^CRHD(183.2,"_CRHDFLDN_",1,"_CRHDFG_")"
41 S DIWL=1,DIWR=CRHDLEN K ^UTILITY($J,"W"),CRHDTMP
42 I DIWF="R" S CRHDCT=1 D B2
43 I DIWF="NR" D
44 .M CRHDTMP(CRHDFLDN)=@CRHDROOT@("TEXT")
45 S CRHDCT=2,CRHDX=0
46 S CRHDX=$O(CRHDTMP(CRHDX)) Q:'CRHDX S CRHDX1=0 F S CRHDX1=$O(CRHDTMP(CRHDX,CRHDX1)) Q:'CRHDX1 S CRHDRTN(CRHDX1+1)=CRHDTMP(CRHDX,CRHDX1,0)
47 S CRHDCT=99999,CRHDCT=$O(CRHDRTN(CRHDCT),-1)
48 S CRHDNAM=$$GET1^DIQ(200,+CRHDWLED,.01,"E")
49 S CRHDWLED=$$TITLE^XLFSTR($P(CRHDNAM,",",1))_","_$E($P(CRHDNAM,",",2),1)
50 S CRHDRTN(1)=CRHDCT_"^"_$$FMTE^XLFDT(CRHDLEDI,2)_"^"_CRHDWLED
51 Q
52 I DIWF="R" D
53 .S CRHDMN=0
54 .F S CRHDMN=$O(@CRHDROOT@("TEXT",CRHDMN)) Q:'CRHDMN S CRHDX=@CRHDROOT@("TEXT",CRHDMN,0) S:CRHDX="" CRHDX=" " D ^DIWP ;M TMP=^UTILITY($J,"W")
55 .M CRHDTMP=^UTILITY($J,"W") D ^DIWW K ^UTILITY($J,"W")
56 Q
57B2 ;
58 S CRHDMN=0
59 F S CRHDMN=$O(@CRHDROOT@("TEXT",CRHDMN)) Q:'CRHDMN S CRHDX=@CRHDROOT@("TEXT",CRHDMN,0) D
60 .S CRHDFG2=0
61 .S CRHDMN2=CRHDMN F S CRHDMN2=$O(@CRHDROOT@("TEXT",CRHDMN2)) Q:'CRHDMN2!(CRHDFG2) D
62 ..S CRHDX1=@CRHDROOT@("TEXT",CRHDMN2,0)
63 ..I ($E(CRHDX1,1,3)?1N1". ")!($E(CRHDX1,1,3)?1N1") ")!($E(CRHDX1,1,4)?2N1". ")!($E(CRHDX1,1,4)?2N1") ") I CRHDX'="" D DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT) S CRHDFG2=1,CRHDMN=CRHDMN2-1,CRHDX1="" Q
64 ..E D
65 ...I ($L(CRHDX)+$L(CRHDX1))>256 D DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT) S CRHDLL=999,CRHDLL=$O(CRHDTMP(1,CRHDLL),-1) I $L(CRHDTMP(1,CRHDLL,0))<CRHDLEN S CRHDX=CRHDTMP(1,CRHDLL,0) K CRHDTMP(1,CRHDLL,0) S CRHDCT=CRHDCT-1
66 ...S:CRHDX="" CRHDX=" " S CRHDX=CRHDX_CRHDX1 I ($E(CRHDX,$L(CRHDX)-2,$L(CRHDX))[".")!($E(CRHDX,$L(CRHDX)-2,$L(CRHDX))["?") D DIWP(.CRHDTMP,CRHDX,CRHDLEN,.CRHDCT) S CRHDMN=CRHDMN2,CRHDFG2=1 S CRHDX=""
67 Q
68DIWP(CRHDRN,CRHDSTR,CRHDL,CRHDN) ;
69 N CRHDX,CRHDFG
70 ;CRHDRN : Array to return data
71 ;CRHDSTR: String to manipulate
72 ;CRHDL : Length to return
73 ;CRHDN : Next number to use in array
74 I $L(CRHDSTR)<CRHDL S CRHDRN(1,CRHDN,0)=CRHDSTR,CRHDN=CRHDN+1 Q
75 F Q:'$L(CRHDSTR) D
76 .S CRHDFG=0
77 .S CRHDX=$E(CRHDSTR,1,CRHDL)
78 .I $L(CRHDX)<CRHDL S CRHDRN(1,CRHDN,0)=CRHDX,CRHDSTR="",CRHDN=CRHDN+1 Q
79 .F Q:CRHDFG S:$E(CRHDX,$L(CRHDX))=" "!($E(CRHDSTR,$L(CRHDX)+1)=" ") CRHDFG=1 S:'CRHDFG CRHDX=$E(CRHDX,1,$L(CRHDX)-1)
80 .S CRHDRN(1,CRHDN,0)=CRHDX,CRHDSTR=$E(CRHDSTR,$L(CRHDX)+1,$L(CRHDSTR)),CRHDN=CRHDN+1
81 Q
82PRIV(CRHDUSR,CRHDFN,CRHDMN) ;returns 1 if note is private, viewable only to the author; 0 anyone on the authors team or treating specialty or attending can view
83 N CRHDPRIV
84 S CRHDPRIV=0
85 I CRHDUSR'=$P($G(@CRHDTRG@(CRHDFN,1,CRHDMN,0)),"^",2) D
86 . I +$P(@CRHDTRG@(CRHDFN,1,CRHDMN,0),"^",6) S CRHDPRIV=1
87 Q CRHDPRIV
88GETPTLST(CRHDPATL,CRHDTML) ;
89 N CRHDSTG
90 S CRHDSTG="DFN^NAME^SSN^DOB^AGE^SEX"
91 I $G(CRHDTML)'="" D
92 .S CRHDLSTT=$$UP^XLFSTR($P(CRHDTML,"^",3))
93 .I CRHDLSTT="P"!(CRHDTML["^TEAM") D TEAM(+CRHDTML)
94 .I CRHDLSTT="TEAM" D TEAM(+CRHDTML)
95 .I CRHDLSTT="SPECIALTY" D SPECPTS(+CRHDTML)
96 .I CRHDLSTT="PATLIST"!(CRHDTML["PATLIST") D DEFPATL()
97 .I CRHDLSTT="WARD" D WARD(+CRHDTML)
98 .I CRHDLSTT="PROVIDER"!(CRHDTML["PROVIDER") D PROV(+CRHDTML)
99 I $G(CRHDTML)="" D DEFPATL()
100 Q
101LISTINPT(Y,CRHDFRM,CRHDDIR) ; Return a bolus of patient names. From is either Name or IEN^Name.
102 N CRHDI2,CRHDIEN,CRHDCNT,CRHDFROM,CRHDORID,CRHDPM
103 S CRHDCNT=44,CRHDI2=0,CRHDFROM=0
104 S CRHDPM=0
105 F S CRHDPM=$O(^DPT("ACA",CRHDPM)) Q:'CRHDPM S CRHDIEN=0 F S CRHDIEN=$O(^DPT("ACA",CRHDPM,CRHDIEN)) Q:'CRHDIEN S:$P($G(^DPT(+CRHDIEN,0)),"^",1)'="" ^TMP("CRHDACA",$J,$P(^DPT(+CRHDIEN,0),"^",1),CRHDIEN)=""
106 I $D(^TMP("CRHDACA",$J)) D
107 . I $P(CRHDFRM,U,2)'="" S CRHDFROM=$P(CRHDFRM,U,1),CRHDFRM=$O(^TMP("CRHDACA",$J,$P(CRHDFRM,U,2)),-CRHDDIR)
108 . F S CRHDFRM=$O(^TMP("CRHDACA",$J,CRHDFRM),CRHDDIR) Q:CRHDFRM="" D Q:CRHDI2=CRHDCNT
109 . . S CRHDIEN=CRHDFROM,CRHDFROM=0 F S CRHDIEN=$O(^TMP("CRHDACA",$J,CRHDFRM,CRHDIEN)) Q:'CRHDIEN D Q:CRHDI2=CRHDCNT
110 . . . S CRHDORID=""
111 . . . S CRHDORID=$G(^DPT(CRHDIEN,0)) ; Get zero node name.
112 . . . ; S CRHDX1=$G(^DPT(CRHDIEN,.1))_" "_$G(^DPT(CRHDIEN,.101))
113 . . . S CRHDI2=CRHDI2+1 S Y(CRHDI2)=CRHDIEN_U_CRHDFRM_U_U_U_U_$P(CRHDORID,U) ;_"^"_CRHDX ; _"^"_CRHDX1 ;" ("_X_")"
114 Q
115ISINPT(CRHDDFN) ;is patient an inpatient
116 Q:'CRHDDFN ""
117 Q +$G(^DPT(+CRHDDFN,.105))
118 ;
119PERLIST(DUZ) ;
120 K CRHDPATL
121 D PERSLST^CRHDPL(.CRHDPATL,DUZ) ;get personal lists
122 Q
123DEFPATL() ;
124 K CRHDPATL
125 D DEFPAT^CRHDPL(.CRHDPATL,DUZ) ;get default patient list
126 Q
127TEAM(CRHDTM) ;
128 K CRHDPATL
129 D TEAM^CRHDPL(.CRHDPATL,.CRHDTM,0) ;get patient list
130 Q
131SPECPTS(CRHDSPEC) ;
132 K CRHDPATL
133 D SPECPTS^CRHDPL(.CRHDPATL,CRHDSPEC) ;get specialty list
134 Q
135WARD(CRHDWRD) ;
136 K CRHDPATL
137 D WARD^CRHDPL(.CRHDPATL,.CRHDWRD) ;get ward list
138 Q
139PROV(CRHDPRV) ;
140 K CRHDPATL
141 D PROV^CRHDPL(.CRHDPATL,.CRHDPRV) ;get provider list
142 Q
Note: See TracBrowser for help on using the repository browser.