- 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 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL7A 6278 printed Feb 19, 2025@00:06:48 Page 2
- 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 SET RANAME=$PIECE(VADM(1),U,1)
- SET RASSN=$PIECE(VADM(2),U,2)
- KILL DFN,VADM
- +14 SET RACOUNT=RACOUNT+1
- +15 SET RADPT0=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- +16 SET RARES=+$PIECE(RADPT0,U,12)
- IF $DATA(^VA(200,RARES,0))
- SET RARES=$PIECE(^VA(200,RARES,0),U,1)
- +17 SET RASTAFF=+$PIECE(RADPT0,U,15)
- IF $DATA(^VA(200,RASTAFF,0))
- SET RASTAFF=$PIECE(^VA(200,RASTAFF,0),U,1)
- +18 WRITE !!,$PIECE(RARPT0,U,1),?15,RANAME_" ("_RASSN_")",?60,"Status: ",RASTATUS
- +19 WRITE !,"Resident: ",$SELECT(RARES=0:"<none>",RARES]"":RARES,1:"<none>")
- +20 WRITE ?43,"Staff: ",$SELECT(RASTAFF=0:"<none>",RASTAFF]"":RASTAFF,1:"<none>")
- +21 KILL DIE,DR
- SET DIE="^RARPT("
- SET DR="5////V"
- SET DA=RARPT
- DO ^DIE
- +22 IF ($Y+4)>IOSL
- Begin DoDot:2
- +23 if $EXTRACT(IOST)'="C"
- QUIT
- +24 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
- +25 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +26 QUIT
- End DoDot:2
- if $DATA(DIRUT)
- QUIT
- WRITE @IOF
- DO HEADER
- +27 IF $DATA(ZTQUEUED)
- DO STOPCHK^RAUTL9
- if $GET(ZTSTOP)=1
- SET DIRUT=1
- +28 QUIT
- End DoDot:1
- if $DATA(DIRUT)
- QUIT
- +29 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