Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RASTEXT

RASTEXT.m

Go to the documentation of this file. 
  1. RASTEXT ;HISC/CAH,FPT,GJC AISC/TMP,TAC,RMO-Called by Status Tracking display,edit. Allow selection/edit of case if called from edit option ;7/16/04  07:50 [ 12/05/2011  10:09 AM ]
  1.  ;;5.0;Radiology/Nuclear Medicine;**48,47*1004**;Mar 16, 1998;Build 21
  1.  S RAED=1 ;If called from beginning of routine, allow case edit
  1.  ;If called at EN1, display exams by status but don't allow editing
  1. EN1 D SET^RAPSET1 I $D(XQUIT) K RAED,XQUIT Q
  1.  D HOME^%ZIS S:'$D(RAED) RAED=0 S (RACTR,RAORD,RAXIT)=0 K RASTAT,RADTI
  1.  N RADLOCS,RAQUIT,RATEMP,RATOTAL S (RATOTAL,X)=0
  1.  F  S X=$O(^RA(79.1,X)) Q:X'>0  D
  1.  . S Y=$G(^RA(79.1,X,0)),Y(6)=+$P(Y,U,6) Q:'Y(6)
  1.  . I $D(RACCESS(DUZ,"LOC",+X)),(Y(6)=+$O(^RA(79.2,"B",RAIMGTY,0))),($D(RACCESS(DUZ,"DIV",+RAMDIV,X))) D
  1.  .. S RATOTAL=RATOTAL+1,RATEMP=$P($G(^SC(+$P(Y,"^"),0)),"^")_"^"_X
  1.  .. Q
  1.  . Q
  1.  I 'RATOTAL D  D Q QUIT
  1.  . W !?5,"Your access to Imaging Locations is nonexistent."
  1.  . W !?5,"Contact your ADPAC for further assistance."
  1.  . Q
  1.  W !!?5,"Current Division: ",$P(^DIC(4,+RAMDIV,0),U,1)
  1.  W !?5,"Current Imaging Type: ",RAIMGTY,!
  1.  I RATOTAL=1 D
  1.  . N DIR,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR
  1.  . S:'+Y RAXIT=1 Q:RAXIT
  1.  . S ^TMP($J,"RADLOCS",$P(RATEMP,"^"),$P(RATEMP,"^",2))=""
  1.  . S RADLOCS($P(RATEMP,"^"),$P(RATEMP,"^",2))="",RAQUIT=0
  1.  . Q
  1.  I RAXIT D Q QUIT
  1.  K X,Y I RATOTAL>1 D
  1.  . N RAARRY,RADIC,RAUTIL
  1.  . S RADIC="^RA(79.1,",(RAARRY,RAUTIL)="RADLOCS",RADIC(0)="QEAFMZ"
  1.  . S RADIC("A")="Select the Location(s) you wish to track: "
  1.  . S RADIC("B")="All"
  1.  . S RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+RAMDIV,+Y)),(+$P(^(0),""^"",6)=+$O(^RA(79.2,""B"",RAIMGTY,0)))"
  1.  . D EN1^RASELCT(.RADIC,RAUTIL,RAARRY)
  1.  . Q
  1.  I +$G(RAQUIT) D Q Q
  1.  K ^TMP($J,"RADLOCS")
  1.  S RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0)) G Q:'RAIMGTYI
  1.  ; set up RASEQARR(order seq)=ien of file 72
  1.  ; if order seq is null, set it to -1, -2, etc., so each img typ gets
  1.  ; gets a different negative subscript to represent a null order seq
  1.  S X=0 F  S X=$O(^RADPT("AS",X)) Q:X'=+X  I $P($G(^RA(72,X,0)),U,7)=RAIMGTYI,$P(^(0),U,5)="Y" S RAX=$P(^(0),U,3) D:RAX=""  S RASEQARR(RAX)=X
  1.  . S RAX=$O(RASEQARR(""))
  1.  . I RAX>0 S RAX=-1 Q
  1.  . S:RAX<0 RAX=RAX-1
  1.  S RAORD=""
  1.  F  K ^TMP($J,"RASTEXT") S RAORD=$O(RASEQARR(RAORD)) Q:RAORD=""!(RAORD>8)  S RASTAT=RASEQARR(RAORD) I $D(^RA(72,+RASTAT,0)),$P(^(0),"^",5)="Y" D START I RACTR S RACTR=0 D SCRN Q:RAQ
  1.  I 'RACTR&('$D(RADTI)) W *7,!,"No incomplete statuses on file"
  1.  G Q
  1. START S (RACTR,RAQ)=0 F RADFN=0:0 S RADFN=$O(^RADPT("AS",RASTAT,RADFN)) Q:RADFN'>0  F RADTI=0:0 S RADTI=$O(^RADPT("AS",RASTAT,RADFN,RADTI)) Q:RADTI'>0  I $D(^RADPT(RADFN,"DT",RADTI,0)) S Y=^(0) D GETCN
  1.  Q
  1. GETCN Q:'$D(^RA(79.1,+$P(Y,"^",4),0))  ;If imaging loc is broken pointer
  1.  Q:'$D(RADLOCS($P($G(^SC(+$P($G(^RA(79.1,+$P(Y,"^",4),0)),"^"),0)),"^")))
  1.  F RACNI=0:0 S RACNI=$O(^RADPT("AS",RASTAT,RADFN,RADTI,RACNI)) Q:RACNI'>0  I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S Y(0)=^(0) D EXT
  1.  Q
  1. EXT F RAI=1:1 Q:'$D(^TMP($J,"RASTEXT",+Y,RAI))
  1.  S:$D(^XUSEC("RA MGR",DUZ))!(RAMDIV=+$P(Y,"^",3)) ^TMP($J,"RASTEXT",+Y,RAI)=RADFN_"^"_+Y(0)_"^"_$P(Y(0),"^",2)_"^"_$P(Y(0),"^",18),RACTR=1
  1.  Q
  1.  ;
  1. SCRN D HD F RADTI=0:0 Q:RAQ!(RADTI="")!(RAXIT)  S RADTI=$O(^TMP($J,"RASTEXT",RADTI)) Q:RADTI'>0  F I1=0:0 S I1=$O(^TMP($J,"RASTEXT",RADTI,I1)) Q:I1'>0!(RAXIT)  D:$$LMAX HD D WRT D:$$LMAX SELECT^RASTEXT1 Q:RAQ!(RADTI'>0)!(RAXIT)
  1.  Q:RAQ!(RAXIT)  D:$$LMAX HD
  1.  D SELECT^RASTEXT1 Q:RAQ!(RAXIT)
  1.  G SCRN:RADTI=0
  1.  Q
  1.  ;
  1. WRT I $P(RADTI,".")=DT S X=RADTI D TIME^RAUTL1 S RATI=X
  1.  I $P(RADTI,".")'=DT S RATI=$E(RADTI,4,5)_"/"_$E(RADTI,6,7)_"/"_$E(RADTI,2,3)
  1.  S RACTR=RACTR+1
  1.  N RASSAN,RACNDSP,RADFNXX,RADTIXX,RACNIXX
  1.  S RADFNXX=+^TMP($J,"RASTEXT",RADTI,I1),RADTIXX=9999999.9999-RADTI
  1.  S RACNIXX=I1,RASSAN=$$SSANVAL^RAHLRU1(RADFNXX,RADTIXX,RACNIXX)
  1.  S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(^TMP($J,"RASTEXT",RADTI,I1),"^",2))
  1.  ;
  1.  ;IHS/CMI/DAY - Patch 1004 - Add IHS HRNO to Display
  1.  ;VA Patch 47 adds use of Site Specific Accession Numbers, which
  1.  ;squeezes the display even more.  Previous IHS patches added a
  1.  ;column for the IHS HRNO, but we need to squeeze it into the name
  1.  ;I $$USESSAN^RAHLRU1() D
  1.  ;.W !,?1,RACNDSP,?18,$J(RATI,8),?27,$E($S($D(^DPT(+^TMP($J,"RASTEXT",RADTI,I1),0)):$P(^(0),"^"),1:"Unknown"),1,18),?46,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown")
  1.  ;I '$$USESSAN^RAHLRU1() D
  1.  ;.W !,?1,$P(^TMP($J,"RASTEXT",RADTI,I1),"^",2),?10,$J(RATI,8),?20,$E($S($D(^DPT(+^TMP($J,"RASTEXT",RADTI,I1),0)):$P(^(0),"^"),1:"Unknown"),1,20),?42,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown")
  1.  ;--> Set HRNO and Name
  1.  N RAZZHRNM
  1.  S RAZZHRNM=$$HRCN^BDGF2($P(^TMP($J,"RASTEXT",RADTI,I1),U),+$G(DUZ(2)))
  1.  S RAZZHRNM=RAZZHRNM_"-"_$S($D(^DPT(+^TMP($J,"RASTEXT",RADTI,I1),0)):$P(^(0),"^"),1:"Unknown")
  1.  I $$USESSAN^RAHLRU1() D
  1.  .W !,?1,RACNDSP,?18,$J(RATI,8),?27,$E(RAZZHRNM,1,18),?46,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown")
  1.  I '$$USESSAN^RAHLRU1() D
  1.  .W !,?1,$P(^TMP($J,"RASTEXT",RADTI,I1),"^",2),?10,$J(RATI,8),?20,$E(RAZZHRNM,1,20),?42,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown")
  1.  ;End Patch
  1.  ;
  1.  W:$D(^RA(78.6,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",4),0)) ?72,$E($P(^(0),"^"),1,8)
  1.  Q
  1.  ;
  1. HD N RADIVHD,RAGENTXT
  1.  S X=$H D NOW^RAUTL1 S RATIME=X,RASTOUT=$S($D(^RA(72,RASTAT,0)):$P(^(0),"^"),1:"")
  1.  S RALOC(0)=$P(RAMLC,"^"),RALOC(1)=$P($G(^RA(79.1,RALOC(0),0)),"^")
  1.  S RALOC=$P($G(^SC(RALOC(1),0)),"^"),RADIV=$P($G(^DIC(4,+RAMDIV,0)),"^")
  1.  S RADIVHD="Division: "_RADIV
  1.  S RAGENTXT="Exam Status Tracking Module"
  1.  W @IOF,!?1,RAGENTXT,?39,RADIVHD
  1.  W !?1,"Date    : ",$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3),"  ",RATIME,?39,"Status  : ",RASTOUT
  1.  W !?1,"Locations: " S X="" F  S X=$O(RADLOCS(X)) Q:X']""  W:($X+$L(X))>IOM !?($X+5) W X W:$O(RADLOCS(X))'="" ?($X+5)
  1.  I $$USESSAN^RAHLRU1() D
  1.  .W !!?1,"Case #",?18,"Date",?27,"Patient",?46,"Procedure",?72,"Equip/Rm",!
  1.  .W ?1,"----------------",?18,"----",?27,"-------",?46,"---------",?72,"--------"
  1.  I '$$USESSAN^RAHLRU1() D
  1.  .W !!?1,"Case #",?10,"Date",?20,"Patient",?42,"Procedure",?72,"Equip/Rm",!
  1.  .W ?1,"------",?10,"----",?20,"-------",?42,"---------",?72,"--------"
  1.  Q
  1. Q ; Kill and quit
  1.  K %,%H,%W,%Y,%Y1,A,C,DIC,I,I1,ORX,POP,RACNI,RACNT,RACONTIN,RACS,RACTR,RADA,RADATE,RADFN,RADIV,RADTI,RAED,RAJ1,RAI,RAIMAGE,RALOC,RAMIS,RANODE,RAORD,RAPRIT,RAQ,RASTAT,RASTOUT,RATI,RATICTR,RATIME,RATXTLP,RAX,RAXIT,SDCLST,X,XQUIT,Y
  1.  K RASEQARR
  1.  K ^TMP($J,"RASTEXT"),^TMP($J,"RAEX")
  1.  D KILLVAR^RAUTL2,KMV^RAUTL15
  1.  K DIOV,RAOR,X1
  1.  Q
  1. LMAX() ;
  1.  Q:($Y+4)>IOSL 1
  1.  Q 0