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