- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN1.m
r613 r623 1 TIUPRPN1 ;SLC/JER - Print SF 509-Progress Notes ;11/23/072 ;;1.0;TEXT INTEGRATION UTILITIES;**45,52,87,100,162,182,211,222,234**;Jun 20, 1997;Build 6 3 4 PRINT(TIUFLAG,TIUSPG) 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 REPORT(TIUROOT,TIUFOOT,TIUMISC,TIUCONT,TIUIDEND) 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 S TITLE=@TIUROOT@(.01,"E"),LOINCNM=@TIUROOT@(89261,"E")74 75 76 77 78 79 80 81 82 83 84 I SUBJ]"" W !,"SUBJECT: ",^("E"),! ; @TIUROOT@(1701,"E") 85 86 87 88 89 90 91 ..W !,^(TIUI,0) ; @TIUROOT@("PROBLEM",TIUI,0) 92 93 94 95 96 97 98 99 100 101 102 103 104 105 ADDENDA 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 IDKIDS(TIUROOT,TIUFOOT,TIUMISC,TIUCONT1,TIUCONT) 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 GETSIG(TIUROOT,TIUSIG) 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 SETCONT(TIUFOOT,TIUMISC,TIUCONT1,TIUHEAD,TIUROOT) 177 178 179 180 1 TIUPRPN1 ;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) 4 PRINT(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 ; 53 REPORT(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 105 ADDENDA ; 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 ; 131 IDKIDS(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 ; 149 GETSIG(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 ; 176 SETCONT(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 TracChangeset
for help on using the changeset viewer.
