RASTREQ ;HISC/CAH,GJC AISC/MJK-Status Requirements Check Routine ; 06 Oct 2013 11:07 AM
;;5.0;Radiology/Nuclear Medicine;**1,10,23,40,56,99,90,1005**;Mar 16, 1998;Build 13
;Supported IA #10104 UP^XLFSTR
;Supported IA #1367 LKUP^XPDKEY
;Supported IA #10060 ^VA(200
;Supported IA #10076 ^XUSEC(
;Supported IA #2056 GET1^DIQ and GETS^DIQ
; Called by
; (1) Stat Track's [RA STATUS CHANGE]'s fld EXAM STATUS' input transform
; (2) ASK+22^RASTED, if user "^" out of stat trk editing
; (3) Cancel an Exam's [RA CANCEL]'s fld EXAM STATUS' input transform
; (4) Enter Last Past Visit Before DHCP's [RA LAST PAST VISIT]'s ""
;
; Instead of using RAIMGTY, recalculate
; the imaging type using the imaging type on the exam node because
; status updating through report entry/edit, batch verify, and several
; other options is NOT screened by sign-on imaging type, so does not
; stay the same through a user's session.
;
; 'RAMES1' is used to display which Exam Status required fields are
; not populated. This only applies to the 'Status Tracking Of Exams'
; option.
;
; If tracking ^-out, this rtn would be called outside of edt tmpl,
; and thus the DA vars would not be defined, so we need to set them here
;
N RASAVY M RASAVY=Y ;save the value of Y, patch #90
S:'$D(DA)#2 DA=RACNI S:'$D(DA(1))#2 DA(1)=RADTI S:'$D(DA(2))#2 DA(2)=RADFN
; If Fileman enter/edit, we need to define RADFN, RADTI, RACNI so the
; nuc med checks won't bomb
S:'$D(RACNI)#2 RACNI=DA S:'$D(RADTI)#2 RADTI=DA(1) S:'$D(RADFN)#2 RADFN=DA(2)
;
S RAIMGTYI=+$P($G(^RADPT(DA(2),"DT",DA(1),0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U,1),RASAVTYJ=RAIMGTYJ
S RAMES1="W:$G(K)=$P($G(^RA(72,+$G(RANXT72),0)),U,3)&('$D(ZTQUEUED)#2) !?3,""No '"",RAZ,""'"",?35,"" entered for this exam.""" ; display if at the ranext exm stat level
S RAXX=+$G(X)
I '$D(^RA(72,RAXX,0))!(RAIMGTYJ']"") D M Y=RASAVY Q
. K X W:'$D(ZTQUEUED)#2 !?3,"Error: cannot determine Imaging Type of exam. Contact IRM."
. K RAMES1,RAXX
. Q
N RA,RASN,RASTI,RADES,RAOKAY,RA3
; RADES = order seq. desired, RAOKAY= actual order seq. okay'd
S X1=$G(^RA(72,RAXX,0)),RADES=$P(X1,U,3)
I $$LKUP^XPDKEY(+$P(X1,"^",4))]"",'$D(^XUSEC($$LKUP^XPDKEY(+$P(X1,"^",4)),DUZ)) K X W:'$D(ZTQUEUED)#2 !?3,"You do not have the proper access privileges to ",!?3,"change this exam to this status" M Y=RASAVY Q
S RAJ=^RADPT(DA(2),"DT",DA(1),"P",DA,0),RAOR=-1
S RABEFORE=$P($G(^RA(72,+$P(RAJ,U,3),0)),U,3) ; current order seq
; Don't need to set RAORDIFN,RACS,RAPRIT,RAF5
I '$D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D LOOP^RASTREQ1 S RAIMGTYJ=RASAVTYJ
I $D(^RA(72,"AA",RAIMGTYJ,0,RAXX)) D CANCEL^RASTREQ1
S RAIMGTYJ=RASAVTYJ
; Can't use X to determine if status change to next was successful
; due to looping thru all status levels for this img type
; chk if calculated order is at NEXT or higher level
; RAAFTER is set in rastreq1; it has 2 meanings :
; upon return from rastreq1, RAAFTER means highest seq order qualified
; upon exit from this rtn, RAAFTER means actual seq order used
I RABEFORE<RAAFTER D G MSG
. I RADES<RAAFTER S RAOKAY=RADES
. E S RAOKAY=RAAFTER
. Q
I RAAFTER<RABEFORE D G MSG
. I RADES<RAAFTER S RAOKAY=RADES
. E S RAOKAY=RAAFTER
. Q
; at this point RAAFTER=RABEFORE
I RADES<RAAFTER S RAOKAY=RADES
E S RAOKAY=RABEFORE
MSG I RAOKAY=RABEFORE K X W:'$D(ZTQUEUED)#2 !?5," ...exam status not changed" G KOUT2
S X=$O(^RA(72,"AA",RAIMGTYJ,RAOKAY,0))
S:$D(RANEXT) RANEXT=^RA(72,+X,0) ;set existing RANEXT to ok'd status
I RAOKAY<RABEFORE W:'$D(ZTQUEUED)#2 !?5," ...exam status backed down to '",$P($G(^RA(72,+X,0)),U),"'" G KOUT2
I RAOKAY<RADES W:'$D(ZTQUEUED)#2 !!?5," ...though upgraded, new status level (",$P($G(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RAOKAY,0)),0)),U),")",!?5,"is not as high as the desired level (",$P($G(^RA(72,+$O(^RA(72,"AA",RAIMGTYJ,RADES,0)),0)),U),")",!
KOUT1 ; check for higher qualifying status(es)
G:RAOKAY'<RAAFTER!(RAOKAY=9) KOUT2 S RA3=RAOKAY
W !!,"This case also qualifies for higher status(es) :",!
F S RA3=$O(^RA(72,"AA",RAIMGTYJ,RA3)) Q:RA3="" Q:RA3>RAAFTER W:'$D(ZTQUEUED)#2 ?$X+4,$P($G(^RA(72,$O(^(RA3,0)),0)),U)
W:'$D(ZTQUEUED)#2 !!,"Since Status Tracking can only upgrade one status at a time,",!,"please edit this exam again.",!
KOUT2 S RAAFTER=RAOKAY ;return as actual seq order used, not nec. highest
K RAIMGTYI,RAIMGTYJ,RAMES1,RAZ,RAXX,RAJ,RAS,RAK,RAE,X1,RASAVTYJ
M Y=RASAVY
Q
;
1 ;Technologist Check
N DIERR
S RA("TECH")="" I $O(^RADPT(DA(2),"DT",DA(1),"P",DA,"TC",0))>0 S RA("TECH")=+^($O(^(0)),0) S RA("TECH")=$$GET1^DIQ(200,RA("TECH")_",",.01)
I RA("TECH")']"" K X S RAZ="technologist" X:$D(RAMES1) RAMES1
K RA("TECH") Q
;
2 ;Interpreting Physician Check
N DIERR
I $$GET1^DIQ(200,$P(RAJ,"^",12)_",",.01)="",$$GET1^DIQ(200,$P(RAJ,"^",15)_",",.01)="" K X S RAZ="interpreting staff or resident" X:$D(RAMES1) RAMES1
Q
;
3 ;Detailed Procedure Check
S RAZ="detailed procedure" I '$D(^RAMIS(71,+$P(RAJ,"^",2),0)) K X X:$D(RAMES1) RAMES1 Q
S RAJ1=$G(^RAMIS(71,+$P(RAJ,"^",2),0)) I "DS"'[$P(RAJ1,"^",6) K X X:$D(RAMES1) RAMES1 Q
S RAZ="detailed procedure (no CPT code)" I $P(RAJ1,"^",9)']"" K X X:$D(RAMES1) RAMES1 Q
Q
;
4 ;Film Data Check
I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"F",0)) K X S RAZ="film data" X:$D(RAMES1) RAMES1
Q
;
5 ;Diagnostic Code Check
I '$D(^RA(78.3,+$P(RAJ,"^",13),0)) K X S RAZ="diagnostic code" X:$D(RAMES1) RAMES1
Q
;
6 ;Camera/Equipment/Room Check
S RAE=$S($D(RAMDV):$P(RAMDV,"^",9),1:1) I RAE,'$D(^RA(78.6,+$P(RAJ,"^",18),0)) K X S RAZ="camera/equip/room" X:$D(RAMES1) RAMES1
Q
;
11 ;Report Entered and not just a stub rec for Img/PACS Check
I '$D(^RARPT(+$P(RAJ,"^",17),0)) G NORPT
; since there's a rpt ptr, must check if the rpt is just a stub rpt
N RA17,RA0 ; use logic from RAREG
S RA17=+$P(RAJ,"^",17)
I $$STUB^RAEDCN1(RA17) G NORPT ; rpt is an image stub
Q
NORPT ; either no report yet, or report is stub
K X S RAZ="report" X:$D(RAMES1) RAMES1
Q
;
12 ;Report Verified Check
D 11:$P(RAS,"^",11)'="Y" I $D(^RARPT(+$P(RAJ,"^",17),0)),$P(^(0),"^",5)'="V" K X S RAZ="report verification" X:$D(RAMES1) RAMES1
Q
;
16 ;Impression Entry Check
; In Phase 1, for Elec. filed rpts, skip this even if div. param requires it
I $D(^RARPT(+$P(RAJ,"^",17),0)),$P(^(0),"^",5)="EF" Q
I $O(^RARPT(+$P(RAJ,"^",17),"I",0))'>0 K X S RAZ="impression" X:$D(RAMES1) RAMES1
Q
13 ;Procedure Modifers Check
I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"M",0)) K X S RAZ="procedure modifier" X:$D(RAMES1) RAMES1
Q
14 ;CPT Modifiers Check
I '$O(^RADPT(DA(2),"DT",DA(1),"P",DA,"CMOD",0)) K X S RAZ="CPT modifiers" X:$D(RAMES1) RAMES1
Q
;
HELP ; Called from 'Help Text' node in DD(70.03,3,4).
N E,RA
S RAJ=$G(^RADPT(DA(2),"DT",DA(1),"P",DA,0))
S RAIMGTYI=+$P($G(^RADPT(DA(2),"DT",DA(1),0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U,1)
I RAIMGTYJ']"" W !,"ERROR: Cannot determine imaging type of exam!" K FL,K,N,RAIMGTYI,RAIMGTYJ,RAS,RAJ Q
W !,"This exam meets the requirements for the following statuses:"
F K=0:0 S K=$O(^RA(72,"AA",RAIMGTYJ,K)) Q:K'>0 D
. S X="",E=+$O(^RA(72,"AA",RAIMGTYJ,K,0)) Q:E'>0
. I $D(^RA(72,E,0)) D
.. S RA(0)=$G(^RA(72,E,0)),N=$P(RA(0),U),RAS=$G(^RA(72,E,.1))
.. I $L(RAS) D HELP1 I $D(X) W !?10,N S FL="" ;removed D 3, done inside HELP1
.. Q
. Q
W:'$D(FL) !?10,"Does not meet the requirements of any status."
W ! K RAS,RAJ,N,K,FL,RAIMGTYI,RAIMGTYJ
Q
HELP1 ; Called from 'HELP' above and 'STUFF^RASTREQ1'
; 'RAJ' -> 0 node of the examination
; 'E' -> ien of the examination status
; Both 'RAJ' & 'E' set in 'HELP' & 'STUFF^RASTREQ1'
;
;start of p99, exam status UNCHANGED if pregnancy screen is not answered for female pt bet ages 12-55
N RAPTAGE,RASAVE
S RASAVE=X ;save the value of X, since it's being replaced in DIQ call.
S RAPTAGE=$$PTAGE^RAUTL8(DA(2),"")
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $$PTSEX^RAUTL8(DA(2))="F",((RAPTAGE>11)&(RAPTAGE<56)),$$GET1^DIQ(70.03,DA_","_DA(1)_","_DA(2),32)="" S E=$P(RAJ,U,3),(N,X)="" S:$G(E) (N,X)=$P($G(^RA(72,E,0)),U) Q
I $$PTSEX^RAUTL8(DA(2))'="M",((RAPTAGE>11)&(RAPTAGE<56)),$$GET1^DIQ(70.03,DA_","_DA(1)_","_DA(2),32)="" S E=$P(RAJ,U,3),(N,X)="" S:$G(E) (N,X)=$P($G(^RA(72,E,0)),U) Q
;
S X=RASAVE
;end p99
N RADIO,RADIOUZD,RAS5 S RADIO=$S($G(^RA(72,E,.5))]"":$G(^(.5)),1:"N")
S:$P($G(^RA(79.2,+RAIMGTYI,0)),"^",5)="Y" RADIOUZD=""
;
; Phase 1 Outside Reporting 100% outside work, skip all except Diag. Code
I $D(^RARPT(+$P(RAJ,"^",17),0)),$P(^(0),"^",5)="EF" S RAS5=$P(RAS,U,5),RAS="",$P(RAS,U,5)=RAS5 K RADIOUZD
;
F RAK=1:1 Q:$P(RAS,"^",RAK,99)']"" D:$P(RAS,"^",RAK)="Y" @RAK
I $D(X),$P(RAS,"^",3)'="Y",$D(^RA(72,"AA",RAIMGTYJ,9,E)) D 3
I $D(X),$P(RAS,"^",16)'="Y",$D(^RA(72,"AA",RAIMGTYJ,9,E)),$D(^RA(79,+$P(^RADPT(DA(2),"DT",DA(1),0),"^",3),.1)),$P(^(.1),"^",16)="Y" D 16
I $D(RADIOUZD) D ;if Radiopharm Used, then check req'd NucMed flds
. D EN1^RASTREQN(RADIO,RAJ)
. I $D(X),($$UP^XLFSTR($P($G(^RA(72,E,.6)),"^",11)="Y")) D EN1^RADOSTIK(RADFN,RADTI,RACNI)
. Q
Q
RASTREQ ;HISC/CAH,GJC AISC/MJK-Status Requirements Check Routine ; 06 Oct 2013 11:07 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**1,10,23,40,56,99,90,1005**;Mar 16, 1998;Build 13
+2 ;Supported IA #10104 UP^XLFSTR
+3 ;Supported IA #1367 LKUP^XPDKEY
+4 ;Supported IA #10060 ^VA(200
+5 ;Supported IA #10076 ^XUSEC(
+6 ;Supported IA #2056 GET1^DIQ and GETS^DIQ
+7 ; Called by
+8 ; (1) Stat Track's [RA STATUS CHANGE]'s fld EXAM STATUS' input transform
+9 ; (2) ASK+22^RASTED, if user "^" out of stat trk editing
+10 ; (3) Cancel an Exam's [RA CANCEL]'s fld EXAM STATUS' input transform
+11 ; (4) Enter Last Past Visit Before DHCP's [RA LAST PAST VISIT]'s ""
+12 ;
+13 ; Instead of using RAIMGTY, recalculate
+14 ; the imaging type using the imaging type on the exam node because
+15 ; status updating through report entry/edit, batch verify, and several
+16 ; other options is NOT screened by sign-on imaging type, so does not
+17 ; stay the same through a user's session.
+18 ;
+19 ; 'RAMES1' is used to display which Exam Status required fields are
+20 ; not populated. This only applies to the 'Status Tracking Of Exams'
+21 ; option.
+22 ;
+23 ; If tracking ^-out, this rtn would be called outside of edt tmpl,
+24 ; and thus the DA vars would not be defined, so we need to set them here
+25 ;
+26 ;save the value of Y, patch #90
NEW RASAVY
MERGE RASAVY=Y
+27 IF '$DATA(DA)#2
SET DA=RACNI
IF '$DATA(DA(1))#2
SET DA(1)=RADTI
IF '$DATA(DA(2))#2
SET DA(2)=RADFN
+28 ; If Fileman enter/edit, we need to define RADFN, RADTI, RACNI so the
+29 ; nuc med checks won't bomb
+30 IF '$DATA(RACNI)#2
SET RACNI=DA
IF '$DATA(RADTI)#2
SET RADTI=DA(1)
IF '$DATA(RADFN)#2
SET RADFN=DA(2)
+31 ;
+32 SET RAIMGTYI=+$PIECE($GET(^RADPT(DA(2),"DT",DA(1),0)),U,2)
SET RAIMGTYJ=$PIECE($GET(^RA(79.2,+RAIMGTYI,0)),U,1)
SET RASAVTYJ=RAIMGTYJ
+33 ; display if at the ranext exm stat level
SET RAMES1="W:$G(K)=$P($G(^RA(72,+$G(RANXT72),0)),U,3)&('$D(ZTQUEUED)#2) !?3,""No '"",RAZ,""'"",?35,"" entered for this exam."""
+34 SET RAXX=+$GET(X)
+35 IF '$DATA(^RA(72,RAXX,0))!(RAIMGTYJ']"")
Begin DoDot:1
+36 KILL X
IF '$DATA(ZTQUEUED)#2
WRITE !?3,"Error: cannot determine Imaging Type of exam. Contact IRM."
+37 KILL RAMES1,RAXX
+38 QUIT
End DoDot:1
MERGE Y=RASAVY
QUIT
+39 NEW RA,RASN,RASTI,RADES,RAOKAY,RA3
+40 ; RADES = order seq. desired, RAOKAY= actual order seq. okay'd
+41 SET X1=$GET(^RA(72,RAXX,0))
SET RADES=$PIECE(X1,U,3)
+42 IF $$LKUP^XPDKEY(+$PIECE(X1,"^",4))]""
IF '$DATA(^XUSEC($$LKUP^XPDKEY(+$PIECE(X1,"^",4)),DUZ))
KILL X
IF '$DATA(ZTQUEUED)#2
WRITE !?3,"You do not have the proper access privileges to ",!?3,"change this exam to this status"
MERGE Y=RASAVY
QUIT
+43 SET RAJ=^RADPT(DA(2),"DT",DA(1),"P",DA,0)
SET RAOR=-1
+44 ; current order seq
SET RABEFORE=$PIECE($GET(^RA(72,+$PIECE(RAJ,U,3),0)),U,3)
+45 ; Don't need to set RAORDIFN,RACS,RAPRIT,RAF5
+46 IF '$DATA(^RA(72,"AA",RAIMGTYJ,0,RAXX))
DO LOOP^RASTREQ1
SET RAIMGTYJ=RASAVTYJ
+47 IF $DATA(^RA(72,"AA",RAIMGTYJ,0,RAXX))
DO CANCEL^RASTREQ1
+48 SET RAIMGTYJ=RASAVTYJ
+49 ; Can't use X to determine if status change to next was successful
+50 ; due to looping thru all status levels for this img type
+51 ; chk if calculated order is at NEXT or higher level
+52 ; RAAFTER is set in rastreq1; it has 2 meanings :
+53 ; upon return from rastreq1, RAAFTER means highest seq order qualified
+54 ; upon exit from this rtn, RAAFTER means actual seq order used
+55 IF RABEFORE<RAAFTER
Begin DoDot:1
+56 IF RADES<RAAFTER
SET RAOKAY=RADES
+57 IF '$TEST
SET RAOKAY=RAAFTER
+58 QUIT
End DoDot:1
GOTO MSG
+59 IF RAAFTER<RABEFORE
Begin DoDot:1
+60 IF RADES<RAAFTER
SET RAOKAY=RADES
+61 IF '$TEST
SET RAOKAY=RAAFTER
+62 QUIT
End DoDot:1
GOTO MSG
+63 ; at this point RAAFTER=RABEFORE
+64 IF RADES<RAAFTER
SET RAOKAY=RADES
+65 IF '$TEST
SET RAOKAY=RABEFORE
MSG IF RAOKAY=RABEFORE
KILL X
IF '$DATA(ZTQUEUED)#2
WRITE !?5," ...exam status not changed"
GOTO KOUT2
+1 SET X=$ORDER(^RA(72,"AA",RAIMGTYJ,RAOKAY,0))
+2 ;set existing RANEXT to ok'd status
IF $DATA(RANEXT)
SET RANEXT=^RA(72,+X,0)
+3 IF RAOKAY<RABEFORE
IF '$DATA(ZTQUEUED)#2
WRITE !?5," ...exam status backed down to '",$PIECE($GET(^RA(72,+X,0)),U),"'"
GOTO KOUT2
+4 IF RAOKAY<RADES
IF '$DATA(ZTQUEUED)#2
WRITE !!?5," ...though upgraded, new status level (",$PIECE($GET(^RA(72,+$ORDER(^RA(72,"AA",RAIMGTYJ,RAOKAY,0)),0)),U),")",!?5,"is not as high as the desired level (",$PIECE($GET(^RA(72,+$ORDER(^RA(72,"AA",RAIMGTYJ,RADES,0)),0)),U),")",
!
KOUT1 ; check for higher qualifying status(es)
+1 IF RAOKAY'<RAAFTER!(RAOKAY=9)
GOTO KOUT2
SET RA3=RAOKAY
+2 WRITE !!,"This case also qualifies for higher status(es) :",!
+3 FOR
SET RA3=$ORDER(^RA(72,"AA",RAIMGTYJ,RA3))
IF RA3=""
QUIT
IF RA3>RAAFTER
QUIT
IF '$DATA(ZTQUEUED)#2
WRITE ?$X+4,$PIECE($GET(^RA(72,$ORDER(^(RA3,0)),0)),U)
+4 IF '$DATA(ZTQUEUED)#2
WRITE !!,"Since Status Tracking can only upgrade one status at a time,",!,"please edit this exam again.",!
KOUT2 ;return as actual seq order used, not nec. highest
SET RAAFTER=RAOKAY
+1 KILL RAIMGTYI,RAIMGTYJ,RAMES1,RAZ,RAXX,RAJ,RAS,RAK,RAE,X1,RASAVTYJ
+2 MERGE Y=RASAVY
+3 QUIT
+4 ;
1 ;Technologist Check
+1 NEW DIERR
+2 SET RA("TECH")=""
IF $ORDER(^RADPT(DA(2),"DT",DA(1),"P",DA,"TC",0))>0
SET RA("TECH")=+^($ORDER(^(0)),0)
SET RA("TECH")=$$GET1^DIQ(200,RA("TECH")_",",.01)
+3 IF RA("TECH")']""
KILL X
SET RAZ="technologist"
IF $DATA(RAMES1)
XECUTE RAMES1
+4 KILL RA("TECH")
QUIT
+5 ;
2 ;Interpreting Physician Check
+1 NEW DIERR
+2 IF $$GET1^DIQ(200,$PIECE(RAJ,"^",12)_",",.01)=""
IF $$GET1^DIQ(200,$PIECE(RAJ,"^",15)_",",.01)=""
KILL X
SET RAZ="interpreting staff or resident"
IF $DATA(RAMES1)
XECUTE RAMES1
+3 QUIT
+4 ;
3 ;Detailed Procedure Check
+1 SET RAZ="detailed procedure"
IF '$DATA(^RAMIS(71,+$PIECE(RAJ,"^",2),0))
KILL X
IF $DATA(RAMES1)
XECUTE RAMES1
QUIT
+2 SET RAJ1=$GET(^RAMIS(71,+$PIECE(RAJ,"^",2),0))
IF "DS"'[$PIECE(RAJ1,"^",6)
KILL X
IF $DATA(RAMES1)
XECUTE RAMES1
QUIT
+3 SET RAZ="detailed procedure (no CPT code)"
IF $PIECE(RAJ1,"^",9)']""
KILL X
IF $DATA(RAMES1)
XECUTE RAMES1
QUIT
+4 QUIT
+5 ;
4 ;Film Data Check
+1 IF '$ORDER(^RADPT(DA(2),"DT",DA(1),"P",DA,"F",0))
KILL X
SET RAZ="film data"
IF $DATA(RAMES1)
XECUTE RAMES1
+2 QUIT
+3 ;
5 ;Diagnostic Code Check
+1 IF '$DATA(^RA(78.3,+$PIECE(RAJ,"^",13),0))
KILL X
SET RAZ="diagnostic code"
IF $DATA(RAMES1)
XECUTE RAMES1
+2 QUIT
+3 ;
6 ;Camera/Equipment/Room Check
+1 SET RAE=$SELECT($DATA(RAMDV):$PIECE(RAMDV,"^",9),1:1)
IF RAE
IF '$DATA(^RA(78.6,+$PIECE(RAJ,"^",18),0))
KILL X
SET RAZ="camera/equip/room"
IF $DATA(RAMES1)
XECUTE RAMES1
+2 QUIT
+3 ;
11 ;Report Entered and not just a stub rec for Img/PACS Check
+1 IF '$DATA(^RARPT(+$PIECE(RAJ,"^",17),0))
GOTO NORPT
+2 ; since there's a rpt ptr, must check if the rpt is just a stub rpt
+3 ; use logic from RAREG
NEW RA17,RA0
+4 SET RA17=+$PIECE(RAJ,"^",17)
+5 ; rpt is an image stub
IF $$STUB^RAEDCN1(RA17)
GOTO NORPT
+6 QUIT
NORPT ; either no report yet, or report is stub
+1 KILL X
SET RAZ="report"
IF $DATA(RAMES1)
XECUTE RAMES1
+2 QUIT
+3 ;
12 ;Report Verified Check
+1 IF $PIECE(RAS,"^",11)'="Y"
DO 11
IF $DATA(^RARPT(+$PIECE(RAJ,"^",17),0))
IF $PIECE(^(0),"^",5)'="V"
KILL X
SET RAZ="report verification"
IF $DATA(RAMES1)
XECUTE RAMES1
+2 QUIT
+3 ;
16 ;Impression Entry Check
+1 ; In Phase 1, for Elec. filed rpts, skip this even if div. param requires it
+2 IF $DATA(^RARPT(+$PIECE(RAJ,"^",17),0))
IF $PIECE(^(0),"^",5)="EF"
QUIT
+3 IF $ORDER(^RARPT(+$PIECE(RAJ,"^",17),"I",0))'>0
KILL X
SET RAZ="impression"
IF $DATA(RAMES1)
XECUTE RAMES1
+4 QUIT
13 ;Procedure Modifers Check
+1 IF '$ORDER(^RADPT(DA(2),"DT",DA(1),"P",DA,"M",0))
KILL X
SET RAZ="procedure modifier"
IF $DATA(RAMES1)
XECUTE RAMES1
+2 QUIT
14 ;CPT Modifiers Check
+1 IF '$ORDER(^RADPT(DA(2),"DT",DA(1),"P",DA,"CMOD",0))
KILL X
SET RAZ="CPT modifiers"
IF $DATA(RAMES1)
XECUTE RAMES1
+2 QUIT
+3 ;
HELP ; Called from 'Help Text' node in DD(70.03,3,4).
+1 NEW E,RA
+2 SET RAJ=$GET(^RADPT(DA(2),"DT",DA(1),"P",DA,0))
+3 SET RAIMGTYI=+$PIECE($GET(^RADPT(DA(2),"DT",DA(1),0)),U,2)
SET RAIMGTYJ=$PIECE($GET(^RA(79.2,+RAIMGTYI,0)),U,1)
+4 IF RAIMGTYJ']""
WRITE !,"ERROR: Cannot determine imaging type of exam!"
KILL FL,K,N,RAIMGTYI,RAIMGTYJ,RAS,RAJ
QUIT
+5 WRITE !,"This exam meets the requirements for the following statuses:"
+6 FOR K=0:0
SET K=$ORDER(^RA(72,"AA",RAIMGTYJ,K))
IF K'>0
QUIT
Begin DoDot:1
+7 SET X=""
SET E=+$ORDER(^RA(72,"AA",RAIMGTYJ,K,0))
IF E'>0
QUIT
+8 IF $DATA(^RA(72,E,0))
Begin DoDot:2
+9 SET RA(0)=$GET(^RA(72,E,0))
SET N=$PIECE(RA(0),U)
SET RAS=$GET(^RA(72,E,.1))
+10 ;removed D 3, done inside HELP1
IF $LENGTH(RAS)
DO HELP1
IF $DATA(X)
WRITE !?10,N
SET FL=""
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF '$DATA(FL)
WRITE !?10,"Does not meet the requirements of any status."
+14 WRITE !
KILL RAS,RAJ,N,K,FL,RAIMGTYI,RAIMGTYJ
+15 QUIT
HELP1 ; Called from 'HELP' above and 'STUFF^RASTREQ1'
+1 ; 'RAJ' -> 0 node of the examination
+2 ; 'E' -> ien of the examination status
+3 ; Both 'RAJ' & 'E' set in 'HELP' & 'STUFF^RASTREQ1'
+4 ;
+5 ;start of p99, exam status UNCHANGED if pregnancy screen is not answered for female pt bet ages 12-55
+6 NEW RAPTAGE,RASAVE
+7 ;save the value of X, since it's being replaced in DIQ call.
SET RASAVE=X
+8 SET RAPTAGE=$$PTAGE^RAUTL8(DA(2),"")
+9 ;
+10 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+11 ;I $$PTSEX^RAUTL8(DA(2))="F",((RAPTAGE>11)&(RAPTAGE<56)),$$GET1^DIQ(70.03,DA_","_DA(1)_","_DA(2),32)="" S E=$P(RAJ,U,3),(N,X)="" S:$G(E) (N,X)=$P($G(^RA(72,E,0)),U) Q
+12 IF $$PTSEX^RAUTL8(DA(2))'="M"
IF ((RAPTAGE>11)&(RAPTAGE<56))
IF $$GET1^DIQ(70.03,DA_","_DA(1)_","_DA(2),32)=""
SET E=$PIECE(RAJ,U,3)
SET (N,X)=""
IF $GET(E)
SET (N,X)=$PIECE($GET(^RA(72,E,0)),U)
QUIT
+13 ;
+14 SET X=RASAVE
+15 ;end p99
+16 NEW RADIO,RADIOUZD,RAS5
SET RADIO=$SELECT($GET(^RA(72,E,.5))]"":$GET(^(.5)),1:"N")
+17 IF $PIECE($GET(^RA(79.2,+RAIMGTYI,0)),"^",5)="Y"
SET RADIOUZD=""
+18 ;
+19 ; Phase 1 Outside Reporting 100% outside work, skip all except Diag. Code
+20 IF $DATA(^RARPT(+$PIECE(RAJ,"^",17),0))
IF $PIECE(^(0),"^",5)="EF"
SET RAS5=$PIECE(RAS,U,5)
SET RAS=""
SET $PIECE(RAS,U,5)=RAS5
KILL RADIOUZD
+21 ;
+22 FOR RAK=1:1
IF $PIECE(RAS,"^",RAK,99)']""
QUIT
IF $PIECE(RAS,"^",RAK)="Y"
DO @RAK
+23 IF $DATA(X)
IF $PIECE(RAS,"^",3)'="Y"
IF $DATA(^RA(72,"AA",RAIMGTYJ,9,E))
DO 3
+24 IF $DATA(X)
IF $PIECE(RAS,"^",16)'="Y"
IF $DATA(^RA(72,"AA",RAIMGTYJ,9,E))
IF $DATA(^RA(79,+$PIECE(^RADPT(DA(2),"DT",DA(1),0),"^",3),.1))
IF $PIECE(^(.1),"^",16)="Y"
DO 16
+25 ;if Radiopharm Used, then check req'd NucMed flds
IF $DATA(RADIOUZD)
Begin DoDot:1
+26 DO EN1^RASTREQN(RADIO,RAJ)
+27 IF $DATA(X)
IF ($$UP^XLFSTR($PIECE($GET(^RA(72,E,.6)),"^",11)="Y"))
DO EN1^RADOSTIK(RADFN,RADTI,RACNI)
+28 QUIT
End DoDot:1
+29 QUIT
