- RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO - Queue/print Reports ; Jun 17, 2024@12:00:07
- ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75,92,99,210,216**;Mar 16, 1998;Build 2
- ;Supported IA #2056 reference to GET1^DIQ
- PRT ; Begin print/build of e-mail message
- ;
- ; ** NOTE: If the layout of this output is changed **
- ; ** please check that routine RAO7PC3 is **
- ; ** not affected. It assumes fixed format of **
- ; ** the following headings: **
- ; ** Clinical History: **
- ; ** Report: **
- ; ** Impression: **
- ; ** Primary Diagnostic Code: **
- ; ** Secondary Diagnostic Codes: **
- ; ** Primary Interpreting Staff: **
- ;
- Q:'$D(^RARPT(+$G(RARPT),0))
- ; Use and Set if running in the foreground and Writing to the device
- I '$D(RAUTOE) D
- . U IO
- . S RAFFLF=IOF
- . S RAORIOF=RAFFLF
- ;
- W:$Y>0&('$D(RAUTOE)) @RAFFLF ; If RAUTOE defined build mail msg
- S X=$G(^RARPT(+$G(RARPT),0)) ; RAORIOF=RAFFLF
- ;
- ;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!")
- D INIT ; setup exam/report variables
- ;p210/KLM - Add Facility Contact Data for FDA mammograpgy requirement
- I '$D(RAUTOE) D
- .N RADIVDA,RACRM S RADIVDA=$P(^RADPT(RADFN,"DT",RADTI,0),U,3)
- .S RACRM=$P($G(^RA(79.1,$P(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,21) ;p216/KLM - data check
- .I $G(RAST)'="EF",(RACRM'=2) D HDRFAC^RARTR0(RADIVDA)
- .Q ;end 210
- ;start p99
- I $$PTSEX^RAUTL8(RADFN)="F",'$D(RAUTOE) D
- .N RA700332,RA700380 S RA700332=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),32)
- .W:RA700332'="" !,"Pregnancy Screen: ",RA700332
- .S RA700380=$$GET1^DIQ(70.03,$G(RACNI)_","_$G(RADTI)_","_$G(RADFN),80)
- .I (RA700332'="Patient answered no"),(RA700380'="") S RA700380="Pregnancy Screen Comment: "_RA700380 D OUTTEXT^RAUTL9(RA700380,"",1,75,"","!","")
- .W !
- ;end of p99
- I RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0) K RAFFLF Q ; data nodes missing
- ;
- PRT1 I $D(RAUTOE) D
- . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
- . I $D(RADDEN) D
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$P($G(^VA(200,$S($G(RADUZ):RADUZ,1:DUZ),0)),"^")
- .. Q
- . Q
- I +$O(^RARPT(RARPT,"ERR",0)) D
- . S RAERRFLG="" ; set for future reference (display AMENRPT^RARTR text)
- . W:'$D(RAUTOE) !!?10,$$AMENRPT^RARTR2(),!
- . I $D(RAUTOE) D
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
- .. Q
- . Q
- I $P(RAY3,"^",25)<2 D G END:$D(RAOOUT)
- . D MODS^RAUTL2,OUT1^RARTR3
- . D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT)
- . D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
- . ;W:'$D(RAUTOE) !
- . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- . Q
- I $P(RAY3,"^",25)>1 D
- . D MEMS1^RARTR3
- . W:'$D(RAUTOE) !
- . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- . Q
- G END:$D(RAOOUT)
- ; Check for duplicate history in file 70 and 74.
- D CHKDUPHX^RART1 ; Sets RADUPHX to 1 for duplicate or 0 if different.
- F RAP="H","AH","R","I" K ^UTILITY($J,"W"),^(1) D G END:$D(RAOOUT)
- . S RAP("P")=$S(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:")
- . ; Don't continue if printing Additional Clinical History and it is a
- . ; duplicate of Clinical History.
- . Q:RAP="AH"&(RADUPHX>0)
- . W:'$D(RAUTOE) !?RATAB,RAP("P")
- . I $D(RAUTOE),($D(RADDEN)),(RAP="R") D
- .. N RABAN1,RABAN2,RASPCE S $P(RASPCE," ",46)=""
- .. S RABAN1="*** Uncorrected Version ***"
- .. S RABAN2="*** Refer to final report ***"
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- .. Q
- . S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P")
- . W:$D(RASTFL)&(RAP="R")&('$D(RAUTOE)) ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2))
- . I RAP="R",($D(RAUTOE)) D
- .. S $P(RAP("S")," ",(46-$L(^TMP($J,"RA AUTOE",RAACNT))))=""
- .. I '$D(RADDEN) S ^TMP($J,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),"^",2))
- .. Q
- . D:$D(RAUTOE) SET^RARTR2
- . D:'$D(RAUTOE) WRITE^RARTR2 Q:$D(RAOOUT)
- . K ^UTILITY($J,"W")
- . Q
- I $D(RADDEN),($G(^RARPT(RARPT,"PURGE"))) D
- . ; when the report is unverified and purge data exists (rpt adden)
- . N RAPRGE S RAPRGE=+$G(^RARPT(RARPT,"PURGE"))
- . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P")
- . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- . Q
- I $P($G(^RA(79.1,+$P(RAY2,U,4),0)),U,18)="Y" D PRTDX^RARTR1 G:$D(RAOOUT) END ;print dx codes
- D EN1^RARTR0 G:$D(RAOOUT) END
- I '$D(RAVERFND) D G END:$D(RAOOUT)
- . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL
- . N RADFTSBN,RADFTSBT S:$D(RADDEN) RAVERF=+$P(RA74B4,"^",9)
- . S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25)
- . S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25)
- . S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30)
- . I RADFTSBT']"" S RADFTSBT=$$TITLE^RARTR0(RAVERF)
- . W:'$D(RAUTOE) !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"")
- . W:RADFTSBT]""&('$D(RAUTOE)) ", "_RADFTSBT
- . I $D(RAUTOE) D
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:"
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$S(RADFTSBN]"":RADFTSBN,1:"")_$S(RADFTSBT]"":", "_RADFTSBT,1:"")
- .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- .. Q
- . Q
- K RASBPN,RASBT,RASECIEN,RASECOND,RASECSS
- I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 G END:$D(RAOOUT) D HD:($Y+RAFOOT+4)>IOSL
- W:'$D(RAUTOE) !!,$S($D(^RABTCH(74.2,+RABTCH,0)):$P(^(0),"^"),1:""),"/" I +$G(^RARPT(RARPT,"T")),$D(^VA(200,+$P(^RARPT(RARPT,"T"),"^"),0)) W:'$D(RAUTOE) $P(^(0),"^",2)
- S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$P($G(^RABTCH(74.2,+RABTCH,0)),"^")_"/"_$S(+$G(^RARPT(RARPT,"T"))&($D(^VA(200,+$P($G(^RARPT(RARPT,"T")),"^"),0))):$P(^(0),"^",2),1:"")
- S:$D(RAUTOE) ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- D HANG^RARTR2 G END:$D(RAOOUT)
- I RAST'="V" D:'$D(RAMDV) SETDIV^RARTR2 I $P(RAMDV,U,25) D WARNING^RARTR1
- G PEND:RAST'="PD"
- S $P(RASTRSK,"*",80)=""
- I '$D(RAUTOE) D
- . D HD:($Y+RAFOOT+9)>IOSL
- . W !,$E(RASTRSK,1,22)," P R O B L E M S T A T E M E N T ",$E(RASTRSK,1,22)
- . W !!,$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.") W !!,RASTRSK
- . Q
- E D
- . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$E(RASTRSK,1,22)_" P R O B L E M S T A T E M E N T "_$E(RASTRSK,1,22)
- . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$S($D(^RARPT(RARPT,"P")):^("P"),1:"None entered.")
- . S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- . Q
- PEND D FOOT^RARTR2,HANG^RARTR2 D:'$D(RAMIE)&('$D(RAUTOE)) Q^RAFLH1
- END K:$D(RAOOUT) XQAID,XQAKILL
- K %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF
- K RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR
- K RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE
- K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z
- ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG
- ; 05/15/08 BAY/KAM Patch RA*5*92 Added Conditional Kill to next line
- ; to support an AMIE interface (IA 708)
- K RASTRSK,RAORIOF,RAFFLF,RAERRFLG K:'($D(RAMIE)#2) DFN
- ;the next kill line corrects the CPRS V27 report display issue when repeated
- ;on same patient P92
- K %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RADUPHX,RANUM,RAREZON,RAST
- Q
- Q ; Queue the report
- S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")="" S:$D(RARTMES) ZTSAVE("RARTMES")=""
- D ZIS^RAUTL Q:RAPOP
- ;
- DQ S U="^",X="T",%DT="" D ^%DT K %DT S DT=Y G PRT
- ;
- INIT ; initialize exam/report variables
- ; main variables set:
- ; RAY0: zero node data from the Patient File (2)
- ; RAY1: zero node data from the Rad/Nuc Med Patient File (70)
- ; RAY2: Registered Exams (70.02) zero node data
- ; RAY3: Examinations (70.03) zero node data
- S (RAY0,RAY1,RAY2,RAY3)=-1 ; error condition, if no data nodes
- S RADFN=+$P(X,"^",2),RADTE=+$P(X,"^",3),RADTI=(9999999.9999-RADTE)
- S RACN=+$P(X,"^",4),RAST=$P(X,"^",5),RATAB=5
- S:'$D(RABTCH) RABTCH=0 S (DIWL,DIWF)=0
- Q:'$D(^RADPT(RADFN,0)) S RANUM=1,RAY1=^(0)
- Q:'$D(^DPT(RADFN,0)) S RAY0=^(0)
- Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) S RAY2=^(0)
- S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
- S (RAY3,RALB)=$S($D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1)
- Q:RAY3<0 ; examinations data missing
- ;
- S (RAHDFM,RAFTFM)=1 S:$D(^RA(79.1,+$P(RAY2,"^",4),0)) RAHDFM=^(0),RAFTFM=+$P(RAHDFM,"^",13),DIWL=$P(RAHDFM,"^",14),DIWF=$P(RAHDFM,"^",15),RAHDFM=+$P(RAHDFM,"^",12) S RAFOOT=$S($D(^RA(78.2,RAFTFM,0)):+$P(^(0),"^",2),1:0)
- S:'DIWL DIWL=5 S:'DIWF DIWF=70 S DIWF="WC"_(DIWF-DIWL)
- G @$S($D(RAUTOE):"HEAD^RARTR0",1:"HD1")
- Q
- ;
- HD D FOOT^RARTR2:$E(IOST,1,2)'="C-"
- HD1 S RAFMT=RAHDFM I $D(RARTMES) W:$Y>0 @RAFFLF W !,?((80-$L(RARTMES))/2),RARTMES,! S RAIOF=RAFFLF,RAFFLF="!"
- I '$D(RARTMES) W:$Y>0 @RAFFLF
- D PRT^RAFLH S:$D(RARTMES) RAFFLF=RAIOF
- W:$D(RAERRFLG) !!?10,$$AMENRPT^RARTR2(),!!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTR 9383 printed Jan 18, 2025@03:40:25 Page 2
- RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO - Queue/print Reports ; Jun 17, 2024@12:00:07
- +1 ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75,92,99,210,216**;Mar 16, 1998;Build 2
- +2 ;Supported IA #2056 reference to GET1^DIQ
- PRT ; Begin print/build of e-mail message
- +1 ;
- +2 ; ** NOTE: If the layout of this output is changed **
- +3 ; ** please check that routine RAO7PC3 is **
- +4 ; ** not affected. It assumes fixed format of **
- +5 ; ** the following headings: **
- +6 ; ** Clinical History: **
- +7 ; ** Report: **
- +8 ; ** Impression: **
- +9 ; ** Primary Diagnostic Code: **
- +10 ; ** Secondary Diagnostic Codes: **
- +11 ; ** Primary Interpreting Staff: **
- +12 ;
- +13 if '$DATA(^RARPT(+$GET(RARPT),0))
- QUIT
- +14 ; Use and Set if running in the foreground and Writing to the device
- +15 IF '$DATA(RAUTOE)
- Begin DoDot:1
- +16 USE IO
- +17 SET RAFFLF=IOF
- +18 SET RAORIOF=RAFFLF
- End DoDot:1
- +19 ;
- +20 ; If RAUTOE defined build mail msg
- if $Y>0&('$DATA(RAUTOE))
- WRITE @RAFFLF
- +21 ; RAORIOF=RAFFLF
- SET X=$GET(^RARPT(+$GET(RARPT),0))
- +22 ;
- +23 ;S RAFFLF=$S('$D(ORACTION):RAFFLF,ORACTION'=8:RAFFLF,1:"!")
- +24 ; setup exam/report variables
- DO INIT
- +25 ;p210/KLM - Add Facility Contact Data for FDA mammograpgy requirement
- +26 IF '$DATA(RAUTOE)
- Begin DoDot:1
- +27 NEW RADIVDA,RACRM
- SET RADIVDA=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,3)
- +28 ;p216/KLM - data check
- SET RACRM=$PIECE($GET(^RA(79.1,$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,21)
- +29 IF $GET(RAST)'="EF"
- IF (RACRM'=2)
- DO HDRFAC^RARTR0(RADIVDA)
- +30 ;end 210
- QUIT
- End DoDot:1
- +31 ;start p99
- +32 IF $$PTSEX^RAUTL8(RADFN)="F"
- IF '$DATA(RAUTOE)
- Begin DoDot:1
- +33 NEW RA700332,RA700380
- SET RA700332=$$GET1^DIQ(70.03,$GET(RACNI)_","_$GET(RADTI)_","_$GET(RADFN),32)
- +34 if RA700332'=""
- WRITE !,"Pregnancy Screen: ",RA700332
- +35 SET RA700380=$$GET1^DIQ(70.03,$GET(RACNI)_","_$GET(RADTI)_","_$GET(RADFN),80)
- +36 IF (RA700332'="Patient answered no")
- IF (RA700380'="")
- SET RA700380="Pregnancy Screen Comment: "_RA700380
- DO OUTTEXT^RAUTL9(RA700380,"",1,75,"","!","")
- +37 WRITE !
- End DoDot:1
- +38 ;end of p99
- +39 ; data nodes missing
- IF RAY0<0!(RAY1<0)!(RAY2<0)!(RAY3<0)
- KILL RAFFLF
- QUIT
- +40 ;
- PRT1 IF $DATA(RAUTOE)
- Begin DoDot:1
- +1 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
- +2 IF $DATA(RADDEN)
- Begin DoDot:2
- +3 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Unverified by: "_$PIECE($GET(^VA(200,$SELECT($GET(RADUZ):RADUZ,1:DUZ),0)),"^")
- +4 QUIT
- End DoDot:2
- +5 QUIT
- End DoDot:1
- +6 IF +$ORDER(^RARPT(RARPT,"ERR",0))
- Begin DoDot:1
- +7 ; set for future reference (display AMENRPT^RARTR text)
- SET RAERRFLG=""
- +8 if '$DATA(RAUTOE)
- WRITE !!?10,$$AMENRPT^RARTR2(),!
- +9 IF $DATA(RAUTOE)
- Begin DoDot:2
- +10 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "
- +11 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$$AMENRPT^RARTR2()
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 IF $PIECE(RAY3,"^",25)<2
- Begin DoDot:1
- +15 DO MODS^RAUTL2
- DO OUT1^RARTR3
- +16 if +$PIECE(RAY3,"^",28)
- DO RDIO^RARTUTL(+$PIECE(RAY3,"^",28))
- if $DATA(RAOOUT)
- QUIT
- +17 if +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
- DO PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
- +18 ;W:'$D(RAUTOE) !
- +19 if $DATA(RAUTOE)
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +20 QUIT
- End DoDot:1
- if $DATA(RAOOUT)
- GOTO END
- +21 IF $PIECE(RAY3,"^",25)>1
- Begin DoDot:1
- +22 DO MEMS1^RARTR3
- +23 if '$DATA(RAUTOE)
- WRITE !
- +24 if $DATA(RAUTOE)
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +25 QUIT
- End DoDot:1
- +26 if $DATA(RAOOUT)
- GOTO END
- +27 ; Check for duplicate history in file 70 and 74.
- +28 ; Sets RADUPHX to 1 for duplicate or 0 if different.
- DO CHKDUPHX^RART1
- +29 FOR RAP="H","AH","R","I"
- KILL ^UTILITY($JOB,"W"),^(1)
- Begin DoDot:1
- +30 SET RAP("P")=$SELECT(RAP="H":"Clinical History:",RAP="AH":"Additional Clinical History:",RAP="R":"Report:",1:"Impression:")
- +31 ; Don't continue if printing Additional Clinical History and it is a
- +32 ; duplicate of Clinical History.
- +33 if RAP="AH"&(RADUPHX>0)
- QUIT
- +34 if '$DATA(RAUTOE)
- WRITE !?RATAB,RAP("P")
- +35 IF $DATA(RAUTOE)
- IF ($DATA(RADDEN))
- IF (RAP="R")
- Begin DoDot:2
- +36 NEW RABAN1,RABAN2,RASPCE
- SET $PIECE(RASPCE," ",46)=""
- +37 SET RABAN1="*** Uncorrected Version ***"
- +38 SET RABAN2="*** Refer to final report ***"
- +39 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +40 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN1
- +41 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RASPCE_RABAN2
- +42 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +43 QUIT
- End DoDot:2
- +44 if $DATA(RAUTOE)
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_RAP("P")
- +45 if $DATA(RASTFL)&(RAP="R")&('$DATA(RAUTOE))
- WRITE ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$PIECE($GET(^DD(74,5,0)),"^",2))
- +46 IF RAP="R"
- IF ($DATA(RAUTOE))
- Begin DoDot:2
- +47 SET $PIECE(RAP("S")," ",(46-$LENGTH(^TMP($JOB,"RA AUTOE",RAACNT))))=""
- +48 IF '$DATA(RADDEN)
- SET ^TMP($JOB,"RA AUTOE",RAACNT)=^(RAACNT)_RAP("S")_"Status: "_$$XTERNAL^RAUTL5(RAST,$PIECE($GET(^DD(74,5,0)),"^",2))
- +49 QUIT
- End DoDot:2
- +50 if $DATA(RAUTOE)
- DO SET^RARTR2
- +51 if '$DATA(RAUTOE)
- DO WRITE^RARTR2
- if $DATA(RAOOUT)
- QUIT
- +52 KILL ^UTILITY($JOB,"W")
- +53 QUIT
- End DoDot:1
- if $DATA(RAOOUT)
- GOTO END
- +54 IF $DATA(RADDEN)
- IF ($GET(^RARPT(RARPT,"PURGE")))
- Begin DoDot:1
- +55 ; when the report is unverified and purge data exists (rpt adden)
- +56 NEW RAPRGE
- SET RAPRGE=+$GET(^RARPT(RARPT,"PURGE"))
- +57 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +58 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Report Purged: "_$$FMTE^XLFDT(RAPRGE,"1P")
- +59 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +60 QUIT
- End DoDot:1
- +61 ;print dx codes
- IF $PIECE($GET(^RA(79.1,+$PIECE(RAY2,U,4),0)),U,18)="Y"
- DO PRTDX^RARTR1
- if $DATA(RAOOUT)
- GOTO END
- +62 DO EN1^RARTR0
- if $DATA(RAOOUT)
- GOTO END
- +63 IF '$DATA(RAVERFND)
- Begin DoDot:1
- +64 IF '$DATA(RAUTOE)
- if ($Y+RAFOOT+4)>IOSL
- DO HANG^RARTR2
- if $DATA(RAOOUT)
- QUIT
- if ($Y+RAFOOT+4)>IOSL
- DO HD
- +65 NEW RADFTSBN,RADFTSBT
- if $DATA(RADDEN)
- SET RAVERF=+$PIECE(RA74B4,"^",9)
- +66 SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",2),1,25)
- +67 if RADFTSBN']""
- SET RADFTSBN=$EXTRACT($PIECE($GET(^VA(200,RAVERF,0)),"^"),1,25)
- +68 SET RADFTSBT=$EXTRACT($PIECE($GET(^VA(200,RAVERF,20)),"^",3),1,30)
- +69 IF RADFTSBT']""
- SET RADFTSBT=$$TITLE^RARTR0(RAVERF)
- +70 if '$DATA(RAUTOE)
- WRITE !!,"VERIFIED BY:",!?2,$SELECT(RADFTSBN]"":RADFTSBN,1:"")
- +71 if RADFTSBT]""&('$DATA(RAUTOE))
- WRITE ", "_RADFTSBT
- +72 IF $DATA(RAUTOE)
- Begin DoDot:2
- +73 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="VERIFIED BY:"
- +74 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$SELECT(RADFTSBN]"":RADFTSBN,1:"")_$SELECT(RADFTSBT]"":", "_RADFTSBT,1:"")
- +75 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +76 QUIT
- End DoDot:2
- +77 QUIT
- End DoDot:1
- if $DATA(RAOOUT)
- GOTO END
- +78 KILL RASBPN,RASBT,RASECIEN,RASECOND,RASECSS
- +79 IF '$DATA(RAUTOE)
- if ($Y+RAFOOT+4)>IOSL
- DO HANG^RARTR2
- if $DATA(RAOOUT)
- GOTO END
- if ($Y+RAFOOT+4)>IOSL
- DO HD
- +80 if '$DATA(RAUTOE)
- WRITE !!,$SELECT($DATA(^RABTCH(74.2,+RABTCH,0)):$PIECE(^(0),"^"),1:""),"/"
- IF +$GET(^RARPT(RARPT,"T"))
- IF $DATA(^VA(200,+$PIECE(^RARPT(RARPT,"T"),"^"),0))
- if '$DATA(RAUTOE)
- WRITE $PIECE(^(0),"^",2)
- +81 if $DATA(RAUTOE)
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$PIECE($GET(^RABTCH(74.2,+RABTCH,0)),"^")_"/"_$SELECT(+$GET(^RARPT(RARPT,"T"))&($DATA(^VA(200,+$PIECE($GET(^RARPT(RARPT,"T")),"^"),0))):$PIECE(^(0),"^",2),1:"")
- +82 if $DATA(RAUTOE)
- SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +83 DO HANG^RARTR2
- if $DATA(RAOOUT)
- GOTO END
- +84 IF RAST'="V"
- if '$DATA(RAMDV)
- DO SETDIV^RARTR2
- IF $PIECE(RAMDV,U,25)
- DO WARNING^RARTR1
- +85 if RAST'="PD"
- GOTO PEND
- +86 SET $PIECE(RASTRSK,"*",80)=""
- +87 IF '$DATA(RAUTOE)
- Begin DoDot:1
- +88 if ($Y+RAFOOT+9)>IOSL
- DO HD
- +89 WRITE !,$EXTRACT(RASTRSK,1,22)," P R O B L E M S T A T E M E N T ",$EXTRACT(RASTRSK,1,22)
- +90 WRITE !!,$SELECT($DATA(^RARPT(RARPT,"P")):^("P"),1:"None entered.")
- WRITE !!,RASTRSK
- +91 QUIT
- End DoDot:1
- +92 IF '$TEST
- Begin DoDot:1
- +93 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$EXTRACT(RASTRSK,1,22)_" P R O B L E M S T A T E M E N T "_$EXTRACT(RASTRSK,1,22)
- +94 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$SELECT($DATA(^RARPT(RARPT,"P")):^("P"),1:"None entered.")
- +95 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
- +96 QUIT
- End DoDot:1
- PEND DO FOOT^RARTR2
- DO HANG^RARTR2
- if '$DATA(RAMIE)&('$DATA(RAUTOE))
- DO Q^RAFLH1
- END if $DATA(RAOOUT)
- KILL XQAID,XQAKILL
- +1 KILL %I,%W,%Y1,C,DN,I,RADXCODE,RARTMES,RAVERF,RAVERFND,RAPVERF
- +2 KILL RAVERS,RAFOOT,RAY0,RAY1,RAY2,RAY3,RALOC,RAFMT,RAMOD,RASTFL,RALB,RALBR
- +3 KILL RALBRT,RALBS,RALBST,RAV,RAP,RATAB,RAXX,VAL,VAR,RADFN,RADTI,RACN,RADTE
- +4 KILL RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z
- +5 ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG
- +6 ; 05/15/08 BAY/KAM Patch RA*5*92 Added Conditional Kill to next line
- +7 ; to support an AMIE interface (IA 708)
- +8 KILL RASTRSK,RAORIOF,RAFFLF,RAERRFLG
- if '($DATA(RAMIE)#2)
- KILL DFN
- +9 ;the next kill line corrects the CPRS V27 report display issue when repeated
- +10 ;on same patient P92
- +11 KILL %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RADUPHX,RANUM,RAREZON,RAST
- +12 QUIT
- Q ; Queue the report
- +1 SET ZTDTH=$HOROLOG
- SET ZTRTN="DQ^RARTR"
- SET ZTSAVE("RARPT")=""
- if $DATA(RARTMES)
- SET ZTSAVE("RARTMES")=""
- +2 DO ZIS^RAUTL
- if RAPOP
- QUIT
- +3 ;
- DQ SET U="^"
- SET X="T"
- SET %DT=""
- DO ^%DT
- KILL %DT
- SET DT=Y
- GOTO PRT
- +1 ;
- INIT ; initialize exam/report variables
- +1 ; main variables set:
- +2 ; RAY0: zero node data from the Patient File (2)
- +3 ; RAY1: zero node data from the Rad/Nuc Med Patient File (70)
- +4 ; RAY2: Registered Exams (70.02) zero node data
- +5 ; RAY3: Examinations (70.03) zero node data
- +6 ; error condition, if no data nodes
- SET (RAY0,RAY1,RAY2,RAY3)=-1
- +7 SET RADFN=+$PIECE(X,"^",2)
- SET RADTE=+$PIECE(X,"^",3)
- SET RADTI=(9999999.9999-RADTE)
- +8 SET RACN=+$PIECE(X,"^",4)
- SET RAST=$PIECE(X,"^",5)
- SET RATAB=5
- +9 if '$DATA(RABTCH)
- SET RABTCH=0
- SET (DIWL,DIWF)=0
- +10 if '$DATA(^RADPT(RADFN,0))
- QUIT
- SET RANUM=1
- SET RAY1=^(0)
- +11 if '$DATA(^DPT(RADFN,0))
- QUIT
- SET RAY0=^(0)
- +12 if '$DATA(^RADPT(RADFN,"DT",RADTI,0))
- QUIT
- SET RAY2=^(0)
- +13 SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0))
- +14 SET (RAY3,RALB)=$SELECT($DATA(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)):^(0),1:-1)
- +15 ; examinations data missing
- if RAY3<0
- QUIT
- +16 ;
- +17 SET (RAHDFM,RAFTFM)=1
- if $DATA(^RA(79.1,+$PIECE(RAY2,"^",4),0))
- SET RAHDFM=^(0)
- SET RAFTFM=+$PIECE(RAHDFM,"^",13)
- SET DIWL=$PIECE(RAHDFM,"^",14)
- SET DIWF=$PIECE(RAHDFM,"^",15)
- SET RAHDFM=+$PIECE(RAHDFM,"^",12)
- SET RAFOOT=$SELECT($DATA(^RA(78.2,RAFTFM,0)):+$PIECE(^(0),"^",2),1:0)
- +18 if 'DIWL
- SET DIWL=5
- if 'DIWF
- SET DIWF=70
- SET DIWF="WC"_(DIWF-DIWL)
- +19 GOTO @$SELECT($DATA(RAUTOE):"HEAD^RARTR0",1:"HD1")
- +20 QUIT
- +21 ;
- HD if $EXTRACT(IOST,1,2)'="C-"
- DO FOOT^RARTR2
- HD1 SET RAFMT=RAHDFM
- IF $DATA(RARTMES)
- if $Y>0
- WRITE @RAFFLF
- WRITE !,?((80-$LENGTH(RARTMES))/2),RARTMES,!
- SET RAIOF=RAFFLF
- SET RAFFLF="!"
- +1 IF '$DATA(RARTMES)
- if $Y>0
- WRITE @RAFFLF
- +2 DO PRT^RAFLH
- if $DATA(RARTMES)
- SET RAFFLF=RAIOF
- +3 if $DATA(RAERRFLG)
- WRITE !!?10,$$AMENRPT^RARTR2(),!!
- +4 QUIT