source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN3.m@ 1753

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

initial load of WorldVistAEHR

File size: 7.2 KB
Line 
1TIUPRPN3 ;SLC/MJC-Sort PNs for Prting;;6/26/01
2 ;;1.0;TEXT INTEGRATION UTILITIES;**100,121**;Jun 20, 1997
3 ;
4SETUP(TITLE) ;displays centered option hdr
5 N TIULINE
6 S $P(TIULINE,"-",80)=""
7 W @IOF,!!?(IOM-$L(TITLE)\2),TITLE,!,TIULINE,!
8 Q
9PT ;sorts PNs to prt by pt for selected date range
10 ;these notes are chartable either contiguous or separate pgs
11 ;[TIU PRINT PN PT]
12 ;
13 N TIUDFN,TIUQT,DIC,Y,TIUXREF,CTR1
14 D SETUP("Print Progress Notes for a Selected PATIENT")
15 F W ! S DIC=2,DIC(0)="AEQMN" D ^DIC Q:Y<0 D K TIUQT
16 .N TIUFLAG,TIUSPG
17 .S CTR1=0,TIUDFN=Y,TIUXREF="APTP" ;pt/pt x-ref
18 .D FETCH(TIUXREF,TIUDFN,.CTR1) Q:$D(TIUQT)
19 .S TIUFLAG=$$FLAG() Q:TIUFLAG']""
20 .I +$G(TIUFLAG),CTR1>1 S TIUSPG=$$PAGE Q:TIUSPG']""
21 .S TIUSPG=$S(+$G(TIUSPG):0,1:1)
22 .D DEVICE^TIUPRPN(TIUFLAG,TIUSPG)
23 Q
24 ;
25AUTHOR ;sorts PNs to prt by author for selected date range
26 ;these guys are only chartable if prted on separate pages
27 ;[TIU PRINT PN AUTHOR]
28 ;
29 N TIUDUZ,TIUQT,DIC,Y,TIUXREF
30 D SETUP("Print Progress Notes for a Selected AUTHOR")
31 S DIC=200,DIC(0)="AEQMN",DIC("A")="AUTHOR: "
32 F W ! D ^DIC Q:Y<0 D K TIUQT
33 .N TIUFLAG,TIUSPG
34 .S TIUDUZ=Y,TIUXREF="AAUP" ;author/author x-ref
35 .D FETCH(TIUXREF,TIUDUZ) Q:$D(TIUQT)
36 .S TIUFLAG=$$FLAG() Q:TIUFLAG']""
37 .S TIUSPG=$S(+$G(TIUFLAG):0,1:1)
38 .D DEVICE^TIUPRPN(TIUFLAG,TIUSPG)
39 Q
40 ;
41LOC ;sorts PNs to prt by location for selected date range
42 ;they are only chartable if prted on separate pages
43 ;[TIU PRINT PN LOC]
44 ;
45 N TIUDUZ,TIUQT,DIC,Y,TIUXREF
46 D SETUP("Print Progress Notes for a Selected LOCATION")
47 S DIC=44,DIC(0)="AEQMN"
48 F W ! D ^DIC Q:Y<0 D K TIUQT
49 .N TIUFLAG,TIUSPG
50 .S TIULOC=Y,TIUXREF="ALOCP" ;location/location x-ref
51 .D FETCH(TIUXREF,TIULOC) Q:$D(TIUQT)
52 .S TIUFLAG=$$FLAG() Q:TIUFLAG']""
53 .S TIUSPG=$S(+$G(TIUFLAG):0,1:1)
54 .D DEVICE^TIUPRPN(TIUFLAG,TIUSPG)
55 Q
56 ;
57FETCH(TIUXREF,ENTITY,CTR1) ;get available notes, select date range
58 ; Passes back optional CTR1 = # of notes
59 N OLD,NEW,BEG,END,HOLD,SORT,DFN,IFN,Y,DATE
60 S OLD=0 S OLD=$O(^TIU(8925,TIUXREF,+ENTITY,OLD))
61 I 'OLD D S TIUQT=1 Q
62 .W !!,$C(7),"No signed notes available for "_$P(ENTITY,U,2),!
63 S OLD=$O(^TIU(8925,TIUXREF,+ENTITY,0))
64 S NEW=$O(^TIU(8925,TIUXREF,+ENTITY,9999999),-1)
65 W !!,"Available note",$S(OLD'=NEW:"s",1:""),": "
66 W $$FMTE^XLFDT(OLD,"D")
67 I OLD'=NEW W " thru ",$$FMTE^XLFDT(NEW,"D")
68FISH I OLD=NEW S (BEG,END)=$E(OLD,1,7)
69 E D W ! K %DT G:$D(TIUQT) FETCHX
70 .S %DT="AEPTX",%DT(0)="-NOW",%DT("A")="Print Notes Beginning: "
71 .D ^%DT I $D(DTOUT)!(Y<0) S TIUQT=1 Q
72 .S BEG=Y,%DT("A")=" Thru: "
73 .S %DT="AEPTX" D ^%DT I $D(DTOUT)!(Y<0) S TIUQT=1 Q
74 .S END=Y I END<BEG S HOLD=BEG,BEG=END,END=HOLD
75 ; load up the notes
76 W !!,"Searching for the notes"
77 K ^TMP("TIUPR",$J),^TMP("TIUREPLACE",$J)
78 S DATE=BEG,END=END+.9999999
79 F S DATE=$O(^TIU(8925,TIUXREF,+ENTITY,DATE)) Q:'DATE!(DATE>END) D
80 .S IFN=0 F S IFN=$O(^TIU(8925,TIUXREF,+ENTITY,DATE,IFN)) Q:'IFN D
81 ..W "." D REPLACE(IFN,DATE,1501)
82 S IFN=0 F S IFN=$O(^TMP("TIUREPLACE",$J,IFN)) Q:'IFN Q:'^TMP("TIUREPLACE",$J,IFN) D
83 .S DFN=$P(^TIU(8925,IFN,0),U,2),SORT=$P(^DPT(DFN,0),U)_";"_DFN
84 .S DATE=^TMP("TIUREPLACE",$J,IFN,"DT")
85 .S ^TMP("TIUPR",$J,SORT,DATE,IFN)="Vice SF 509"
86 I '$D(^TMP("TIUPR",$J)) W !!,"No notes found- try again!",! G FISH
87 S CTR1=+$G(^TMP("TIUREPLACE",$J))
88 W !,">> "_CTR1_" note"_$S(CTR1>1:"s",1:"")_" found for "_$P(ENTITY,U,2)
89FETCHX ;
90 K ^TMP("TIUREPLACE",$J)
91 Q
92 ;
93REPLACE(TIUDA,DATTIM,DTFIELD,CKCANVW) ; Populate TMP array
94 ;w record received, replacing ID kids or addenda with their parents.
95 ; Requires TIUDA.
96 ; Sets ^TMP("TIUREPLACE",$J,IFN)=1 or 1^TIUDA, or 0,
97 ;where IFN is TIUDA or its ID parent.
98 ; If TIUDA is replaced by its parent, then
99 ;^TMP("TIUREPLACE",$J,IFN)=1^TIUDA,
100 ;to know what child the parent was included in the list for.
101 ; If CKCANVW = 1 is received, code checks CAN VIEW before
102 ;setting TMP array.
103 ; Sets ^TMP("TIUREPLACE",$J) = # of [viewable] elements in array
104 ; Optional DATTIM =
105 ; Signature date/time of record, NOT inverse, if DTFIELD = 1501
106 ; Reference date/time of record, inverse, if DTFIELD = 1301
107 ;If DATTIM received=non null, sets
108 ; ^TMP("TIUREPLACE",$J,IFN,"DT")=DATTIM
109 ; Optional DTFIELD = 1501 or 1301; default = 1501
110 ; 1/11/01 cf REPLACE^TIUSRVLL.
111 N IDPRNT,PDATTIM,DTNODE,PCANDO,CANDO
112 S ^TMP("TIUREPLACE",$J)=+$G(^TMP("TIUREPLACE",$J))
113 S IDPRNT=+$G(^TIU(8925,TIUDA,21)) ; ID parent
114 ; -- If user can't view record, quit and
115 ; if it is parent, track it as already processed
116 ; (but not a 'good' record):
117 I $G(CKCANVW) D Q:'$G(CANDO)
118 . S CANDO=+$$CANDO^TIULP(TIUDA,"VIEW")
119 . I '$G(CANDO),$O(^TIU(8925,"GDAD",TIUDA,0)) S ^TMP("TIUREPLACE",$J,TIUDA)=0
120 S DTNODE=$S($G(DTFIELD)=1301:13,1:15)
121 ; -- If record is child with nonexistent parent,
122 ; treat record as stand-alone:
123 I '$D(^TIU(8925,IDPRNT,0)) S IDPRNT=0
124 ; -- If record is child, & parent already in array
125 ; from previous cycle (viewable or not), just quit:
126 I IDPRNT,$D(^TMP("TIUREPLACE",$J,IDPRNT)) G REPX
127 ; -- If record is child, & parent not viewable,
128 ; track parent as processed but not 'good' & quit:
129 I IDPRNT,$G(CKCANVW) D I '$G(PCANDO) G REPX
130 . S PCANDO=+$$CANDO^TIULP(IDPRNT,"VIEW")
131 . I '$G(PCANDO) S ^TMP("TIUREPLACE",$J,IDPRNT)=0
132 ; -- If record is not child, just put it
133 ; in array and quit: --
134 I 'IDPRNT D G REPX
135 . ; -- If record is already in array as parent from previous cycle
136 . ; (viewable or not), and is now received on its own merit,
137 . ; quit & don't consider it there because of a child:
138 . I $D(^TMP("TIUREPLACE",$J,TIUDA)) S ^TMP("TIUREPLACE",$J,TIUDA)=+^TMP("TIUREPLACE",$J,TIUDA) Q
139 . S ^TMP("TIUREPLACE",$J,TIUDA)=1
140 . I $G(DATTIM)'="" S ^TMP("TIUREPLACE",$J,TIUDA,"DT")=DATTIM
141 . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
142 ; -- If record is child, put its parent in array:
143 I IDPRNT,$G(DATTIM)'="" D
144 . S PDATTIM=+$G(^TIU(8925,IDPRNT,DTNODE))
145 . I PDATTIM,DTNODE=13 S PDATTIM=9999999-PDATTIM
146 I IDPRNT D G REPX
147 . S ^TMP("TIUREPLACE",$J,IDPRNT)=1_U_TIUDA ;parent in array because of child TIUDA
148 . I $G(DATTIM)'="" S ^TMP("TIUREPLACE",$J,IDPRNT,"DT")=PDATTIM
149 . S ^TMP("TIUREPLACE",$J)=$G(^TMP("TIUREPLACE",$J))+1
150REPX Q
151 ;
152FLAG() ;asks question for CHART vs. WORK copies
153 ;returns TIUFLAG=1 if CHART copy - TIUFLAG=0 if WORK copy - NULL if '^'
154 S TIUFLAG=$$READ^TIUU("SA^C:CHART;W:WORK","Do you want WORK copies or CHART copies? ","CHART","^D HELP^TIUPRPN3")
155 I $E(TIUFLAG)="^" S TIUFLAG=""
156 E S TIUFLAG=$S($P(TIUFLAG,U)="C":1,1:0)
157 Q TIUFLAG
158 ;
159PAGE() ;asks question for CONTIGUOUS vs. SEPARATE PAGE print
160 ;returns TIUSPG=0 for CONTIGUOUS - TIUSPG=1 SEPARATE PAGE - NULL if '^'
161 S TIUSPG=$$READ^TIUU("YA","Do you want to start each note on a new page? ","NO","^D HELP1^TIUPRPN3")
162 I $E(TIUSPG)="^" S TIUSPG=""
163 E S TIUSPG=$S(+$G(TIUSPG):1,1:0)
164 Q TIUSPG
165HELP ; answers questions regarding WORK vs. CHART copies
166 W !!?5,"The FOOTERS of WORK/CHART copies vary significantly. The WORK"
167 W !?5,"FOOTER has the patient's phone number and is clearly marked:"
168 W !?5,"'NOT FOR MEDICAL RECORD'. Unless you really intend to file the"
169 W !?5,"note(s) in the chart- print a WORK copy."
170 Q
171HELP1 ; answers the 'ea note on a new page' question
172 W !!?5,"The option selected will produce CHARTABLE contiguous notes."
173 W !?5,"If you are filling in a chart that has handwritten notes, or,"
174 W !?5,"you'd prefer to begin each note on a new page; answer 'YES'."
175 Q
Note: See TracBrowser for help on using the repository browser.