- RADLY ;HISC/GJC AISC/MJK,RMO-Rad Daily Log Report ;7/17/97 12:35
- ;;5.0;Radiology/Nuclear Medicine;**15,47**;Mar 16, 1998;Build 21
- ; setup raccess(duz,"LOC" raccess(duz,"DIV" raccess(duz,"IMG"
- I $O(RACCESS(DUZ,""))="" S RAPSTX="" D SETVARS^RAPSET1(0)
- ; Check access and
- ; setup raccess(duz,"DIV-IMG","chicago (ws),"general radiology"
- S RAXIT=$$SETUPDI^RAUTL7() G:RAXIT CLEAN
- ; Select Div
- ; setup ^tmp($j,"RA D-TYPE"
- D SELDIV^RAUTL7
- I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) K RACCESS(DUZ,"DIV-IMG") S RAXIT=1 G CLEAN
- ; Set imaging types as allowed by division(s) picked
- N X,X1,RACHK1 S X=0
- ; setup ^tmp($j,"DIV-IMG"
- D SETUP^RAUTL7A
- ; setup ^tmp($j,"RA I-TYPE"
- F S X=$O(^TMP($J,"DIV-IMG",X)) Q:X'=+X I $D(RACCESS(DUZ,"IMG",X)) S ^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+X,0)),U),X)=""
- ; Select Img Loc
- ; setup ^tmp($j,"DIV-ITYP-ILOC" ^tmp($j,"RA LOC-TYPE"
- D SELLOC^RAUTL7
- I '$D(^TMP($J,"RA LOC-TYPE"))!(RAQUIT) K RACESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-ITYP-ILOC") S RAXIT=1
- CLEAN K ^TMP($J,"DIV-IMG")
- ;
- I RAXIT K RAXIT K:$D(RAPSTX) RACCESS,RAPSTX,I,POP,RAQUIT Q
- ; loop thru raccess(duz,"DIV-IMG" to setup ^tmp($j,"RADLY",
- ; matching on ^tmp($j,"RA D-TYPE" and ^tmp($j,"RA I-TYPE"
- ; use new code in rtn radly1, instead of rtn radlq3
- D ZEROUT^RADLY1 K RACCESS(DUZ,"DIV-IMG") W !
- ASKLOG ; Ask log date
- W ! K %DT
- S %DT="PATEX",%DT("A")="Select Log Date: "
- S %DT("B")="T-1" D ^%DT K %DT
- I Y<0 D KILL^RADLY1 Q
- S RALDTI=Y\1 S RALDTX=$$FMTE^XLFDT(Y\1,1)
- S ZTDESC="Rad/Nuc Med Daily Log Rpt"
- S ZTRTN="START^RADLY",ZTSAVE("RALDT*")=""
- S ZTSAVE("^TMP($J,""RADLY"",")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
- S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
- S ZTSAVE("^TMP($J,""RA LOC-TYPE"",")=""
- D ZIS^RAUTL
- I RAPOP D KILL^RADLY1 Q
- START ; Start the process
- U IO D NOW^%DTC
- S:$D(ZTQUEUED) ZTREQ="@"
- S RATDY=$$FMTE^XLFDT(%\1,1),(RAPG,RAXIT)=0
- S $P(RALN,"-",(IOM+1))="",RAHEAD="Daily Log Report For: "_RALDTX
- S RATAB(1)=$S(IOM=132:8,1:5),RATAB(2)=$S(IOM=132:25,1:8)
- S RATAB(3)=$S(IOM=132:42,1:25),RATAB(4)=$S(IOM=132:52,1:32)
- S RATAB(5)=$S(IOM=132:72,1:38),RATAB(6)=$S(IOM=132:95,1:43)
- S RATAB(7)=$S(IOM=132:114,1:60),RATAB(8)=$S(IOM=132:122,1:62)
- S RATAB(9)=$S(IOM=132:102,1:62)
- ;
- F RADTE=RALDTI:0 S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE D Q:RAXIT
- . Q:RADTE>(RALDTI+.9999)
- . F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN D Q:RAXIT
- .. S RADTI=9999999.9999-RADTE
- .. D:$D(^RADPT(RADFN,"DT",RADTI,0)) SORT^RADLY1
- .. Q
- . Q
- I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q
- ;
- ; eliminate "RADLY" nodes that are outside the user-selected img locs
- N A,B,C S A=""
- CLN1 S A=$O(^TMP($J,"RADLY",A)) G:A']"" PREP S B=""
- CLN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" CLN1 S C=""
- CLN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" CLN2
- K:$O(^TMP($J,"RA LOC-TYPE",C,0))="" ^TMP($J,"RADLY",A,B,C)
- K:$O(^TMP($J,"RA I-TYPE",B,0))="" ^TMP($J,"RADLY",A,B)
- K:$O(^TMP($J,"RADLY",A,""))="" ^TMP($J,"RADLY",A)
- G CLN3
- PREP G:'$D(^TMP($J,"RADLY")) OUT
- S X=+$O(^TMP($J,"RADLY","")),Y=$O(^TMP($J,"RADLY",X,""))
- S RADIV=$P($G(^DIC(4,X,0)),"^"),RAITYPE=Y
- S RAILOC=$O(^TMP($J,"RADLY",X,Y,""))
- ; save current values
- S RADIV0=RADIV,RAITYPE0=RAITYPE,RAILOC0=RAILOC
- D HD^RADLY1
- I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q
- I $D(^TMP($J,"RADLY")) D
- . D PRINT^RADLY1 ; Print out data
- . I 'RAXIT D
- .. S RADIVNM=$$DIVTOT^RACMP("RADLY") Q:'RADIVNM
- .. S (RADIV,RAFLG,RAITYPE)="",RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1
- .. D:'RAXIT SYNOP
- .. Q
- . Q
- OUT D CLOSE^RAUTL,KILL^RADLY1
- Q
- SET ; Set ^TMP global
- S RAEX(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- S RACN=$P(RAEX(0),"^"),RAPRC=+$P(RAEX(0),"^",2)
- S RAPRC=$G(^RAMIS(71,RAPRC,0)),RAST=+$P(RAEX(0),"^",3)
- S RAPRC=$E($S(RAPRC]"":$P(RAPRC,"^"),1:"Unknown"),1,19)
- S RAST=$G(^RA(72,RAST,0)),RA6=+$P(RAEX(0),"^",6)
- S RA8=+$P(RAEX(0),"^",8),RA9=+$P(RAEX(0),"^",9)
- S RAST=$E($S(RAST]"":$P(RAST,"^"),1:"Unknown"),1,20)
- S X=RADTE D TIME^RAUTL1 S RATME=X
- S:$D(^DIC(42,RA6,0)) RAWHE=$P(^DIC(42,RA6,0),"^")
- S:$D(^SC(RA8,0)) RAWHE=$P(^SC(RA8,0),"^")
- S:$D(^DIC(34,RA9,0)) RAWHE=$P(^DIC(34,RA9,0),"^")
- S:$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")) RAWHE=$P(^("R"),"^")
- S RAWHE=$E($S($G(RAWHE)]"":RAWHE,1:"Unknown"),1,20)
- S RARPT=+$P(RAEX(0),"^",17)
- S RARPT=$S($O(^RARPT(RARPT,"R",0)):"Yes",1:"No")
- I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
- S ^TMP($J,"RADLY",RADIV)=+$G(^TMP($J,"RADLY",RADIV))+1
- S ^TMP($J,"RADLY",RADIV,RAITYPE)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE))+1
- S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC))+1
- S RADIVTY=+$G(RADIVTY)+1
- N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
- I $$USESSAN^RAHLRU1() S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACNDSP_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
- I '$$USESSAN^RAHLRU1() S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACN_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
- Q
- SYNOP ; Synopsis of data presented to the user.
- S A=""
- W !?RATAB(2),"Division",!?RATAB(2)+3,"Imaging Type",!?RATAB(2)+6,"Imaging Location(s)",!
- SYN1 S A=$O(^TMP($J,"RADLY",A)) Q:A']""
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
- W !!?RATAB(2),$P($G(^DIC(4,A,0)),"^") S B=""
- SYN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" SYN1
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
- W !?RATAB(2)+3,B,!?RATAB(2)+6 S C=""
- SYN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" SYN2
- I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
- W:$X>(IOM-30) !?RATAB(2)+6
- W C,?($X+3)
- G SYN3
- RADLY ;HISC/GJC AISC/MJK,RMO-Rad Daily Log Report ;7/17/97 12:35
- +1 ;;5.0;Radiology/Nuclear Medicine;**15,47**;Mar 16, 1998;Build 21
- +2 ; setup raccess(duz,"LOC" raccess(duz,"DIV" raccess(duz,"IMG"
- +3 IF $ORDER(RACCESS(DUZ,""))=""
- SET RAPSTX=""
- DO SETVARS^RAPSET1(0)
- +4 ; Check access and
- +5 ; setup raccess(duz,"DIV-IMG","chicago (ws),"general radiology"
- +6 SET RAXIT=$$SETUPDI^RAUTL7()
- IF RAXIT
- GOTO CLEAN
- +7 ; Select Div
- +8 ; setup ^tmp($j,"RA D-TYPE"
- +9 DO SELDIV^RAUTL7
- +10 IF '$DATA(^TMP($JOB,"RA D-TYPE"))!(RAQUIT)
- KILL RACCESS(DUZ,"DIV-IMG")
- SET RAXIT=1
- GOTO CLEAN
- +11 ; Set imaging types as allowed by division(s) picked
- +12 NEW X,X1,RACHK1
- SET X=0
- +13 ; setup ^tmp($j,"DIV-IMG"
- +14 DO SETUP^RAUTL7A
- +15 ; setup ^tmp($j,"RA I-TYPE"
- +16 FOR
- SET X=$ORDER(^TMP($JOB,"DIV-IMG",X))
- IF X'=+X
- QUIT
- IF $DATA(RACCESS(DUZ,"IMG",X))
- SET ^TMP($JOB,"RA I-TYPE",$PIECE($GET(^RA(79.2,+X,0)),U),X)=""
- +17 ; Select Img Loc
- +18 ; setup ^tmp($j,"DIV-ITYP-ILOC" ^tmp($j,"RA LOC-TYPE"
- +19 DO SELLOC^RAUTL7
- +20 IF '$DATA(^TMP($JOB,"RA LOC-TYPE"))!(RAQUIT)
- KILL RACESS(DUZ,"DIV-IMG"),^TMP($JOB,"DIV-ITYP-ILOC")
- SET RAXIT=1
- CLEAN KILL ^TMP($JOB,"DIV-IMG")
- +1 ;
- +2 IF RAXIT
- KILL RAXIT
- IF $DATA(RAPSTX)
- KILL RACCESS,RAPSTX,I,POP,RAQUIT
- QUIT
- +3 ; loop thru raccess(duz,"DIV-IMG" to setup ^tmp($j,"RADLY",
- +4 ; matching on ^tmp($j,"RA D-TYPE" and ^tmp($j,"RA I-TYPE"
- +5 ; use new code in rtn radly1, instead of rtn radlq3
- +6 DO ZEROUT^RADLY1
- KILL RACCESS(DUZ,"DIV-IMG")
- WRITE !
- ASKLOG ; Ask log date
- +1 WRITE !
- KILL %DT
- +2 SET %DT="PATEX"
- SET %DT("A")="Select Log Date: "
- +3 SET %DT("B")="T-1"
- DO ^%DT
- KILL %DT
- +4 IF Y<0
- DO KILL^RADLY1
- QUIT
- +5 SET RALDTI=Y\1
- SET RALDTX=$$FMTE^XLFDT(Y\1,1)
- +6 SET ZTDESC="Rad/Nuc Med Daily Log Rpt"
- +7 SET ZTRTN="START^RADLY"
- SET ZTSAVE("RALDT*")=""
- +8 SET ZTSAVE("^TMP($J,""RADLY"",")=""
- SET ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
- +9 SET ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
- +10 SET ZTSAVE("^TMP($J,""RA LOC-TYPE"",")=""
- +11 DO ZIS^RAUTL
- +12 IF RAPOP
- DO KILL^RADLY1
- QUIT
- START ; Start the process
- +1 USE IO
- DO NOW^%DTC
- +2 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 SET RATDY=$$FMTE^XLFDT(%\1,1)
- SET (RAPG,RAXIT)=0
- +4 SET $PIECE(RALN,"-",(IOM+1))=""
- SET RAHEAD="Daily Log Report For: "_RALDTX
- +5 SET RATAB(1)=$SELECT(IOM=132:8,1:5)
- SET RATAB(2)=$SELECT(IOM=132:25,1:8)
- +6 SET RATAB(3)=$SELECT(IOM=132:42,1:25)
- SET RATAB(4)=$SELECT(IOM=132:52,1:32)
- +7 SET RATAB(5)=$SELECT(IOM=132:72,1:38)
- SET RATAB(6)=$SELECT(IOM=132:95,1:43)
- +8 SET RATAB(7)=$SELECT(IOM=132:114,1:60)
- SET RATAB(8)=$SELECT(IOM=132:122,1:62)
- +9 SET RATAB(9)=$SELECT(IOM=132:102,1:62)
- +10 ;
- +11 FOR RADTE=RALDTI:0
- SET RADTE=$ORDER(^RADPT("AR",RADTE))
- IF 'RADTE
- QUIT
- Begin DoDot:1
- +12 IF RADTE>(RALDTI+.9999)
- QUIT
- +13 FOR RADFN=0:0
- SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
- IF 'RADFN
- QUIT
- Begin DoDot:2
- +14 SET RADTI=9999999.9999-RADTE
- +15 IF $DATA(^RADPT(RADFN,"DT",RADTI,0))
- DO SORT^RADLY1
- +16 QUIT
- End DoDot:2
- IF RAXIT
- QUIT
- +17 QUIT
- End DoDot:1
- IF RAXIT
- QUIT
- +18 IF RAXIT
- DO CLOSE^RAUTL
- DO KILL^RADLY1
- QUIT
- +19 ;
- +20 ; eliminate "RADLY" nodes that are outside the user-selected img locs
- +21 NEW A,B,C
- SET A=""
- CLN1 SET A=$ORDER(^TMP($JOB,"RADLY",A))
- IF A']""
- GOTO PREP
- SET B=""
- CLN2 SET B=$ORDER(^TMP($JOB,"RADLY",A,B))
- IF B']""
- GOTO CLN1
- SET C=""
- CLN3 SET C=$ORDER(^TMP($JOB,"RADLY",A,B,C))
- IF C']""
- GOTO CLN2
- +1 IF $ORDER(^TMP($JOB,"RA LOC-TYPE",C,0))=""
- KILL ^TMP($JOB,"RADLY",A,B,C)
- +2 IF $ORDER(^TMP($JOB,"RA I-TYPE",B,0))=""
- KILL ^TMP($JOB,"RADLY",A,B)
- +3 IF $ORDER(^TMP($JOB,"RADLY",A,""))=""
- KILL ^TMP($JOB,"RADLY",A)
- +4 GOTO CLN3
- PREP IF '$DATA(^TMP($JOB,"RADLY"))
- GOTO OUT
- +1 SET X=+$ORDER(^TMP($JOB,"RADLY",""))
- SET Y=$ORDER(^TMP($JOB,"RADLY",X,""))
- +2 SET RADIV=$PIECE($GET(^DIC(4,X,0)),"^")
- SET RAITYPE=Y
- +3 SET RAILOC=$ORDER(^TMP($JOB,"RADLY",X,Y,""))
- +4 ; save current values
- +5 SET RADIV0=RADIV
- SET RAITYPE0=RAITYPE
- SET RAILOC0=RAILOC
- +6 DO HD^RADLY1
- +7 IF RAXIT
- DO CLOSE^RAUTL
- DO KILL^RADLY1
- QUIT
- +8 IF $DATA(^TMP($JOB,"RADLY"))
- Begin DoDot:1
- +9 ; Print out data
- DO PRINT^RADLY1
- +10 IF 'RAXIT
- Begin DoDot:2
- +11 SET RADIVNM=$$DIVTOT^RACMP("RADLY")
- IF 'RADIVNM
- QUIT
- +12 SET (RADIV,RAFLG,RAITYPE)=""
- SET RAXIT=$$EOS^RAUTL5()
- IF 'RAXIT
- DO HD^RADLY1
- +13 IF 'RAXIT
- DO SYNOP
- +14 QUIT
- End DoDot:2
- +15 QUIT
- End DoDot:1
- OUT DO CLOSE^RAUTL
- DO KILL^RADLY1
- +1 QUIT
- SET ; Set ^TMP global
- +1 SET RAEX(0)=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- +2 SET RACN=$PIECE(RAEX(0),"^")
- SET RAPRC=+$PIECE(RAEX(0),"^",2)
- +3 SET RAPRC=$GET(^RAMIS(71,RAPRC,0))
- SET RAST=+$PIECE(RAEX(0),"^",3)
- +4 SET RAPRC=$EXTRACT($SELECT(RAPRC]"":$PIECE(RAPRC,"^"),1:"Unknown"),1,19)
- +5 SET RAST=$GET(^RA(72,RAST,0))
- SET RA6=+$PIECE(RAEX(0),"^",6)
- +6 SET RA8=+$PIECE(RAEX(0),"^",8)
- SET RA9=+$PIECE(RAEX(0),"^",9)
- +7 SET RAST=$EXTRACT($SELECT(RAST]"":$PIECE(RAST,"^"),1:"Unknown"),1,20)
- +8 SET X=RADTE
- DO TIME^RAUTL1
- SET RATME=X
- +9 IF $DATA(^DIC(42,RA6,0))
- SET RAWHE=$PIECE(^DIC(42,RA6,0),"^")
- +10 IF $DATA(^SC(RA8,0))
- SET RAWHE=$PIECE(^SC(RA8,0),"^")
- +11 IF $DATA(^DIC(34,RA9,0))
- SET RAWHE=$PIECE(^DIC(34,RA9,0),"^")
- +12 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R"))
- SET RAWHE=$PIECE(^("R"),"^")
- +13 SET RAWHE=$EXTRACT($SELECT($GET(RAWHE)]"":RAWHE,1:"Unknown"),1,20)
- +14 SET RARPT=+$PIECE(RAEX(0),"^",17)
- +15 SET RARPT=$SELECT($ORDER(^RARPT(RARPT,"R",0)):"Yes",1:"No")
- +16 IF $DATA(ZTQUEUED)
- DO STOPCHK^RAUTL9
- IF $GET(ZTSTOP)=1
- SET RAXIT=1
- IF RAXIT
- QUIT
- +17 SET ^TMP($JOB,"RADLY",RADIV)=+$GET(^TMP($JOB,"RADLY",RADIV))+1
- +18 SET ^TMP($JOB,"RADLY",RADIV,RAITYPE)=+$GET(^TMP($JOB,"RADLY",RADIV,RAITYPE))+1
- +19 SET ^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC)=+$GET(^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC))+1
- +20 SET RADIVTY=+$GET(RADIVTY)+1
- +21 NEW RASSAN,RACNDSP
- SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
- +22 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
- +23 IF $$USESSAN^RAHLRU1()
- SET ^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACNDSP_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
- +24 IF '$$USESSAN^RAHLRU1()
- SET ^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACN_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
- +25 QUIT
- SYNOP ; Synopsis of data presented to the user.
- +1 SET A=""
- +2 WRITE !?RATAB(2),"Division",!?RATAB(2)+3,"Imaging Type",!?RATAB(2)+6,"Imaging Location(s)",!
- SYN1 SET A=$ORDER(^TMP($JOB,"RADLY",A))
- IF A']""
- QUIT
- +1 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF 'RAXIT
- DO HD^RADLY1
- IF RAXIT
- QUIT
- +2 WRITE !!?RATAB(2),$PIECE($GET(^DIC(4,A,0)),"^")
- SET B=""
- SYN2 SET B=$ORDER(^TMP($JOB,"RADLY",A,B))
- IF B']""
- GOTO SYN1
- +1 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF 'RAXIT
- DO HD^RADLY1
- IF RAXIT
- QUIT
- +2 WRITE !?RATAB(2)+3,B,!?RATAB(2)+6
- SET C=""
- SYN3 SET C=$ORDER(^TMP($JOB,"RADLY",A,B,C))
- IF C']""
- GOTO SYN2
- +1 IF $Y>(IOSL-4)
- SET RAXIT=$$EOS^RAUTL5()
- IF 'RAXIT
- DO HD^RADLY1
- IF RAXIT
- QUIT
- +2 IF $X>(IOM-30)
- WRITE !?RATAB(2)+6
- +3 WRITE C,?($X+3)
- +4 GOTO SYN3
