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

RAUTL7A.m

Go to the documentation of this file.
  1. RAUTL7A ;HISC/CAH,FPT-Utility for RACCESS array ;9/10/01 15:13
  1. ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
  1. LOCIMG1() ;Determines if user has access to more than one loc of
  1. ;the current imaging type
  1. ;Returns Null if more than one Rad/NM Loc, or if no access
  1. ;Returns Rad/NM Loc File 79.1 IEN if one only.
  1. N X,Y,Z,RALOCTOT S X=$O(RACCESS(DUZ,"LOC",0)) Q:'X ""
  1. S (RALOCTOT,X)=0 S Z=$O(^RA(79.2,"B",RAIMGTY,0))
  1. F S X=$O(RACCESS(DUZ,"LOC",X)) Q:'X D
  1. . I $P($G(^RA(79.1,X,0)),U,6)=Z S RALOCSAV=X,RALOCTOT=RALOCTOT+1
  1. . Q
  1. I RALOCTOT=1 Q RALOCSAV
  1. Q ""
  1. ERROR ; Display error message
  1. W !!?5,"You do not have access to any Imaging Locations."
  1. W !?5,"Contact your ADPAC for further assistance.",$C(7)
  1. Q
  1. IMGNUM() ; Detrmines the number of selectable imaging types based on
  1. ; division parameters. Called fron SELIMG^RAUTL7
  1. N X,Y S (X,Y)=0
  1. F S X=$O(^TMP($J,"DIV-IMG",X)) Q:X'>0 S Y=Y+1
  1. Q Y
  1. SETUP ; Setup temp global to screen i-type by division
  1. ; Requires ^TMP($J,"RA D-TYPE",Division name), RACCESS "DIV-IMG"
  1. ; elements. Creates ^TMP($J,"DIV-IMG",Imaging Type IEN)=""
  1. ; Called fron SELIMG^RAUTL7
  1. N RAX,RAY,RAZ S RAX=""
  1. F S RAX=$O(^TMP($J,"RA D-TYPE",RAX)) Q:RAX']"" D
  1. . I $D(RACCESS(DUZ,"DIV-IMG",RAX)) D
  1. .. S RAY="" F S RAY=$O(RACCESS(DUZ,"DIV-IMG",RAX,RAY)) Q:RAY']"" D
  1. ... S RAZ=+$O(^RA(79.2,"B",RAY,0)),^TMP($J,"DIV-IMG",RAZ)=""
  1. ... Q
  1. .. Q
  1. . Q
  1. Q
  1. LOCNUM() ;Detrmines the number of selectable imaging locations based on
  1. ; division parameters. Called fron SELLOC^RAUTL7
  1. N X,Y S (X,Y)=0
  1. F S X=$O(^TMP($J,"DIV-ITYP-ILOC",X)) Q:X'>0 S Y=Y+1
  1. Q Y
  1. SETUPL ; Setup temp global to screen img-loc, where
  1. ; img-loc must be within previously selected img-typ(s)
  1. ; Requires RACCESS(duz,"LOC") and ^TMP($J,"RA ITYPE")
  1. ; Creates ^TMP($J,"DIV-ITYP-ILOC",Img Loc ien)
  1. ; and eg. RACCESS(duz,"DIV-ITYP-ILOC","cgo(ws)","gen rad","x-ray")
  1. ; Called from SELLOC^RAUTL7
  1. N RAX,RAY,RAZ,RAW
  1. S RAX=0
  1. ; allow other img locations with img types that match at least one
  1. ; of the user's accessible img location's img types
  1. ; so, loop thru all img locations
  1. SETUPL1 S RAX=$O(^RA(79.1,RAX)) Q:'RAX ;eg. 7
  1. S RAY=+$P(^RA(79.1,RAX,0),"^",6) G:RAY="" SETUPL1 ;eg. 1
  1. G:'$O(^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+RAY,0)),U),0)) SETUPL1
  1. S RAZ=$P($G(^RA(79.1,RAX,"DIV")),U) G:RAZ="" SETUPL1 ;eg. 639
  1. S RAW=$P(^DIC(4,+RAZ,0),U) G:RAW="" SETUPL1 ;eg. CHICAGO (WS)
  1. ; match on selected imaging type
  1. G:'$D(^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+RAY,0)),"^"),+RAY)) SETUPL1
  1. ; match on selected division(s)
  1. G:'$D(^TMP($J,"RA D-TYPE",RAW,RAZ)) SETUPL1
  1. S ^TMP($J,"DIV-ITYP-ILOC",RAX)=""
  1. ; following line replaces original code from DIVIACC section of ^RAUTL7
  1. ; raccess(duz,"DIV-ITYP-ILOC" is used by ZEROUT^RADLY1 to
  1. ; zerout the ^tmp($j,"radly" nodes
  1. S RACCESS(DUZ,"DIV-ITYP-ILOC",RAW,$P($G(^RA(79.2,+RAY,0)),"^"),$P($G(^SC(+$P($G(^RA(79.1,+RAX,0)),U),0)),U))=""
  1. G SETUPL1
  1. Q
  1. VERIFY ; verify old reports
  1. ; back door function to "administratively verify" old reports
  1. ; that were never verified
  1. W !,"This subroutine prompts you for a date and places all unverified reports"
  1. W !,"through that date into a status of Verified.",!
  1. I '$D(^RARPT("ASTAT")) W !!,"NO UNVERFIED REPORTS CROSS REFERENCE" Q
  1. K DIR S DIR(0)="D",DIR("A")="Enter a date",DIR("?")="All unverified reports through this date will be marked as Verified."
  1. D ^DIR K DIR I $D(DIRUT) D KILL Q
  1. S RAENDATE=Y
  1. DEVICE ;
  1. S ZTRTN="START^RAUTL7A",ZTDESC="Rad/Nuc Med Verify Old Reports",ZTSAVE("RAENDATE")=""
  1. D ZIS^RAUTL
  1. I RAPOP D KILL Q
  1. START ;
  1. U IO K DIR,DIRUT,DIROUT,DTOUT,DUOUT
  1. S RASTATUS="",(RACOUNT,RAPAGE)=0,RAENDATE=$P(RAENDATE,".")_"."_9999
  1. S:$D(ZTQUEUED) ZTREQ="@"
  1. D NOW^%DTC S Y=X X ^DD("DD") S RATIME=Y
  1. D HEADER
  1. F S RASTATUS=$O(^RARPT("ASTAT",RASTATUS)) Q:RASTATUS=""!($D(DIRUT)) S RARPT=0 F S RARPT=$O(^RARPT("ASTAT",RASTATUS,RARPT)) Q:RARPT'>0 D Q:$D(DIRUT)
  1. .S RARPT0=$G(^RARPT(RARPT,0)) Q:RARPT0=""
  1. .S RADTE=$P(RARPT0,U,3) Q:RADTE=""!(RADTE>RAENDATE)
  1. .S RADFN=$P(RARPT0,U,2) Q:RADFN=""
  1. .S RADTI=9999999.9999-RADTE
  1. .S RACNI=$O(^RADPT("ADC",$P(RARPT0,U,1),RADFN,RADTI,0)) Q:RACNI=""
  1. .S DFN=RADFN D DEM^VADPT
  1. .S RANAME=$P(VADM(1),U,1),RASSN=$P(VADM(2),U,2) K DFN,VADM
  1. .S RACOUNT=RACOUNT+1
  1. .S RADPT0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
  1. .S RARES=+$P(RADPT0,U,12) I $D(^VA(200,RARES,0)) S RARES=$P(^VA(200,RARES,0),U,1)
  1. .S RASTAFF=+$P(RADPT0,U,15) I $D(^VA(200,RASTAFF,0)) S RASTAFF=$P(^VA(200,RASTAFF,0),U,1)
  1. .W !!,$P(RARPT0,U,1),?15,RANAME_" ("_RASSN_")",?60,"Status: ",RASTATUS
  1. .W !,"Resident: ",$S(RARES=0:"<none>",RARES]"":RARES,1:"<none>")
  1. .W ?43,"Staff: ",$S(RASTAFF=0:"<none>",RASTAFF]"":RASTAFF,1:"<none>")
  1. .K DIE,DR S DIE="^RARPT(",DR="5////V",DA=RARPT D ^DIE
  1. .I ($Y+4)>IOSL D Q:$D(DIRUT) W @IOF D HEADER
  1. ..Q:$E(IOST)'="C"
  1. ..K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. ..S DIR(0)="E" D ^DIR K DIR
  1. ..Q
  1. .I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 DIRUT=1
  1. .Q
  1. W !!,"Total: ",RACOUNT
  1. KILL ;
  1. K %,DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,RACNI,RACOUNT,RADFN,RADPT0,RADTE,RADTI,RAENDATE,RANAME,RAPAGE,RAPOP,RARPT,RARPT0,RARES,RASSN,RATIME,RASTAFF,RASTATUS,X,Y,ZTDESC,ZTRTN,ZTSAVE
  1. D CLOSE^RAUTL
  1. Q
  1. W:$Y>0 @IOF
  1. S RAPAGE=RAPAGE+1
  1. W "Verify Reports Prior to "_$E(RAENDATE,4,5)_"/"_$E(RAENDATE,6,7)_"/"_$E(RAENDATE,2,3)
  1. W !,"Run Date/Time: ",RATIME,?70,"Page: ",RAPAGE
  1. W !,$$REPEAT^XLFSTR("-",79),!
  1. Q
  1. DISPLAY ; back door function to display all reports not verified in file 74
  1. ; prints [captioned] dump of entire record
  1. W !!,"This subroutine loops through the unverified reports cross-reference of"
  1. W !,"File 74 and displays the report entry including computed field values.",!!
  1. D ^%ZIS
  1. U IO W:$Y>0 @IOF
  1. S RA4CHX=""
  1. F S RA4CHX=$O(^RARPT("ASTAT",RA4CHX)) Q:RA4CHX=""!($D(DIRUT)) D
  1. . S RA4CHX1=0 F S RA4CHX1=$O(^RARPT("ASTAT",RA4CHX,RA4CHX1)) Q:'RA4CHX1!($D(DIRUT)) D
  1. .. I $D(^RARPT(RA4CHX1,0)) S DIC="^RARPT(",DA=+RA4CHX1,DIQ(0)="C" W:$Y>0 @IOF D EN^DIQ I '$D(DIRUT) D Q:$D(DIRUT)
  1. ...Q:$E(IOST)'="C"
  1. ...K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. ...S DIR(0)="E" D ^DIR K DIR
  1. ...Q
  1. D ^%ZISC
  1. K A,D0,D1,DA,DIC,DIQ,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL,DN,DTOUT,DUOUT,DX,I,POP,RA4CHX,RA4CHX1,RACN,RARPT,S,X,Y
  1. Q