Routine: RARTST2A

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),!

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

RARTST2A.m