RARTST2A ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Reports Distribution ;11/24/97 12:12
;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
;
DIV ; Division selection
; save all Med Center Divisions (40.8) by pntr to file 4
D LIST^DIC(40.8,"",.07,"I","*","","","","","","RA408")
Q:'$D(RA408("DILIST","ID")) ; quit if no data
S RAI=0 F S RAI=$O(RA408("DILIST","ID",RAI)) Q:RAI'>0 D
. ; for all entries in 40.8, save off the Institution File Pointer data
. ; (Inst. File Pntr data is subscript) set the local array equal to the
. ; appropriate ien in 40.8 - Example: RA4('ien file 4')='ien file 40.8'
. S:$G(RA408("DILIST","ID",RAI,.07))]"" RA4($G(RA408("DILIST","ID",RAI,.07)))=$G(RA408("DILIST",2,RAI))
. S:$G(RA408("DILIST",2,RAI))]"" RAF408(RA408("DILIST",2,RAI))=""
. Q
K RAPRMPT S I1=$P($G(^RABTCH(74.3,RAB,0)),"^")
I I1="CLINIC REPORTS"!(I1="WARD REPORTS")!(I1="REQUESTING PHYSICIAN") S RAPRMPT=" Requesting Division: "
E S RAPRMPT=" Exam Division: "
K RADIV S (C,I1)=0 F I=0:0 S I=$O(^RA(79,I)) Q:'I S C=C+1,I1=I Q:C>1
I C=1,$D(RA4(I1)) S RADIV=I1 K C,I,I1 G IMAG
I $D(RAMDIV),$D(RA4(+RAMDIV)) S DIC("B")=+RAMDIV
W !!,"Division Selection:",!,"-------------------"
S DIC(0)="AEMQZ",DIC="^DIC(4,",DIC("A")=RAPRMPT
S DIC("S")="I $D(RA4(+Y))" ; only institutions linked to Med Center Divs
D ^DIC K DIC("A"),DIC("B"),DIC("S"),RAPRMPT S RADIV=+Y
K C,I,I1,RA408,RAI Q:RADIV'>0
S I=0 F S I=$O(RA4(I)) Q:I'>0 D
. S I(0)=$G(RA4(I))
. I I'=RADIV K RA4(I),RAF408(I(0))
. Q
K I
;
IMAG ;imaging type selection
K RAIMAG I $D(RAOMA) D Q:'$D(RAIMAG)
. S RAIMAG=$$IMG^RARTST3()
. ; allow the users to select all i-types regardless of division
. ; if i-types have been selected, RAIMAG is set to one, else 0
. K:'RAIMAG RAIMAG
. Q
E D Q:'$D(RAIMAG)
. W !!,"Imaging Type Selection:",!,"-----------------------"
. S DIR(0)="PA^79.2:AEMQ",DIR("A")="Select Imaging Type: "
. S:$D(RAMLC) DIR("B")=$P($$IMAG^RASITE(+$P(RAMLC,U,6)),U,2)
. D ^DIR K DIR Q:Y'>0!$D(DIRUT) S RAIMAG(+Y)=""
. Q
I $D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))#2 D G LOC
. S RASRT(0)="Patient",RASRT="P"
. Q
;
SORT W !!,"Sort Sequence Selection:",!,"------------------------"
K RASRT S RARD(1)="Terminal Digits^sort reports by terminal digit of SSN",RARD(2)="SSN^sort reports by SSN",RARD(3)="Patient^sort reports by patient's name",RARD("A")="Select Sequence: ",RARD("B")=3
D SET^RARD K RARD Q:"^"[X S RASRT=$E(X),RASRT(0)=X
;
LOC I $G(RARTST1)=1 D Q:"^"[RALOCSRT ; *** [RA RPTDISTQUE] option only ***
. W !!,"First Sort Selection:",!,"---------------------"
. K DIR S DIR(0)="YO",DIR("B")="Yes"
. S DIR("A")=" Sort by patient location before "_RASRT(0)
. S DIR("?",1)="Enter YES to sort the report by patient location, then by "_RASRT(0)_"."
. S DIR("?",2)="Enter NO to sort the report by "_RASRT(0)_", with no sort by location."
. S DIR("?")="Choose either YES or NO."
. D ^DIR K DIR S RALOCSRT=$S($D(DIRUT):U,1:Y)
. Q
E S RALOCSRT=1
;
PRINT K RAPRT W !!,"Print/Reprint Reports Selection:",!,"--------------------------------"
S RARD(1)="UNPRINTED^print verified reports that have not been printed",RARD(2)="REPRINT^reprint previously printed reports",RARD("B")=1 D SET^RARD K RARD Q:"^"[X
S RAPRT=X Q:$E(RAPRT)="U"
;
DATE K RABEG,RAEND W !!,"Date Range Selection:",!,"---------------------"
S %DT("B")="T@1201AM",%DT="APRETX",%DT("A")=" Beginning DATE/TIME of Initial Print : " D ^%DT I Y<0 K RAPRT Q
S (%DT(0),RABEG)=Y
W ! S %DT("B")="NOW",%DT="APRETX",%DT("A")=" Ending DATE/TIME of Initial Print : " D ^%DT K %DT I Y<0 K RAPRT Q
W ! S RAEND=Y Q
RPTST(RARPT) ; Report's Print Status, called from 8^RARTST1.
; This code replaces the call to the compiled template routine.
; Input: RARPT -> ien of the Report in file 74
N I,RA74,RAEXFLD,RAY3,X,Y W !,$$REPEAT^XLFSTR("-",IOM),!!
S RA74(0)=$G(^RARPT(RARPT,0)) W "Report : ",$P(RA74(0),"^")
S (X,Y)=+$P(RA74(0),"^",2),Y=$S($D(^DPT(Y,0))#2:$P(^(0),"^"),1:"")
W ?30,"Patient: ",$E(Y,1,25) W:X ?65,$$SSN^RAUTL(X)
S Y=+$O(^RADPT(X,"DT",(9999999.9999-$P(RA74(0),"^",3)),"P","B",$P(RA74(0),"^",4),0))
S RAY3=$G(^RADPT(X,"DT",(9999999.9999-$P(RA74(0),"^",3)),"P",Y,0))
S RAEXFLD="PROC" D ^RARTFLDS W !,"Procedure: ",$E(X,1,30)
W ?45,"Verified: ",$$FMTE^XLFDT($P(RA74(0),"^",7),"1P")
W !!?4,"Routing Queue",?24,"Date Printed",?44,"Printed By",?62,"Ward/Clinic"
W !?4,"-------------",?24,"------------",?44,"----------",?62,"-----------"
S I=0 F S I=$O(^RABTCH(74.4,"B",RARPT,I)) Q:I'>0 D
. S X=$G(^RABTCH(74.4,I,0)),Y=+$P(X,"^",11)
. S Y=$S($D(^RABTCH(74.3,Y,0))#2:$P(^(0),"^"),1:"")
. W !,$E(Y,1,20),?24,$E($$FMTE^XLFDT($P(X,"^",4),1),1,18)
. S Y=+$P(X,"^",3),Y=$S($D(^VA(200,Y,0))#2:$P(^(0),"^"),1:"")
. W ?44,$E(Y,1,17),?62
. W:+$P(X,"^",6) $E($$GET1^DIQ(42,+$P(X,"^",6),.01),1,18)
. W:+$P(X,"^",8) $E($$GET1^DIQ(44,+$P(X,"^",6),.01),1,18)
. Q
W !!,$$REPEAT^XLFSTR("=",IOM),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTST2A 4995 printed Apr 09, 2024@21:35:52 Page 2
RARTST2A ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Reports Distribution ;11/24/97 12:12
+1 ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
+2 ;
DIV ; Division selection
+1 ; save all Med Center Divisions (40.8) by pntr to file 4
+2 DO LIST^DIC(40.8,"",.07,"I","*","","","","","","RA408")
+3 ; quit if no data
if '$DATA(RA408("DILIST","ID"))
QUIT
+4 SET RAI=0
FOR
SET RAI=$ORDER(RA408("DILIST","ID",RAI))
if RAI'>0
QUIT
Begin DoDot:1
+5 ; for all entries in 40.8, save off the Institution File Pointer data
+6 ; (Inst. File Pntr data is subscript) set the local array equal to the
+7 ; appropriate ien in 40.8 - Example: RA4('ien file 4')='ien file 40.8'
+8 if $GET(RA408("DILIST","ID",RAI,.07))]""
SET RA4($GET(RA408("DILIST","ID",RAI,.07)))=$GET(RA408("DILIST",2,RAI))
+9 if $GET(RA408("DILIST",2,RAI))]""
SET RAF408(RA408("DILIST",2,RAI))=""
+10 QUIT
End DoDot:1
+11 KILL RAPRMPT
SET I1=$PIECE($GET(^RABTCH(74.3,RAB,0)),"^")
+12 IF I1="CLINIC REPORTS"!(I1="WARD REPORTS")!(I1="REQUESTING PHYSICIAN")
SET RAPRMPT=" Requesting Division: "
+13 IF '$TEST
SET RAPRMPT=" Exam Division: "
+14 KILL RADIV
SET (C,I1)=0
FOR I=0:0
SET I=$ORDER(^RA(79,I))
if 'I
QUIT
SET C=C+1
SET I1=I
if C>1
QUIT
+15 IF C=1
IF $DATA(RA4(I1))
SET RADIV=I1
KILL C,I,I1
GOTO IMAG
+16 IF $DATA(RAMDIV)
IF $DATA(RA4(+RAMDIV))
SET DIC("B")=+RAMDIV
+17 WRITE !!,"Division Selection:",!,"-------------------"
+18 SET DIC(0)="AEMQZ"
SET DIC="^DIC(4,"
SET DIC("A")=RAPRMPT
+19 ; only institutions linked to Med Center Divs
SET DIC("S")="I $D(RA4(+Y))"
+20 DO ^DIC
KILL DIC("A"),DIC("B"),DIC("S"),RAPRMPT
SET RADIV=+Y
+21 KILL C,I,I1,RA408,RAI
if RADIV'>0
QUIT
+22 SET I=0
FOR
SET I=$ORDER(RA4(I))
if I'>0
QUIT
Begin DoDot:1
+23 SET I(0)=$GET(RA4(I))
+24 IF I'=RADIV
KILL RA4(I),RAF408(I(0))
+25 QUIT
End DoDot:1
+26 KILL I
+27 ;
IMAG ;imaging type selection
+1 KILL RAIMAG
IF $DATA(RAOMA)
Begin DoDot:1
+2 SET RAIMAG=$$IMG^RARTST3()
+3 ; allow the users to select all i-types regardless of division
+4 ; if i-types have been selected, RAIMAG is set to one, else 0
+5 if 'RAIMAG
KILL RAIMAG
+6 QUIT
End DoDot:1
if '$DATA(RAIMAG)
QUIT
+7 IF '$TEST
Begin DoDot:1
+8 WRITE !!,"Imaging Type Selection:",!,"-----------------------"
+9 SET DIR(0)="PA^79.2:AEMQ"
SET DIR("A")="Select Imaging Type: "
+10 if $DATA(RAMLC)
SET DIR("B")=$PIECE($$IMAG^RASITE(+$PIECE(RAMLC,U,6)),U,2)
+11 DO ^DIR
KILL DIR
if Y'>0!$DATA(DIRUT)
QUIT
SET RAIMAG(+Y)=""
+12 QUIT
End DoDot:1
if '$DATA(RAIMAG)
QUIT
+13 IF $DATA(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))#2
Begin DoDot:1
+14 SET RASRT(0)="Patient"
SET RASRT="P"
+15 QUIT
End DoDot:1
GOTO LOC
+16 ;
SORT WRITE !!,"Sort Sequence Selection:",!,"------------------------"
+1 KILL RASRT
SET RARD(1)="Terminal Digits^sort reports by terminal digit of SSN"
SET RARD(2)="SSN^sort reports by SSN"
SET RARD(3)="Patient^sort reports by patient's name"
SET RARD("A")="Select Sequence: "
SET RARD("B")=3
+2 DO SET^RARD
KILL RARD
if "^"[X
QUIT
SET RASRT=$EXTRACT(X)
SET RASRT(0)=X
+3 ;
LOC ; *** [RA RPTDISTQUE] option only ***
IF $GET(RARTST1)=1
Begin DoDot:1
+1 WRITE !!,"First Sort Selection:",!,"---------------------"
+2 KILL DIR
SET DIR(0)="YO"
SET DIR("B")="Yes"
+3 SET DIR("A")=" Sort by patient location before "_RASRT(0)
+4 SET DIR("?",1)="Enter YES to sort the report by patient location, then by "_RASRT(0)_"."
+5 SET DIR("?",2)="Enter NO to sort the report by "_RASRT(0)_", with no sort by location."
+6 SET DIR("?")="Choose either YES or NO."
+7 DO ^DIR
KILL DIR
SET RALOCSRT=$SELECT($DATA(DIRUT):U,1:Y)
+8 QUIT
End DoDot:1
if "^"[RALOCSRT
QUIT
+9 IF '$TEST
SET RALOCSRT=1
+10 ;
PRINT KILL RAPRT
WRITE !!,"Print/Reprint Reports Selection:",!,"--------------------------------"
+1 SET RARD(1)="UNPRINTED^print verified reports that have not been printed"
SET RARD(2)="REPRINT^reprint previously printed reports"
SET RARD("B")=1
DO SET^RARD
KILL RARD
if "^"[X
QUIT
+2 SET RAPRT=X
if $EXTRACT(RAPRT)="U"
QUIT
+3 ;
DATE KILL RABEG,RAEND
WRITE !!,"Date Range Selection:",!,"---------------------"
+1 SET %DT("B")="T@1201AM"
SET %DT="APRETX"
SET %DT("A")=" Beginning DATE/TIME of Initial Print : "
DO ^%DT
IF Y<0
KILL RAPRT
QUIT
+2 SET (%DT(0),RABEG)=Y
+3 WRITE !
SET %DT("B")="NOW"
SET %DT="APRETX"
SET %DT("A")=" Ending DATE/TIME of Initial Print : "
DO ^%DT
KILL %DT
IF Y<0
KILL RAPRT
QUIT
+4 WRITE !
SET RAEND=Y
QUIT
RPTST(RARPT) ; Report's Print Status, called from 8^RARTST1.
+1 ; This code replaces the call to the compiled template routine.
+2 ; Input: RARPT -> ien of the Report in file 74
+3 NEW I,RA74,RAEXFLD,RAY3,X,Y
WRITE !,$$REPEAT^XLFSTR("-",IOM),!!
+4 SET RA74(0)=$GET(^RARPT(RARPT,0))
WRITE "Report : ",$PIECE(RA74(0),"^")
+5 SET (X,Y)=+$PIECE(RA74(0),"^",2)
SET Y=$SELECT($DATA(^DPT(Y,0))#2:$PIECE(^(0),"^"),1:"")
+6 WRITE ?30,"Patient: ",$EXTRACT(Y,1,25)
if X
WRITE ?65,$$SSN^RAUTL(X)
+7 SET Y=+$ORDER(^RADPT(X,"DT",(9999999.9999-$PIECE(RA74(0),"^",3)),"P","B",$PIECE(RA74(0),"^",4),0))
+8 SET RAY3=$GET(^RADPT(X,"DT",(9999999.9999-$PIECE(RA74(0),"^",3)),"P",Y,0))
+9 SET RAEXFLD="PROC"
DO ^RARTFLDS
WRITE !,"Procedure: ",$EXTRACT(X,1,30)
+10 WRITE ?45,"Verified: ",$$FMTE^XLFDT($PIECE(RA74(0),"^",7),"1P")
+11 WRITE !!?4,"Routing Queue",?24,"Date Printed",?44,"Printed By",?62,"Ward/Clinic"
+12 WRITE !?4,"-------------",?24,"------------",?44,"----------",?62,"-----------"
+13 SET I=0
FOR
SET I=$ORDER(^RABTCH(74.4,"B",RARPT,I))
if I'>0
QUIT
Begin DoDot:1
+14 SET X=$GET(^RABTCH(74.4,I,0))
SET Y=+$PIECE(X,"^",11)
+15 SET Y=$SELECT($DATA(^RABTCH(74.3,Y,0))#2:$PIECE(^(0),"^"),1:"")
+16 WRITE !,$EXTRACT(Y,1,20),?24,$EXTRACT($$FMTE^XLFDT($PIECE(X,"^",4),1),1,18)
+17 SET Y=+$PIECE(X,"^",3)
SET Y=$SELECT($DATA(^VA(200,Y,0))#2:$PIECE(^(0),"^"),1:"")
+18 WRITE ?44,$EXTRACT(Y,1,17),?62
+19 if +$PIECE(X,"^",6)
WRITE $EXTRACT($$GET1^DIQ(42,+$PIECE(X,"^",6),.01),1,18)
+20 if +$PIECE(X,"^",8)
WRITE $EXTRACT($$GET1^DIQ(44,+$PIECE(X,"^",6),.01),1,18)
+21 QUIT
End DoDot:1
+22 WRITE !!,$$REPEAT^XLFSTR("=",IOM),!
+23 QUIT
