source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m@ 1800

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

revised back to 6/30/08 version

File size: 7.6 KB
RevLine 
[623]1RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04 11:49
2 ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66**;Mar 16, 1998
3 ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology
4 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
5 ; This routine uses the following IA:
6 ; #4793 - ^WVRALINK (private)
7FILE ;Create Entry in File 74 and File Data
8 I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere"
9 I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2"
10 N RADATIME S RADATIME=$$NOW^XLFDT() I $L($P(RADATIME,".",2))>4 S RADATIME=$P(RADATIME,".",1)_"."_$E($P(RADATIME,".",2),1,4) S RADATIME=+RADATIME
11 S RADPIECE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"")
12 N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR
13 D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET
14 ; If rpt (either stub or real) exists, skip creating a new file 74 entry
15 I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D FILETST^RAHLO4 Q:$D(RAERR) D S RARPT=RASAV K RASAV G LOCK1
16 . ; must save off RARPT, RAVERF and other RA* variables because
17 . ; they are being killed off somewhere in the 'Unverify A Report'
18 . ; option.
19 . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF
20 . ; if report isn't a stub report, then consider it being edited
21 . S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1
22 . I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),"^",5)="V") D Q ; edit on current record (for activity log)
23 .. D UNVER^RARTE1(RARPT)
24 .. Q
25 . K ^RARPT(RARPT,"I"),^("R"),^("H")
26 . Q
27 I RAPRTSET L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 S RAERR="ANOTHER USER IS CURRENTLY EDITING THIS PRINTSET. TRY LATER." D KVAR Q
28NEW1 S I=$P(^RARPT(0),"^",3)
29LOCK S I=I+1 L +^RARPT(I):1 I '$T!($D(^RARPT(I)))!($D(^RARPT("B",I))) L -^RARPT(I) G LOCK
30 S ^RARPT(I,0)=RALONGCN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1)
31 ;if case is member of a print set, then create sub-recs for file #74
32 G:'RAPRTSET LOCK1
33 I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN
34 N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT()
35 I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI) D KVAR Q ;unlck & clear vars
36LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X
37 K DA,DIE,DQ,DR S DA=RARPT,DIE="^RARPT("
38 S DR="5////"_RARPTSTS ; rpt status
39 ;Verifier & Verified date will be set if RAVERF exists for new
40 ;reports, edits, and addendums. Date rpt entered and reported date
41 ;will be set for new reports, and not reset for edits and addendums
42 S DR=DR_";6////"_$S($D(RAEDIT):"",1:RADATIME) ; date/time rpt entered
43 S DR=DR_";7////"_$S($G(RAVERF)&(RARPTSTS="V"):RADATIME,1:"") ; v'fied date/time
44 S DR=DR_";8////"_$S($D(RAEDIT):"",1:RADATE) ; reported date
45 S DR=DR_";9////"_$S($G(RAVERF)&(RARPTSTS="V"):RAVERF,1:"") ; v'fying phys
46 S DR=DR_";11////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist
47 I $G(RAVERF),(RARPTSTS="V") S DR=DR_";17////"_$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) ;status changed to 'verified' by
48 ; D ^DIE K DA,DR ;BNT- Moved the DIE call down three lines due to a
49 ; problem found at Indy while testing PowerScribe. Site was doing a
50 ; local MUMPS cross reference on one of the nodes that are set below.
51 S $P(^RARPT(RARPT,0),"^",2)=RADFN,$P(^(0),"^",3)=(9999999.9999-RADTI),$P(^(0),"^",4)=$P(RALONGCN,"-",2) ;must set manually due uneditable
52 S $P(^RARPT(RARPT,0),"^",10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ; hard set because Elec Sig Code may contain a semi-colon which causes errors in DIE
53 D ^DIE K DA,DR
54 ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line
55 I $D(RADX) D
56 . K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN
57 . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
58 . S DR="13////"_RADX D ^DIE K DIE,DA,DR
59 . S:$P(^RA(78.3,+RADX,0),"^",4)="y" RAAB=1
60 . Q
61 ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
62 I $D(RASECDX) D
63 . N RAX S RAX=0
64 . F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D
65 .. S:$P(^RA(78.3,+RAX,0),"^",4)="y" RAAB=1
66 ;
67 I '$D(RADENDUM)#2,($G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))!$G(^("RARESIDENT"))) D
68 . K DIE,DA S DR=""
69 . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) I $D(^VA(200,"ARC","R",RAPRIMAR)) S DR="12////"_RAPRIMAR
70 . S RAPRIMAR=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) I $D(^VA(200,"ARC","S",RAPRIMAR)) S DR=$S(DR]"":DR_";",1:"")_"15////"_RAPRIMAR
71 . Q:'$G(DR)
72 . S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN
73 . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
74 . D ^DIE K DIE,DA,DR
75 . Q
76 ;
77 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT I $G(RADPIECE),$P(^(0),"^",RADPIECE)="",('$D(RADENDUM)#2) D SETPHYS^RAHLO4
78 ; file impression text if present & not an addendum
79 I '$D(RADENDUM) D
80 . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"I",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I))
81 . S:J ^RARPT(RARPT,"I",0)="^^"_J_"^"_J_"^"_RADATE
82 . Q
83 ; file report text if present & not an addendum
84 I '$D(RADENDUM) D
85 . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"R",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RATXT",I))
86 . S:J ^RARPT(RARPT,"R",0)="^^"_J_"^"_J_"^"_RADATE
87 . Q
88 ; if addendum, add addendum text to impression or report
89 I $D(RADENDUM),($O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))!$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0))) D ADENDUM^RAHLO2 ; store new lines at the end of existing text
90 ;
91 ;
92 ; Check for History from Dictation
93 ; If history sent, check if previous history exists. If previous
94 ; history then current history will follow adding 'Addendum:' before
95 ; the text.
96 I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D
97 . S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1
98 . S RANEW=$S(RACNT>0:0,1:1)
99 . S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0 D
100 . . S RACNT=RACNT+1
101 . . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I))
102 . . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:'
103 . . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1
104 . . S ^RARPT(RARPT,"H",RACNT,0)=RALN
105 . . Q
106 . S ^RARPT(RARPT,"H",0)="^^"_RACNT_"^"_RACNT_"^"_RADATE
107 . Q
108 ;
109 ;
110 I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health
111 G:'RAPRTSET UPACT ; the next section is for printsets only
112 ; copy DX (prim & sec), Prim Resid, Prim Staff
113 N RACNISAV,RA7
114 N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer
115 S RACNISAV=RACNI,RA7=0
116 S RA13=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13),RA12=$P(^(0),U,12),RA15=$P(^(0),U,15)
117 F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX),('$D(RADENDUM)#2) D SECDX^RAHLO2
118 S RACNI=RACNISAV
119 L -^RADPT(RADFN,"DT",RADTI) ;unlock after pce 17 is set in all cases of this printset
120 ;Update Activity Log
121UPACT S DA=RARPT,DIE="^RARPT(",DR="100///""NOW""",DR(2,74.01)="2////"_$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")_";3////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") D ^DIE K DA,DR,DE,DQ,DIE
122 ; use ix^dik to kill before setting xrefs
123 S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK
124 ; if verfd, update rpt & exam statuses; else, just update exam status
125 I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1
126 L -^RARPT(RARPT) D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message
127 ; line pacs is for 2 tasks: hl7 msg'g & voice verified rpt printout
128PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4
129KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RARPT,RAHIST
130 Q
Note: See TracBrowser for help on using the repository browser.