- RART1 ;HISC/GJC,SWM - Reporting Menu (Part 2) ; Jun 17, 2024@11:22:42
- ;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47,173,210,216**;Mar 16, 1998;Build 2
- ;Print Report By Patient has been moved to 4^RART2!
- ;these sections are moved to ^RART3 : QRPT, PHYS, MODSET, OUT1
- ;RVD P99, add pregnancy screen and commment if populated for female pt.
- CHK I 'RARPT!('$D(^RARPT(+RARPT,0))) W !?3,$C(7),"No report filed for case number ",RACN,"." K RARPT Q
- I $D(RADFT),$P(^RARPT(+RARPT,0),"^",5)'["D" W !?3,$C(7),"Report for case number ",RACN," is not in a 'draft' status." K RARPT Q
- I '$D(RADFT),$P(^RARPT(+RARPT,0),"^",5)["D" W !?3,$C(7),"Report filed for case number ",RACN," but not available for printing." K RARPT Q
- Q
- ;
- 5 ;;Draft Report (Reprint)
- D SETVARS Q:'($D(RACCESS(DUZ))\10)!('$D(RAIMGTY)) S RADFT="" G 4^RART2
- ;
- 6 ;;Display a Report By Patient
- W ! S DIC(0)="AEMQ" D ^RADPA G Q6:Y<0 S RADFN=+Y,RAHEAD="**** Patient's Exams ****",RAF1=1,RAREPORT=1 D ^RAPTLU G Q6:X="^" G 6:'$D(RADUP)
- I X=1 R X:3
- OERR ;entry from RA OERR PROFILE protocol
- F RAI=0:0 S RAI=$O(RADUP(RAI)) Q:RAI'>0 S Y=^TMP($J,"RAEX",RAI) D 61,DISP Q:X="^"
- K RADUP,RAI,RAJ,X,^TMP($J,"RAEX") Q:$D(ORVP) G 6
- 61 F RAJ=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$P(Y,"^",RAJ)
- S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) Q
- ;
- OERR1 ;Entry Point for Alert Follow-Up Action for OE/RR
- Q:'$D(XQADATA)!('$D(XQAID)) S (RARPT,Y)=XQADATA D RASET^RAUTL2
- S:Y Y(0)=Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown"),RAPRC=$S($D(^RAMIS(71,+$P(Y(0),"^",2),0)):$P(^(0),"^"),1:"Unknown")
- S RALERTS="" D DISP K:X="^" XQAID,XQAKILL
- I $D(XQAID) S DFN=$P(XQAID,",",2) D DELETE^XQALERT
- K RALERTS
- Q
- ;
- DISP I RARPT,($D(RAPBRPT)),($P($G(^RARPT(+RARPT,0)),"^",5)="V") D Q
- . ; This code will not allow a user to re-edit a verified report.
- . ; In this case, two or more possible users signed on to the same
- . ; Imaging location, asked to verify the reports of the same
- . ; Interpreting Radiology/Nuclear Medicine Physician.
- . ; For the 'On-line Verifying of Reports' option only!
- . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
- . ; removed X from N so rtn RARTVER would quit if caret entered
- . W !!?10,"Since the time you selected this group of reports,",!?10,$P($G(^VA(200,+$P(^RARPT(+RARPT,0),"^",9),0)),U)," has verified the report for "
- . W !?10,$P($G(^DPT(+$P(^RARPT(+RARPT,0),"^",2),0)),U)," case #",$P(^RARPT(+RARPT,0),"^"),".",$C(7)
- . S Y=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):$P($P(^(RARPT),"/",2),U,3),$D(RARPTX(+$G(RPTX))):$P($P(RARPTX(+$G(RPTX)),"/",2),U,3),1:"")
- . I $D(^RAMIS(71,+Y,0)) W !?10,"Procedure ",$P(^(0),U)
- . W ! K DIR S DIR(0)="E" D ^DIR S RAVFIED=1
- . Q
- D HOME^%ZIS S OREND=1
- I 'RARPT!('$D(^RARPT(+RARPT,0))) D G Q6
- . W !?3,$C(7),"No report filed for case number",$S($D(RACN):" "_RACN,1:""),"."
- . R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
- . Q
- S RAST=$P(^RARPT(+RARPT,0),"^",5)
- I '$D(RARTVER),(RAST=""!(RAST["D")) D G Q6
- . W !?3,$C(7),"Report filed for case number ",RACN," but not available for display."
- . R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
- . Q
- DISP1 I $S('$D(ORACTION):1,ORACTION'=8:1,'$D(X):0,X="T":1,1:0) W @IOF
- ;p210/KLM - Add Facility Contact Data for FDA mammograpgy requirement
- 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
- ;Check if outside report -(Electronically Filed, No Credit location
- I $G(RAST)'="EF",($G(RACRM)'=2) D HDRFAC^RARTR0(RADIVDA)
- ;p210 end
- W !,RANME," (",$$SSN^RAUTL,")",?39,"Case No. ",?55,": ",$P($G(^RARPT(RARPT,0)),"^")," @",$E(RADATE,$L(RADATE)-4,$L(RADATE))
- W !,$E(RAPRC,1,40) I +$G(^RARPT(RARPT,"T")) W ?39,"Transcriptionist",?55,": ",$E($P($G(^VA(200,+^RARPT(RARPT,"T"),0)),"^"),1,20)
- N R3 S R3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",+$G(RACNI),0))
- W !,"Req. Phys : ",$E($P($G(^VA(200,+$P(R3,"^",14),0)),"^"),1,25)
- S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) W ?39,"Pre-verified",?55,": ",$S($D(^VA(200,RAPREVER,0)):$E($P($G(^VA(200,RAPREVER,0)),"^"),1,24),1:"NO") K RAPREVER
- D PHYS^RART3
- ;Display Pregnancy Screen and Comments if respective field is filled and pt is female, patch #99
- I $$PTSEX^RAUTL8(RADFN)="F" D
- .W:$P(R3,U,32)'="" !,"Pregnancy Screen: ",$S($P(R3,"^",32)="y":"Patient answered yes",$P(R3,"^",32)="n":"Patient answered no",$P(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
- .N RAPCOMM S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM"))
- .W:$P(R3,U,32)'=""&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM
- I $D(RAPBRPT),(RAST="PD") D
- . W !,"**Prob Text: "
- . I $G(^RARPT(+RARPT,"P"))]"" D
- .. S X=$G(^RARPT(+RARPT,"P"))
- .. D OUTTEXT^RAUTL9(X,"",10,70,13,"","!")
- .. Q
- . Q
- W !,$$REPEAT^XLFSTR("=",79)
- I $O(^RARPT(RARPT,1,0)) D MODSET^RART3
- I '$O(^RARPT(RARPT,1,0)) D
- . D MODS^RAUTL2,OUT1^RART3
- . I +$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28) S X=$$RDIO1^RARTUTL1(+$P(^(0),"^",28))
- . Q:$L($G(X)) ; 'X' should be 'null' to continue
- . S:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
- . Q
- Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^"
- I +$O(^RARPT(RARPT,"ERR",0)) W !?10,$$AMENRPT^RARTR2(),!
- ;
- ; Print the clinical history from file 70
- I +$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) D
- . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75"
- . W !?3,"Clinical History:"
- . S RAP="H" D WRITEHX(RAP)
- . Q
- Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^"
- ;
- ; Print the additional report clinical history if defined and
- ; different than the order clinical history.
- I +$O(^RARPT(RARPT,"H",0)) D
- . D CHKDUPHX Q:RADUPHX ; Duplicate history
- . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75"
- . W !?3,"Additional Clinical History:"
- . S RAP="AH" D WRITEHX(RAP)
- ;
- ; Print Report and Impression text
- F RAP="R","I" D Q:X="^"!(X="P")!(X="T")
- . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75"
- . W !?3,$S(RAP="R":"Report:",1:"Impression:") W:RAP="R" ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),U,2))
- . W:RAP="R"&($E(RAST)="P") $C(7)
- . D WRITE
- . Q
- Q:X="P" G DISP1:X="T",Q6:X="^"
- ; I $$IMAGE^RARIC1() D DISPF^MAGRIC ;don't call MAG 111300
- I $P($G(^RA(79.1,+$P(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,18)="Y" D PRTDX^RART K RADXCODE
- Q:X="P" G DISP1:X="T",Q6:X="^"
- ;
- I $D(ORVP) D
- .S RAVERF=+$P($G(^RARPT(+RARPT,0)),"^",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)
- .S:RADFTSBT']"" RADFTSBT=$$TITLE^RARTR0(RAVERF)
- .W !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"")
- .W:RADFTSBT]"" ", "_RADFTSBT
- Q:X="P" G DISP1:X="T",Q6:X="^"
- ;
- K RAP I '$D(RARTVER) D WAIT Q:X="P" G DISP1:X="T"
- Q6 K %,DIC,DIWF,DIWL,DIWR,I,J,OREND,POP,RABTCH,RAF1,RAHEAD,RALOC,RANME,RAPAR,RAPRC,RAREPORT,RASEL,RASSN,RAST,RAV,RAXX,Y,X1,Z
- K RAVERF,RADFTSBN,RADFTSBT
- K DIW,DIWT,DN
- K C,DIPGM,DISYS,R1,RAIMGTYI,RAP
- K:'$D(RARTVER) RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RARPT Q
- ;
- WRITE K RAXX N Y
- F RAV=0:0 S RAV=$O(^RARPT(RARPT,RAP,RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T")
- . S RAXX=^RARPT(RARPT,RAP,RAV,0) S X=""
- . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T")
- . S X=RAXX D ^DIWP S X=""
- . Q
- Q:X="^" D ^DIWW:$D(RAXX) Q
- ;
- WRITEHX(RAP) ; Get and write the clinical history
- ;
- ;Input: RAP H = Clinical History from file 70
- ; AH = Additional Clinical History from file 74
- ;
- K RAXX N Y
- S RAV=0
- I RAP="H" D
- . F S RAV=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T")
- . . S RAXX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0),X=""
- . . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T")
- . . S X=RAXX D ^DIWP S X=""
- . . Q
- I RAP="AH" D
- . F S RAV=$O(^RARPT(RARPT,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T")
- . . S RAXX=^RARPT(RARPT,"H",RAV,0),X=""
- . . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T")
- . . S X=RAXX D ^DIWP S X=""
- . . Q
- Q:X="^" D ^DIWW:$D(RAXX) Q
- ;
- CHKDUPHX ; Check Duplicate History in file 70 and 74.
- ; Returns RADUPHX 1 = Duplicate
- ; 0 = Different
- N RAX,RA74,RA70,RAOK,RAX1
- ; Initialize to Different
- S RADUPHX=0
- ; Quit if H node does not exist. Could have been purged.
- I '$D(^RARPT(RARPT,"H")) S RADUPHX=1 Q
- ;p173/KLM Quit if no CH on exam, flag set to take CH from report.
- I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")) S RADUPHX=0 Q
- S RA74=$O(^RARPT(RARPT,"H",""),-1)
- S RA70=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1),RA701=$O(^(0))
- S RAX=RA74-RA70+1 Q:RAX'=1 ; begin comparison
- ; Check line by line of each file
- ; RAOK 1 = all lines match
- ; 0 = at least 1 difference
- S RAOK=1
- F RAX1=RA701:1:RA70 I ^RARPT(RARPT,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0) S RAOK=0 Q ;can exit loop on 1st difference
- I 'RAOK Q
- S RADUPHX=1
- Q
- ;
- WAIT ; user input, goto top, print, or continue
- S RARD(1)="Continue^continue normal processing"
- S:$D(RALERTS) RARD(2)="Print^print the entire report"
- S RARD(3)="Top^display the report from the beginning"
- S (RARD("B"),RARD("DTOUT"))=1
- S:$D(RALERTS) RARD("A")="Enter 'Top', 'Print' or 'Continue': "
- S:'$D(RALERTS) RARD("A")="Enter 'Top' or 'Continue': "
- S RARD(0)="S" D SET^RARD K RARD S X=$E(X)
- I $D(RALERTS),(X="P") D QRPT^RART3
- Q:X="^"!(X="P") W:X="C"&($D(RAP)) @IOF
- Q
- ;
- LOCK(X,Y) ; Lock an entry
- W !!,$C(7),"Another user is editing this ",$S(X="R":"report (Case # "_Y_")",1:"exam (diagnostic code)"),". Please try again later." H 4 Q
- ;
- SETVARS ; Setup Rad/Nuc Med required variables
- I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0)
- Q:'($D(RACCESS(DUZ))\10)
- I $G(RAIMGTY)="" D SETVARS^RAPSET1(1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRART1 9960 printed Jan 18, 2025@03:40:14 Page 2
- RART1 ;HISC/GJC,SWM - Reporting Menu (Part 2) ; Jun 17, 2024@11:22:42
- +1 ;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47,173,210,216**;Mar 16, 1998;Build 2
- +2 ;Print Report By Patient has been moved to 4^RART2!
- +3 ;these sections are moved to ^RART3 : QRPT, PHYS, MODSET, OUT1
- +4 ;RVD P99, add pregnancy screen and commment if populated for female pt.
- CHK IF 'RARPT!('$DATA(^RARPT(+RARPT,0)))
- WRITE !?3,$CHAR(7),"No report filed for case number ",RACN,"."
- KILL RARPT
- QUIT
- +1 IF $DATA(RADFT)
- IF $PIECE(^RARPT(+RARPT,0),"^",5)'["D"
- WRITE !?3,$CHAR(7),"Report for case number ",RACN," is not in a 'draft' status."
- KILL RARPT
- QUIT
- +2 IF '$DATA(RADFT)
- IF $PIECE(^RARPT(+RARPT,0),"^",5)["D"
- WRITE !?3,$CHAR(7),"Report filed for case number ",RACN," but not available for printing."
- KILL RARPT
- QUIT
- +3 QUIT
- +4 ;
- 5 ;;Draft Report (Reprint)
- +1 DO SETVARS
- if '($DATA(RACCESS(DUZ))\10)!('$DATA(RAIMGTY))
- QUIT
- SET RADFT=""
- GOTO 4^RART2
- +2 ;
- 6 ;;Display a Report By Patient
- +1 WRITE !
- SET DIC(0)="AEMQ"
- DO ^RADPA
- if Y<0
- GOTO Q6
- SET RADFN=+Y
- SET RAHEAD="**** Patient's Exams ****"
- SET RAF1=1
- SET RAREPORT=1
- DO ^RAPTLU
- if X="^"
- GOTO Q6
- if '$DATA(RADUP)
- GOTO 6
- +2 IF X=1
- READ X:3
- OERR ;entry from RA OERR PROFILE protocol
- +1 FOR RAI=0:0
- SET RAI=$ORDER(RADUP(RAI))
- if RAI'>0
- QUIT
- SET Y=^TMP($JOB,"RAEX",RAI)
- DO 61
- DO DISP
- if X="^"
- QUIT
- +2 KILL RADUP,RAI,RAJ,X,^TMP($JOB,"RAEX")
- if $DATA(ORVP)
- QUIT
- GOTO 6
- 61 FOR RAJ=1:1:11
- SET @$PIECE("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$PIECE(Y,"^",RAJ)
- +1 SET Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
- QUIT
- +2 ;
- OERR1 ;Entry Point for Alert Follow-Up Action for OE/RR
- +1 if '$DATA(XQADATA)!('$DATA(XQAID))
- QUIT
- SET (RARPT,Y)=XQADATA
- DO RASET^RAUTL2
- +2 if Y
- SET Y(0)=Y
- SET RANME=$SELECT($DATA(^DPT(RADFN,0)):$PIECE(^(0),"^"),1:"Unknown")
- SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(Y(0),"^",2),0)):$PIECE(^(0),"^"),1:"Unknown")
- +3 SET RALERTS=""
- DO DISP
- if X="^"
- KILL XQAID,XQAKILL
- +4 IF $DATA(XQAID)
- SET DFN=$PIECE(XQAID,",",2)
- DO DELETE^XQALERT
- +5 KILL RALERTS
- +6 QUIT
- +7 ;
- DISP IF RARPT
- IF ($DATA(RAPBRPT))
- IF ($PIECE($GET(^RARPT(+RARPT,0)),"^",5)="V")
- Begin DoDot:1
- +1 ; This code will not allow a user to re-edit a verified report.
- +2 ; In this case, two or more possible users signed on to the same
- +3 ; Imaging location, asked to verify the reports of the same
- +4 ; Interpreting Radiology/Nuclear Medicine Physician.
- +5 ; For the 'On-line Verifying of Reports' option only!
- +6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
- +7 ; removed X from N so rtn RARTVER would quit if caret entered
- +8 WRITE !!?10,"Since the time you selected this group of reports,",!?10,$PIECE($GET(^VA(200,+$PIECE(^RARPT(+RARPT,0),"^",9),0)),U)," has verified the report for "
- +9 WRITE !?10,$PIECE($GET(^DPT(+$PIECE(^RARPT(+RARPT,0),"^",2),0)),U)," case #",$PIECE(^RARPT(+RARPT,0),"^"),".",$CHAR(7)
- +10 SET Y=$SELECT($DATA(^TMP($JOB,"RA","DT",+$GET(RARTDT),+$GET(RARPT))):$PIECE($PIECE(^(RARPT),"/",2),U,3),$DATA(RARPTX(+$GET(RPTX))):$PIECE($PIECE(RARPTX(+$GET(RPTX)),"/",2),U,3),1:"")
- +11 IF $DATA(^RAMIS(71,+Y,0))
- WRITE !?10,"Procedure ",$PIECE(^(0),U)
- +12 WRITE !
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- SET RAVFIED=1
- +13 QUIT
- End DoDot:1
- QUIT
- +14 DO HOME^%ZIS
- SET OREND=1
- +15 IF 'RARPT!('$DATA(^RARPT(+RARPT,0)))
- Begin DoDot:1
- +16 WRITE !?3,$CHAR(7),"No report filed for case number",$SELECT($DATA(RACN):" "_RACN,1:""),"."
- +17 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
- READ X:3
- +18 QUIT
- End DoDot:1
- GOTO Q6
- +19 SET RAST=$PIECE(^RARPT(+RARPT,0),"^",5)
- +20 IF '$DATA(RARTVER)
- IF (RAST=""!(RAST["D"))
- Begin DoDot:1
- +21 WRITE !?3,$CHAR(7),"Report filed for case number ",RACN," but not available for display."
- +22 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300
- READ X:3
- +23 QUIT
- End DoDot:1
- GOTO Q6
- DISP1 IF $SELECT('$DATA(ORACTION):1,ORACTION'=8:1,'$DATA(X):0,X="T":1,1:0)
- WRITE @IOF
- +1 ;p210/KLM - Add Facility Contact Data for FDA mammograpgy requirement
- +2 NEW RADIVDA,RACRM
- SET RADIVDA=$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,3)
- +3 ;p216/KLM - data check
- SET RACRM=$PIECE($GET(^RA(79.1,$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,21)
- +4 ;Check if outside report -(Electronically Filed, No Credit location
- +5 IF $GET(RAST)'="EF"
- IF ($GET(RACRM)'=2)
- DO HDRFAC^RARTR0(RADIVDA)
- +6 ;p210 end
- +7 WRITE !,RANME," (",$$SSN^RAUTL,")",?39,"Case No. ",?55,": ",$PIECE($GET(^RARPT(RARPT,0)),"^")," @",$EXTRACT(RADATE,$LENGTH(RADATE)-4,$LENGTH(RADATE))
- +8 WRITE !,$EXTRACT(RAPRC,1,40)
- IF +$GET(^RARPT(RARPT,"T"))
- WRITE ?39,"Transcriptionist",?55,": ",$EXTRACT($PIECE($GET(^VA(200,+^RARPT(RARPT,"T"),0)),"^"),1,20)
- +9 NEW R3
- SET R3=$GET(^RADPT(+$GET(RADFN),"DT",+$GET(RADTI),"P",+$GET(RACNI),0))
- +10 WRITE !,"Req. Phys : ",$EXTRACT($PIECE($GET(^VA(200,+$PIECE(R3,"^",14),0)),"^"),1,25)
- +11 SET RAPREVER=+$PIECE($GET(^RARPT(RARPT,0)),"^",13)
- WRITE ?39,"Pre-verified",?55,": ",$SELECT($DATA(^VA(200,RAPREVER,0)):$EXTRACT($PIECE($GET(^VA(200,RAPREVER,0)),"^"),1,24),1:"NO")
- KILL RAPREVER
- +12 DO PHYS^RART3
- +13 ;Display Pregnancy Screen and Comments if respective field is filled and pt is female, patch #99
- +14 IF $$PTSEX^RAUTL8(RADFN)="F"
- Begin DoDot:1
- +15 if $PIECE(R3,U,32)'=""
- WRITE !,"Pregnancy Screen: ",$SELECT($PIECE(R3,"^",32)="y":"Patient answered yes",$PIECE(R3,"^",32)="n":"Patient answered no",$PIECE(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
- +16 NEW RAPCOMM
- SET RAPCOMM=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM"))
- +17 if $PIECE(R3,U,32)'=""&$LENGTH(RAPCOMM)
- WRITE !,"Pregnancy Screen Comment: ",RAPCOMM
- End DoDot:1
- +18 IF $DATA(RAPBRPT)
- IF (RAST="PD")
- Begin DoDot:1
- +19 WRITE !,"**Prob Text: "
- +20 IF $GET(^RARPT(+RARPT,"P"))]""
- Begin DoDot:2
- +21 SET X=$GET(^RARPT(+RARPT,"P"))
- +22 DO OUTTEXT^RAUTL9(X,"",10,70,13,"","!")
- +23 QUIT
- End DoDot:2
- +24 QUIT
- End DoDot:1
- +25 WRITE !,$$REPEAT^XLFSTR("=",79)
- +26 IF $ORDER(^RARPT(RARPT,1,0))
- DO MODSET^RART3
- +27 IF '$ORDER(^RARPT(RARPT,1,0))
- Begin DoDot:1
- +28 DO MODS^RAUTL2
- DO OUT1^RART3
- +29 IF +$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28)
- SET X=$$RDIO1^RARTUTL1(+$PIECE(^(0),"^",28))
- +30 ; 'X' should be 'null' to continue
- if $LENGTH($GET(X))
- QUIT
- +31 if +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
- SET X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
- +32 QUIT
- End DoDot:1
- +33 if $GET(X)="P"
- QUIT
- if $GET(X)="T"
- GOTO DISP1
- if $GET(X)="^"
- GOTO Q6
- +34 IF +$ORDER(^RARPT(RARPT,"ERR",0))
- WRITE !?10,$$AMENRPT^RARTR2(),!
- +35 ;
- +36 ; Print the clinical history from file 70
- +37 IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0))
- Begin DoDot:1
- +38 KILL ^UTILITY($JOB,"W"),^(1)
- SET X=""
- SET DIWL=3
- SET DIWF="|WC75"
- +39 WRITE !?3,"Clinical History:"
- +40 SET RAP="H"
- DO WRITEHX(RAP)
- +41 QUIT
- End DoDot:1
- +42 if $GET(X)="P"
- QUIT
- if $GET(X)="T"
- GOTO DISP1
- if $GET(X)="^"
- GOTO Q6
- +43 ;
- +44 ; Print the additional report clinical history if defined and
- +45 ; different than the order clinical history.
- +46 IF +$ORDER(^RARPT(RARPT,"H",0))
- Begin DoDot:1
- +47 ; Duplicate history
- DO CHKDUPHX
- if RADUPHX
- QUIT
- +48 KILL ^UTILITY($JOB,"W"),^(1)
- SET X=""
- SET DIWL=3
- SET DIWF="|WC75"
- +49 WRITE !?3,"Additional Clinical History:"
- +50 SET RAP="AH"
- DO WRITEHX(RAP)
- End DoDot:1
- +51 ;
- +52 ; Print Report and Impression text
- +53 FOR RAP="R","I"
- Begin DoDot:1
- +54 KILL ^UTILITY($JOB,"W"),^(1)
- SET X=""
- SET DIWL=3
- SET DIWF="|WC75"
- +55 WRITE !?3,$SELECT(RAP="R":"Report:",1:"Impression:")
- if RAP="R"
- WRITE ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$PIECE($GET(^DD(74,5,0)),U,2))
- +56 if RAP="R"&($EXTRACT(RAST)="P")
- WRITE $CHAR(7)
- +57 DO WRITE
- +58 QUIT
- End DoDot:1
- if X="^"!(X="P")!(X="T")
- QUIT
- +59 if X="P"
- QUIT
- if X="T"
- GOTO DISP1
- if X="^"
- GOTO Q6
- +60 ; I $$IMAGE^RARIC1() D DISPF^MAGRIC ;don't call MAG 111300
- +61 IF $PIECE($GET(^RA(79.1,+$PIECE(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,18)="Y"
- DO PRTDX^RART
- KILL RADXCODE
- +62 if X="P"
- QUIT
- if X="T"
- GOTO DISP1
- if X="^"
- GOTO Q6
- +63 ;
- +64 IF $DATA(ORVP)
- Begin DoDot:1
- +65 SET RAVERF=+$PIECE($GET(^RARPT(+RARPT,0)),"^",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 WRITE !!,"VERIFIED BY:",!?2,$SELECT(RADFTSBN]"":RADFTSBN,1:"")
- +71 if RADFTSBT]""
- WRITE ", "_RADFTSBT
- End DoDot:1
- +72 if X="P"
- QUIT
- if X="T"
- GOTO DISP1
- if X="^"
- GOTO Q6
- +73 ;
- +74 KILL RAP
- IF '$DATA(RARTVER)
- DO WAIT
- if X="P"
- QUIT
- if X="T"
- GOTO DISP1
- Q6 KILL %,DIC,DIWF,DIWL,DIWR,I,J,OREND,POP,RABTCH,RAF1,RAHEAD,RALOC,RANME,RAPAR,RAPRC,RAREPORT,RASEL,RASSN,RAST,RAV,RAXX,Y,X1,Z
- +1 KILL RAVERF,RADFTSBN,RADFTSBT
- +2 KILL DIW,DIWT,DN
- +3 KILL C,DIPGM,DISYS,R1,RAIMGTYI,RAP
- +4 if '$DATA(RARTVER)
- KILL RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RARPT
- QUIT
- +5 ;
- WRITE KILL RAXX
- NEW Y
- +1 FOR RAV=0:0
- SET RAV=$ORDER(^RARPT(RARPT,RAP,RAV))
- if RAV'>0
- QUIT
- Begin DoDot:1
- +2 SET RAXX=^RARPT(RARPT,RAP,RAV,0)
- SET X=""
- +3 if ($Y+6)>IOSL&('$DATA(RARTVERF))
- DO WAIT
- if X="^"!(X="P")!(X="T")
- QUIT
- +4 SET X=RAXX
- DO ^DIWP
- SET X=""
- +5 QUIT
- End DoDot:1
- if X="^"!(X="P")!(X="T")
- QUIT
- +6 if X="^"
- QUIT
- if $DATA(RAXX)
- DO ^DIWW
- QUIT
- +7 ;
- WRITEHX(RAP) ; Get and write the clinical history
- +1 ;
- +2 ;Input: RAP H = Clinical History from file 70
- +3 ; AH = Additional Clinical History from file 74
- +4 ;
- +5 KILL RAXX
- NEW Y
- +6 SET RAV=0
- +7 IF RAP="H"
- Begin DoDot:1
- +8 FOR
- SET RAV=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV))
- if RAV'>0
- QUIT
- Begin DoDot:2
- +9 SET RAXX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0)
- SET X=""
- +10 if ($Y+6)>IOSL&('$DATA(RARTVERF))
- DO WAIT
- if X="^"!(X="P")!(X="T")
- QUIT
- +11 SET X=RAXX
- DO ^DIWP
- SET X=""
- +12 QUIT
- End DoDot:2
- if X="^"!(X="P")!(X="T")
- QUIT
- End DoDot:1
- +13 IF RAP="AH"
- Begin DoDot:1
- +14 FOR
- SET RAV=$ORDER(^RARPT(RARPT,"H",RAV))
- if RAV'>0
- QUIT
- Begin DoDot:2
- +15 SET RAXX=^RARPT(RARPT,"H",RAV,0)
- SET X=""
- +16 if ($Y+6)>IOSL&('$DATA(RARTVERF))
- DO WAIT
- if X="^"!(X="P")!(X="T")
- QUIT
- +17 SET X=RAXX
- DO ^DIWP
- SET X=""
- +18 QUIT
- End DoDot:2
- if X="^"!(X="P")!(X="T")
- QUIT
- End DoDot:1
- +19 if X="^"
- QUIT
- if $DATA(RAXX)
- DO ^DIWW
- QUIT
- +20 ;
- CHKDUPHX ; Check Duplicate History in file 70 and 74.
- +1 ; Returns RADUPHX 1 = Duplicate
- +2 ; 0 = Different
- +3 NEW RAX,RA74,RA70,RAOK,RAX1
- +4 ; Initialize to Different
- +5 SET RADUPHX=0
- +6 ; Quit if H node does not exist. Could have been purged.
- +7 IF '$DATA(^RARPT(RARPT,"H"))
- SET RADUPHX=1
- QUIT
- +8 ;p173/KLM Quit if no CH on exam, flag set to take CH from report.
- +9 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H"))
- SET RADUPHX=0
- QUIT
- +10 SET RA74=$ORDER(^RARPT(RARPT,"H",""),-1)
- +11 SET RA70=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1)
- SET RA701=$ORDER(^(0))
- +12 ; begin comparison
- SET RAX=RA74-RA70+1
- if RAX'=1
- QUIT
- +13 ; Check line by line of each file
- +14 ; RAOK 1 = all lines match
- +15 ; 0 = at least 1 difference
- +16 SET RAOK=1
- +17 ;can exit loop on 1st difference
- FOR RAX1=RA701:1:RA70
- IF ^RARPT(RARPT,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0)
- SET RAOK=0
- QUIT
- +18 IF 'RAOK
- QUIT
- +19 SET RADUPHX=1
- +20 QUIT
- +21 ;
- WAIT ; user input, goto top, print, or continue
- +1 SET RARD(1)="Continue^continue normal processing"
- +2 if $DATA(RALERTS)
- SET RARD(2)="Print^print the entire report"
- +3 SET RARD(3)="Top^display the report from the beginning"
- +4 SET (RARD("B"),RARD("DTOUT"))=1
- +5 if $DATA(RALERTS)
- SET RARD("A")="Enter 'Top', 'Print' or 'Continue': "
- +6 if '$DATA(RALERTS)
- SET RARD("A")="Enter 'Top' or 'Continue': "
- +7 SET RARD(0)="S"
- DO SET^RARD
- KILL RARD
- SET X=$EXTRACT(X)
- +8 IF $DATA(RALERTS)
- IF (X="P")
- DO QRPT^RART3
- +9 if X="^"!(X="P")
- QUIT
- if X="C"&($DATA(RAP))
- WRITE @IOF
- +10 QUIT
- +11 ;
- LOCK(X,Y) ; Lock an entry
- +1 WRITE !!,$CHAR(7),"Another user is editing this ",$SELECT(X="R":"report (Case # "_Y_")",1:"exam (diagnostic code)"),". Please try again later."
- HANG 4
- QUIT
- +2 ;
- SETVARS ; Setup Rad/Nuc Med required variables
- +1 IF $ORDER(RACCESS(DUZ,""))=""
- DO SETVARS^RAPSET1(0)
- +2 if '($DATA(RACCESS(DUZ))\10)
- QUIT
- +3 IF $GET(RAIMGTY)=""
- DO SETVARS^RAPSET1(1)
- +4 QUIT