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

BRARPT1.m

Go to the documentation of this file. 
  1. BRARPT1 ; IHS/ADC/PDW - Radiology Exam Roster by Proc, Rad, Diag Code. ;    
  1.  ;;5.0;Radiology/Nuclear Medicine;;Feb 20, 2004
  1.  ;
  1.  D ^XBKVAR K BRADIC
  1. PROMPT ;
  1.  ;S:'$D(IOF) IOF="!!" ;CMTD OUT IHS/ISD/EDE 04/01/97
  1.  ;W @IOF,!?10 F I=1:1:62 W "-"
  1.  W !!,?10 F I=1:1:62 W "-" ; REPLACED W @IOF WITH W !!
  1.  W !?10,"| ***  EXAM ROSTER BY RADIOLOGIST, PROCEDURE, DIAG CODE  *** |"
  1.  W !?10 F I=1:1:62 W "-"
  1.  ;
  1.  ;---> GET DATE RANGE, RETURNS "RABEGDT" AND "RAENDDT".
  1.  D DATE^RAUTL G:RAPOP EXIT
  1.  S RABEGDT=BEGDATE,RAENDDT=ENDDATE
  1.  ;
  1.  S BRAY=0
  1. PROC ;---> SELECT PROCEDURES.
  1.  S BRADIR="procedure",BRADIC=71
  1.  S BRAVAR="RAPRC",BRAGBL="^RAMIS(71,"
  1.  D SELECT
  1.  G:'BRAY EXIT
  1.  ;
  1. RAD ;---> SELECT RADIOLOGISTS.
  1.  S BRADIR="radiologist",BRAVAR="RARAD",BRAGBL="^VA(200,"
  1.  S BRADIC=200,BRADIC("S")="I $D(^VA(200,""ARC"",""S"",Y))"
  1.  D SELECT K BRADIC("S")
  1.  G:'BRAY EXIT
  1.  ;
  1. DIAG ;---> SELECT DIAGNOSTIC CODES.
  1.  S BRADIR="diagnostic code",BRADIC=78.3
  1.  S BRAVAR="RADIAG",BRAGBL="^RA(78.3,"
  1.  D SELECT
  1.  G:'BRAY EXIT
  1.  ;
  1. TASKMAN ;---> TASKMAN STUFF.
  1.  S ZTRTN="START^BRARPT1"
  1.  F RASV="RABEGDT","RAENDDT","RAPRC(","RARAD(","RADIAG(" D
  1.  .S ZTSAVE(RASV)=""
  1.  ;
  1. DEV ;---> GET DEVICE AND/OR QUEUE.
  1.  W ! D ZIS^RAUTL G:RAPOP EXIT
  1.  ;
  1. START ;---> TASKMAN STARTING POINT.
  1.  D SORT
  1.  ;
  1. PRINT D ^BRARPT2
  1.  ;
  1. EXIT ;
  1.  K DIC,DIR,DIRUT,I,N,O,P,RAPOP,Q,R,RABEGDT,RACNI,RAD0,RADFN,RADIAG,RADTE
  1.  K RADTI,RAEND,RAENDDT,RAMES,RANAME,RAP0,RAPAGE,RAPRC,RARAD,RASV,BRADIC
  1.  K BRADIR,BRAGBL,BRAVAR,BRAY,^TMP($J,"RA"),X,Y,ZTDESC,ZTRTN,ZTSAVE
  1.  Q
  1.  ;
  1.  ;
  1. SORT ;---> SORT EXAMS FOR SELECTED CRITERIA.
  1.  K ^TMP($J,"RA")
  1.  S RADTE=RABEGDT-.0001,RAEND=RAENDDT+.9999
  1.  F  S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>RAEND)  D
  1.  .S RADTI=9999999.9999-RADTE
  1.  .D RADFN
  1.  Q
  1.  ;
  1. RADFN S RADFN=0
  1.  F  S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0  D
  1.  .Q:'$D(^RADPT(RADFN,"DT",RADTI,0))
  1.  .;---> RAD0=ZERO NODE OF VISIT.
  1.  .S RAD0=^RADPT(RADFN,"DT",RADTI,0)
  1.  .D RACNI
  1.  Q
  1.  ;
  1. RACNI S RACNI=0
  1.  F  S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0  D
  1.  .Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
  1.  .;---> RAP0=ZERO NODE OF EXAM.
  1.  .S RAP0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
  1.  .;---> IF NOT ALL PROCEDURES, THEN QUIT IF NOT ONE OF THE SELECTED.
  1.  .Q:'$P(RAP0,U,2)  I '$D(RAPRC("ALL")) Q:'$D(RAPRC($P(RAP0,U,2)))
  1.  .;---> IF NOT ALL RADIOLOGISTS, THEN QUIT IF NOT ONE OF THE SELECTED.
  1.  .I '$D(RARAD("ALL")) Q:'$P(RAP0,U,15)  Q:'$D(RARAD($P(RAP0,U,15)))
  1.  .;---> IF NOT ALL DIAG CODES, THEN QUIT IF NOT ONE OF THE SELECTED.
  1.  .I '$D(RADIAG("ALL")) Q:'$P(RAP0,U,13)  Q:'$D(RADIAG($P(RAP0,U,13)))
  1.  .D SET
  1.  Q
  1. SET ;
  1.  ;---> GET DIVISION SUBSCRIPT.
  1.  S RADIV=$S($D(^RA(79,+$P(RAD0,"^",3),0)):+$P(RAD0,"^",3),1:9999)
  1.  ;---> GET RADIOLOGIST SUBSCRIPT.
  1.  S RARAD="UNKNOWN"
  1.  I $P(RAP0,U,15)]"",$D(^VA(200,$P(RAP0,U,15),0)) S RARAD=$P(^(0),U)
  1.  S RARAD=$E(RARAD,1,30)
  1.  ;---> GET PROCEDURE SUBSCRIPT.
  1.  S RAPRC=$E($P(^RAMIS(71,$P(RAP0,U,2),0),U),1,29)
  1.  ;---> GET PATIENT NAME SUBSCRIPT.
  1.  S RANAME=$P(^DPT(RADFN,0),U)
  1.  ;---> SET ^TMP(NODE=CASE#^CHART#^EXAM STATUS^DIAG CODE
  1.  S X=$P(RAP0,U)_U_$$HRCN^BDGF2(RADFN,DUZ("2"))_U_$P(^RA(72,$P(RAP0,U,3),0),U)
  1.  I $P(RAP0,U,13) S X=X_U_$P(^RA(78.3,$P(RAP0,U,13),0),U)
  1.  S ^TMP($J,"RA",RADIV,RARAD,RAPRC,RANAME,RADTE)=X
  1.  Q
  1.  ;
  1.  ;
  1. SELECT ;EP---> SELECT PROCEDURE(S), RADIOLOGIST(S), DIAGNOSTIC CODE(S).
  1.  K @BRAVAR N DIC,DIR
  1.  W ! S DIR("A")="Include ALL "_BRADIR_"s in this report"
  1.  S DIR(0)="Y",DIR("B")="Y"
  1.  S DIR("?",1)="Answer ""YES"" to print exams for ALL "_BRADIR_"s;"
  1.  S DIR("?")="Answer ""NO"" to select one or more "_BRADIR_"s."
  1.  D ^DIR K DIR
  1.  I $D(DIRUT) S BRAY=0 Q
  1.  ;---> IF ALL ARE SELECTED, QUIT HERE.
  1.  I Y S @(BRAVAR_"(""ALL"")")="",BRAY=1 Q
  1.  ;
  1.  W !!,"Select the "_BRADIR_"(s) you wish to include in this report."
  1.  S DIC(0)="QEMA",DIC=BRADIC
  1.  S DIC("A")="Select "_BRADIR_": "
  1.  S:$D(BRADIC("S")) DIC("S")=BRADIC("S")
  1.  F  D ^DIC Q:Y<0  S @(BRAVAR_"(+Y)")=""
  1.  I '$D(@BRAVAR) W !,"No ",BRADIR,"s selected.",! S BRAY=0 Q
  1.  W !!,"The following ",BRADIR,"s will be included in this report:"
  1.  W ! F I=1:1:48+$L(BRADIR) W "-"
  1.  S N=0 F  S N=$O(@(BRAVAR_"(N)")) Q:'N  D
  1.  .W !?5,$P(@(BRAGBL_"N,0)"),U)
  1.  .I BRAVAR="RAROOM" W " - ",$P(@(BRAGBL_"N,0)"),U,2)
  1.  W ! S DIR(0)="Y",DIR("A")="Is this correct",DIR("B")="Y"
  1.  D ^DIR I $D(DIRUT) S BRAY=0 Q
  1.  I 'Y K @BRAVAR D  G SELECT
  1.  .W "   All ",BRADIR,"s deleted.  Please begin again."
  1.  S BRAY=1
  1.  Q