source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN1.m@ 1071

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1TIUPRPN1 ;SLC/JER - Print SF 509-Progress Notes ;10/5/04
2 ;;1.0;TEXT INTEGRATION UTILITIES;**45,52,87,100,162,182,211,222**;Jun 20, 1997
3 ; DBIA 908 ^SC(D0,0)
4PRINT(TIUFLAG,TIUSPG) ; Print Document
5 ; ^TMP("TIUPR",$J) is array of records to be printed
6 ; TIUFLAG=1 --> Chart Copy TIUSPG=1 --> Contiguous
7 ; TIUFLAG=0 --> Work Copy TIUSPG=0 --> Fresh Page- each note
8 ; TIUCONT=1 --> Continue printing
9 ; TIUCONT1=1 --> Write "Continue to next/from previous-page" msgs
10 ; TIUPFNBR ---> Print Form # like vice 509
11 ; TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA
12 N CONT,TIUASK,TIUI,TIUJ,TIUKID,TIUPAGE,TIUFOOT,TIUK,TIUDA,TIUCONT,TIUPGRP,TIUTYP
13 N TIUPFHDR,TIUPFNBR,TIUMISC,TIUCONT1,TIUIDONE,TMP
14 S TIUFLAG=+$G(TIUFLAG),TIUSPG=+$G(TIUSPG)
15 S (CONT,TIUCONT)=1,(TIUASK,TIUCONT1)=0
16 S TIUI=0 F S TIUI=$O(^TMP("TIUPR",$J,TIUI)) Q:TIUI="" D Q:'TIUCONT
17 . N DFN,TIU
18 . ; -- P182 TIUI has form PGRP$PFHDR;DFN with PGRP possibly 0, and
19 . ; PFHDR possibly null (see TIURA):
20 . S TIUPGRP=+$P(TIUI,"$"),TIUPFHDR=$P($P(TIUI,";"),"$",2)
21 . I TIUPFHDR']"" S TIUPFHDR="Progress Notes"
22 . S DFN=$P(TIUI,";",2)
23 . I $G(TIUPGRP)>2 S TIUSPG=0
24 . D PATPN^TIULV(.TIUFOOT,DFN)
25 . I +$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1)
26 . ; Use TIUJ="" (not TIUJ=0), to print "complete" notes w/o sigdt:
27 . S TIUJ="" F S TIUJ=$O(^TMP("TIUPR",$J,TIUI,TIUJ)) Q:TIUJ="" D Q:'TIUCONT
28 . . S TIUK=0 F S TIUK=$O(^TMP("TIUPR",$J,TIUI,TIUJ,TIUK)) Q:'TIUK D Q:'TIUCONT
29 . . . S TIUCONT1=0 S TIUPFNBR=^TMP("TIUPR",$J,TIUI,TIUJ,TIUK)
30 . . . ; Note: TIUPFNBR may be null
31 . . . ;P182 Set TIUMISC BEFORE quitting if deleted
32 . . . S TIUDA=TIUK,TIUMISC=TIUFLAG_U_TIUPFNBR_U_TIUDA
33 . . . ; Quit docmt if deleted:
34 . . . I '$D(^TIU(8925,+TIUDA,0)) D Q
35 . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
36 . . . . W !!,"NOTE DATED:",!,"Document #",TIUDA," for ",$G(TIUFOOT("PNMP")),!,"no longer exists in the TIU DOCUMENT file.",!!!
37 . . . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT))
38 . . . N TIUROOT
39 . . . I '+$G(TIUSPG) D HEADER^TIUPRPN2(.TIUFOOT,TIUFLAG,.TIUPFHDR,TIUCONT1)
40 . . . K ^TMP("TIULQ",$J)
41 . . . D EXTRACT^TIULQ(+TIUDA,"^TMP(""TIULQ"",$J)",.TIUERR,"","",1)
42 . . . I +$G(TIUERR) W !,$P(TIUERR,U,2) Q
43 . . . Q:'$D(^TMP("TIULQ",$J))
44 . . . S TIUROOT="^TMP(""TIULQ"",$J,"_TIUDA_")"
45 . . . D REPORT(TIUROOT,.TIUFOOT,TIUMISC,.TIUCONT) Q:'TIUCONT
46 . . . D IDKIDS(TIUROOT,.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT) Q:'TIUCONT
47 . . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT))
48 . Q:'TIUCONT
49 . I $E(IOST,1,2)="C-" S TIUCONT=$$STOP^TIUPRPN2() Q:'TIUCONT
50 . I '+$G(TIUKID),+$G(TIUSPG),$E(IOST,1,2)'="C-" S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT))
51 Q
52 ;
53REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) ; Report Text
54 ; Requires array TIUFOOT, vars TIUMISC, TIUCONT
55 ; Requires TIUROOT =
56 ; ^TMP("TIULQ",$J,NOTEIFN) for parent/stand-alone note, or
57 ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or
58 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN) for ID kid, or
59 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",KIDSEQ#,IDKIDIFN,"ZADD",KIDADDMIFN)
60 ; for ID kid addm.
61 N DIW,DIWF,DIWL,DIWR,DIWT,TIUERR,TIU,TIUI,X,Z,LOC
62 N REFDT,TITLE,LOINCNM,ADT,HLOC,SUBJ
63 N TIUDA,TIUCONT1,HASIDKID,HASIDDAD
64 S TIUDA=$P(TIUMISC,U,3),TIUCONT1=0
65 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
66 S HASIDKID=$G(^TMP("TIULQ",$J,TIUDA,"ZZID",0)) ;how many ID kids
67 S HASIDDAD=$S(TIUROOT["ZZID":1,1:0)
68 I HASIDKID W "<< Interdisciplinary Note - Begin >>",!
69 I HASIDDAD W "<< Interdisciplinary Note - Cont. >>",!
70 W $S('HASIDKID&'HASIDDAD:"NOTE DATED: ",1:"ENTRY DATED: ")
71 S REFDT=@TIUROOT@(1301,"I")
72 W $$DATE^TIULS(REFDT,"MM/DD/CCYY HR:MIN")
73 S TITLE=@TIUROOT@(.01,"E") ; ,LOINCNM=@TIUROOT@(89261,"E")
74 W !,"LOCAL TITLE: ",$$UP^XLFSTR(TITLE),!
75 ; I $L(LOINCNM)>1 W "STANDARD TITLE: ",$$UP^XLFSTR(LOINCNM),!
76 S LOC=$G(@TIUROOT@(1205,"I"))
77 I +LOC D
78 . W $S($P(^SC(LOC,0),U,3)="W":"ADMITTED: ",1:"VISIT: ")
79 . S ADT=$G(@TIUROOT@(.07,"I"))
80 . W $$DATE^TIULS(ADT,"MM/DD/CCYY HR:MIN")
81 . S HLOC=$G(@TIUROOT@(1205,"E"))
82 . W " ",HLOC
83 S SUBJ=$G(@TIUROOT@(1701,"E"))
84 I SUBJ]"" W !,"SUBJECT: ",^("E"),!
85 S TIUCONT1=1
86 I $D(@TIUROOT@("PROBLEM")) D Q:'TIUCONT
87 . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
88 . W !,"ASSOCIATED PROBLEMS:"
89 . N TIUI S TIUI=0
90 . F S TIUI=$O(@TIUROOT@("PROBLEM",TIUI)) Q:'TIUI D Q:'TIUCONT
91 ..W !,^(TIUI,0)
92 ..S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
93 W !
94 S TIUI=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
95 F S TIUI=$O(@TIUROOT@("TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT ; D ^DIWW
96 . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
97 . S X=@TIUROOT@("TEXT",TIUI,0) S:X="" X=" " D ^DIWP
98 D ^DIWW K ^UTILITY($J,"W")
99 Q:'TIUCONT
100 D GETSIG(TIUROOT,.TIUSIG)
101 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
102 W !
103 D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUROOT)
104 Q:'TIUCONT
105ADDENDA ; Fall through and do Addenda of docmt TIUDA
106 N DIW,DIWF,DIWL,DIWR,DIWT,X,Z,TIUI,TIUADD,ADDMRDT
107 S TIUADD=0,DIWF="WN",DIWL=1,DIWR=79 K ^UTILITY($J,"W")
108 F S TIUADD=$O(@TIUROOT@("ZADD",TIUADD)) Q:TIUADD'>0 D Q:'TIUCONT
109 . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
110 . S ADDMRDT=@TIUROOT@("ZADD",TIUADD,1301,"I")
111 . W !!,$$DATE^TIULS(ADDMRDT,"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
112 . W ?39,"STATUS: ",@TIUROOT@("ZADD",TIUADD,.05,"E") ;P162
113 . S TIUI=0
114 . F S TIUI=$O(@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI)) Q:TIUI'>0 D Q:'TIUCONT
115 . . S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
116 . . S X=@TIUROOT@("ZADD",TIUADD,"TEXT",TIUI,0) S:X="" X=" " D ^DIWP
117 . D ^DIWW
118 . Q:'TIUCONT
119 . N TIUADRT
120 . S TIUADRT=$P(TIUROOT,")")_",""ZADD"","_TIUADD_")"
121 . D GETSIG(TIUADRT,.TIUSIG)
122 . D SIGBLK^TIUPRPN8(.TIUFOOT,TIUMISC,TIUCONT1,.TIUCONT,.TIUSIG,TIUADRT)
123 ; Need ! in front for amended notes:
124 I $G(TIUIDEND) W !,"<< Interdisciplinary Note - End >>",!
125 K ^UTILITY($J,"W")
126 ; Write 2 linefeeds between records
127 S:$E(IOST,1,2)="C-" TIUCONT=$$STOP^TIUFLP1,TIUASK=1
128 W:TIUCONT !!
129 Q
130 ;
131IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) ; Print ID kids
132 ;of docmt TIUDA (each kid does its own addenda)
133 N TIUL,KIDDA,TIUDA,TIUSORT,TIUIDRT,TIUIDEND
134 S TIUDA=$P(TIUMISC,U,3),TIUIDEND=0
135 S TIUL=0
136 F S TIUL=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) Q:'TIUL D Q:'TIUCONT
137 . S KIDDA=$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL,0))
138 . I +$$MEMBEROF^TIUPR222(+$G(^TIU(8925,+KIDDA,0)),"FORM LETTERS") D Q ; hand off to TIUFLP1 (Form Letter Print)
139 . . I '+$G(TIUKID),'+$G(TIUSPG) S TIUCONT1=0 S TIUCONT=$$SETCONT(.TIUFOOT,TIUMISC,TIUCONT1,1,$G(TIUROOT))
140 . . I 'TIUCONT!'CONT Q
141 . . I $E(IOST,1,2)="C-",'+TIUASK S CONT=$$STOP^TIUFLP1,TIUCONT=CONT Q:'+CONT
142 . . S TIUASK=0,TIUKID=1 D IDKID^TIUFLP1(TIUDA,KIDDA)
143 . S TIUMISC=TIUFLAG_U_TIUPFNBR_U_KIDDA
144 . S TIUIDRT="^TMP(""TIULQ"",$J,"_TIUDA_",""ZZID"","_TIUL_","_KIDDA_")"
145 . I '$O(^TMP("TIULQ",$J,TIUDA,"ZZID",TIUL)) S TIUIDEND=1
146 . D REPORT(TIUIDRT,.TIUFOOT,TIUMISC,.TIUCONT,TIUIDEND)
147 Q
148 ;
149GETSIG(TIUROOT,TIUSIG) ; Get signature info from TIULQ global;
150 ; Set info into TIUSIG array **100**
151 ; Requires array name TIUROOT; passes back array TIUSIG
152 ; TIUROOT = ^TMP("TIULQ",$J,NOTEIFN) for parent note, or
153 ; ^TMP("TIULQ",$J,NOTEIFN,"ZADD",ADDMIFN) for addendum, or
154 ; ^TMP("TIULQ",$J,NOTEIFN,"ZZID",IDKIDIFN) for ID kid.
155 ; Signature should be on bottom of form, Addenda on Subsequent pages
156 N TIULINE S $P(TIULINE,"-",81)=""
157 S TIUSIG("AUTHOR")=$G(@TIUROOT@(1202,"I"))_";"_$G(^("E"))
158 S TIUSIG("EXPSIGNR")=$G(@TIUROOT@(1204,"I"))_";"_$G(^("E"))
159 S TIUSIG("EXPCOSNR")=$G(@TIUROOT@(1208,"I"))_";"_$G(^("E"))
160 S TIUSIG("SIGNDATE")=$G(@TIUROOT@(1501,"I"))
161 S TIUSIG("SIGNEDBY")=$G(@TIUROOT@(1502,"I"))_";"_$G(^("E"))
162 S TIUSIG("SIGNNAME")=$G(@TIUROOT@(1503,"E"))
163 S TIUSIG("SIGTITL")=$G(@TIUROOT@(1504,"E"))
164 S TIUSIG("SIGNMODE")=$G(@TIUROOT@(1505,"I"))_";"_$G(^("E"))
165 S TIUSIG("COSGDATE")=$G(@TIUROOT@(1507,"I"))
166 S TIUSIG("COSGEDBY")=$G(@TIUROOT@(1508,"I"))_";"_$G(^("E"))
167 S TIUSIG("COSGNAME")=$G(@TIUROOT@(1509,"E"))
168 S TIUSIG("COSGTITL")=$G(@TIUROOT@(1510,"E"))
169 S TIUSIG("COSGMODE")=$G(@TIUROOT@(1511,"I"))_";"_$G(^("E"))
170 S TIUSIG("SIGCHRT")=$G(@TIUROOT@(1512,"I"))_";"_$G(^("E"))
171 S TIUSIG("COSCHRT")=$G(@TIUROOT@(1513,"I"))_";"_$G(^("E"))
172 ; -- P182 Set Admin Clos Date:
173 S TIUSIG("ADMINCDT")=$G(@TIUROOT@(1606,"I"))_";"_$G(^("E"))
174 Q
175 ;
176SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT) ;Does footer
177 ;and returns TIUCONT
178 ; Requires array TIUFOOT, vars TIUMISC,TIUCONT1; optional TIUHEAD
179 ; Optional TIUROOT
180 Q $$FOOTER^TIUPRPN2(.TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,$G(TIUROOT))
Note: See TracBrowser for help on using the repository browser.