RALIST.m

RALIST ;HISC/GJC AISC/MJK,RMO-List all patient exams associated w/selected Amis ;4/15/96  14:27

 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998

 I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) S RAPSTX=""

 I $O(RACCESS(DUZ,""))="" D  Q

 . W !?5,"You do not have access to any Imaging Locations."

 . W !?5,"Contact your ADPAC."

 . Q

 S (RAFLG,RAXIT)=0

 D SELDIV^RAUTL7

 I $O(^TMP($J,"RA D-TYPE",""))=""!$G(RAQUIT) W !!?5,"No divisions selected." G Q

 D DATE^RAUTL G:RAPOP Q

 S DIC="^RAMIS(71.1,",DIC(0)="AEMQ" W ! D ^DIC G Q:Y<0 S RAMIS=+Y,RAMIS1=$P(Y,"^",2)

 K DIR S DIR(0)="YA",DIR("B")="Yes"

 S DIR("A")="Do you wish to include all Procedures? "

 S DIR("?",1)="Enter 'Yes' to select all entries in the file."

 S DIR("?")="Enter 'No' to select a subset of entries in the file."

 W ! D ^DIR K DIR G:$D(DIRUT) Q S RAINPUT=+Y

 I RAINPUT=0 S RAXIT=0 D  G:RAXIT Q

 . K RADIC

 . S RADIC="^RAMIS(71,",RADIC(0)="EMQZ",RADIC("A")="Select PROCEDURE: "

 . S RADIC("S")="I $O(^RAMIS(71,""AC"",RAMIS,+Y,0))",RAUTIL="RA P-TYPE"

 . D EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)

 . I $O(^TMP($J,"RA P-TYPE",""))=""!$G(RAQUIT) W !!?5,"No procedures selected." S RAXIT=1

 . Q

 S ZTRTN="START^RALIST" F RASV="BEGDATE","ENDDATE","RAFLG","RAXIT","RAMIS","RAMIS1","RAINPUT","^TMP($J,""RA D-TYPE"",","^TMP($J,""RA P-TYPE""," S ZTSAVE(RASV)=""

 W ! D ZIS^RAUTL G:RAPOP Q

START K ^TMP($J,"RALIST"),RACNT,RAIN,RAOUT

 ;create list of all procedures with the selected AMIS code if user

 ;specified that all procedures should be included

 S:$D(ZTQUEUED) ZTREQ="@"

 S RADIVNUM=$$NUMDIV^RALIST1()

 I RAINPUT=1 D

 . K ^TMP($J,"RA P-TYPE") N RAD0 S RAD0=0

 . F  S RAD0=$O(^RAMIS(71,RAD0)) Q:RAD0'>0  D

 .. Q:$O(^RAMIS(71,"AC",RAMIS,RAD0,0))'>0

 .. S X=$P($G(^RAMIS(71,RAD0,0)),U)

 .. I X]"" S ^TMP($J,"RA P-TYPE",X,RAD0)=""

 .. Q

 . Q

 S Y=BEGDATE D D^RAUTL S BEG=Y,Y=ENDDATE D D^RAUTL S END=Y,%DT="TX",X="NOW" D ^%DT D D^RAUTL S RANOW=Y

 U IO S (PAGE,RACNT,RAIN,RAOUT,RACOUNT)=0,BEGDATE=BEGDATE-.0001,ENDDATE=ENDDATE+.9999,RACRT=8 D CRIT^RAUTL1

 F RADTE=BEGDATE:0:ENDDATE S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>ENDDATE)  D  Q:RAXIT

 . F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0  D  Q:RAXIT

 .. I $D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$E($P(RANME,"^"),1,25) D RACNI

 .. Q

 . Q

 I RAXIT D Q QUIT

 S RADIVN=""

 F  S RADIVN=$O(^TMP($J,"RA D-TYPE",RADIVN)) Q:RADIVN=""  D

 . I $O(^TMP($J,"RALIST",RADIVN,0))'>0 S ^TMP($J,"RALIST",RADIVN)=""

 . Q

 D PRINT^RALIST1

 ; Kill and quit

Q K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA P-TYPE"),^TMP($J,"RALIST")

 K %DT,BEG,BEGDATE,C,DIC,END,ENDDATE,I,M,M1,PAGE,POP,RAPOP,RACNI,RACNT

 K RACOUNT,RACRT,RADATE,RADFN,RADIVN,RADTE,RADTI,RAFLG,RAIN,RAINPUT

 K RAMIS,RAMIS1,RAMUL,RAMUL1,RANME,RANOW,RAOUT,RAPROC,RAQI,RAQUIT,RASSN

 K RADIVNUM,RASV,RASTAT,N,N1,RABILAT,RAUTIL,RAXIT,TMP,X,Y,ZTRTN,ZTSAVE

 K DIROUT,DIRUT,DTOUT,DUOUT,RAMES,ZTDESC

 K:$D(RAPSTX) RACCESS,RAPSTX

 D CLOSE^RAUTL

 K DDH,DISYS

 Q

 ;

RACNI S RADTI=9999999.9999-RADTE S Y=RADTE D D^RAUTL S RADATE=Y

 S (RADIVN,Y)=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,3)

 S C=$P(^DD(70.02,3,0),U,2) D:Y]"" Y^DIQ S RADIVN(0)=Y Q:RADIVN(0)=""

 I $D(^TMP($J,"RA D-TYPE",RADIVN(0),RADIVN))[0 Q

 F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0  D  Q:RAXIT

 . S Y=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))

 . S RAPROC=$P(Y,U,2),RAPROC(0)=$P($G(^RAMIS(71,+RAPROC,0)),U)

 . ;if AMIS code 25 or 26 (OR or Portable) was selected, all procedures

 . ;regardless of AMIS code must be allowed because any exam can have

 . ;a modifier of Operating Room or Portable.

 . Q:RAPROC(0)=""  I RAMIS'=25&(RAMIS'=26) I $D(^TMP($J,"RA P-TYPE",RAPROC(0),RAPROC))[0 Q

 . I Y]"",$D(RACRT(+$P(Y,"^",3))) D RACNI1

 . Q

 Q

RACNI1 I $D(^RAMIS(71,"AC",RAMIS,+$P(Y,"^",2))) S RAMUL=$S(RAMIS=25!(RAMIS=26):1,1:$O(^RAMIS(71,"AC",RAMIS,+$P(Y,"^",2),0))) D PRT Q

 S RAMUL=1

 F M=0:0 S M=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M)) Q:'M  D  Q:RAXIT

 . S M1=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M,0))

 . S M1=$P($G(^RAMIS(71.2,M1,0)),U,2)

 . D PRT:(RAMIS=26&(M1="p"))&('RAXIT),PRT:(RAMIS=25&(M1="o"))&('RAXIT)

 . Q

 Q

 ;

PRT I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT

 G PRT1:RAMIS=25!(RAMIS=26)

 K RABILAT S RAMUL=$P(^RAMIS(71,+$P(Y,"^",2),2,RAMUL,0),"^",2) S:RAMUL="" RAMUL=1 I $P(^(0),"^",3)="Y" S RABILAT=1 S:RAMUL=1 RAMUL=2

 I '$D(RABILAT) F RAMUL1=0:0 S RAMUL1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAMUL1)) Q:RAMUL1'>0  I $D(^(RAMUL1,0)) S RAQI=+^(0) I $P($G(^RAMIS(71.2,RAQI,0)),U,2)="b" S RAMUL=RAMUL*2 Q

PRT1 S RACOUNT=RACOUNT+1

 S TMP=RANME_U_RASSN_U_$S(RAMUL>1:"+",RAMUL=0:"-",1:"")_U

 S TMP=TMP_$E($S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"Unknown"),1,25)_U

 S TMP=TMP_RADATE_U_$S($D(^DIC(42,+$P(Y,"^",6),0)):$P(^(0),"^"),$D(^SC(+$P(Y,"^",8),0)):$P(^(0),"^"),1:"Unknown")

 S ^TMP($J,"RALIST",RADIVN(0),RACOUNT)=TMP

 S RACNT(RADIVN(0))=$G(RACNT(RADIVN(0)))+RAMUL

 I $P(Y,"^",4)="I" S RAIN(RADIVN(0))=$G(RAIN(RADIVN(0)))+RAMUL Q

 S RAOUT(RADIVN(0))=$G(RAOUT(RADIVN(0)))+RAMUL

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RALIST   5084     printed  Feb 19, 2025@00:02:52                                                                                                                                                                                                      Page 2

RALIST    ;HISC/GJC AISC/MJK,RMO-List all patient exams associated w/selected Amis ;4/15/96  14:27

 +1       ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998

 +2        IF $ORDER(RACCESS(DUZ,""))=""

               DO SETVARS^RAPSET1(0)

               SET RAPSTX=""

 +3        IF $ORDER(RACCESS(DUZ,""))=""

               Begin DoDot:1

 +4                WRITE !?5,"You do not have access to any Imaging Locations."

 +5                WRITE !?5,"Contact your ADPAC."

 +6                QUIT 

               End DoDot:1

               QUIT 

 +7        SET (RAFLG,RAXIT)=0

 +8        DO SELDIV^RAUTL7

 +9        IF $ORDER(^TMP($JOB,"RA D-TYPE",""))=""!$GET(RAQUIT)

               WRITE !!?5,"No divisions selected."

               GOTO Q

 +10       DO DATE^RAUTL

           if RAPOP

               GOTO Q

 +11       SET DIC="^RAMIS(71.1,"

           SET DIC(0)="AEMQ"

           WRITE !

           DO ^DIC

           if Y<0

               GOTO Q

           SET RAMIS=+Y

           SET RAMIS1=$PIECE(Y,"^",2)

 +12       KILL DIR

           SET DIR(0)="YA"

           SET DIR("B")="Yes"

 +13       SET DIR("A")="Do you wish to include all Procedures? "

 +14       SET DIR("?",1)="Enter 'Yes' to select all entries in the file."

 +15       SET DIR("?")="Enter 'No' to select a subset of entries in the file."

 +16       WRITE !

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO Q

           SET RAINPUT=+Y

 +17       IF RAINPUT=0

               SET RAXIT=0

               Begin DoDot:1

 +18               KILL RADIC

 +19               SET RADIC="^RAMIS(71,"

                   SET RADIC(0)="EMQZ"

                   SET RADIC("A")="Select PROCEDURE: "

 +20               SET RADIC("S")="I $O(^RAMIS(71,""AC"",RAMIS,+Y,0))"

                   SET RAUTIL="RA P-TYPE"

 +21               DO EN1^RASELCT(.RADIC,RAUTIL,"",RAINPUT)

 +22               IF $ORDER(^TMP($JOB,"RA P-TYPE",""))=""!$GET(RAQUIT)

                       WRITE !!?5,"No procedures selected."

                       SET RAXIT=1

 +23               QUIT 

               End DoDot:1

               if RAXIT

                   GOTO Q

 +24       SET ZTRTN="START^RALIST"

           FOR RASV="BEGDATE","ENDDATE","RAFLG","RAXIT","RAMIS","RAMIS1","RAINPUT","^TMP($J,""RA D-TYPE"",","^TMP($J,""RA P-TYPE"","

               SET ZTSAVE(RASV)=""

 +25       WRITE !

           DO ZIS^RAUTL

           if RAPOP

               GOTO Q

START      KILL ^TMP($JOB,"RALIST"),RACNT,RAIN,RAOUT

 +1       ;create list of all procedures with the selected AMIS code if user

 +2       ;specified that all procedures should be included

 +3        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +4        SET RADIVNUM=$$NUMDIV^RALIST1()

 +5        IF RAINPUT=1

               Begin DoDot:1

 +6                KILL ^TMP($JOB,"RA P-TYPE")

                   NEW RAD0

                   SET RAD0=0

 +7                FOR 

                       SET RAD0=$ORDER(^RAMIS(71,RAD0))

                       if RAD0'>0

                           QUIT 

                       Begin DoDot:2

 +8                        if $ORDER(^RAMIS(71,"AC",RAMIS,RAD0,0))'>0

                               QUIT 

 +9                        SET X=$PIECE($GET(^RAMIS(71,RAD0,0)),U)

 +10                       IF X]""

                               SET ^TMP($JOB,"RA P-TYPE",X,RAD0)=""

 +11                       QUIT 

                       End DoDot:2

 +12               QUIT 

               End DoDot:1

 +13       SET Y=BEGDATE

           DO D^RAUTL

           SET BEG=Y

           SET Y=ENDDATE

           DO D^RAUTL

           SET END=Y

           SET %DT="TX"

           SET X="NOW"

           DO ^%DT

           DO D^RAUTL

           SET RANOW=Y

 +14       USE IO

           SET (PAGE,RACNT,RAIN,RAOUT,RACOUNT)=0

           SET BEGDATE=BEGDATE-.0001

           SET ENDDATE=ENDDATE+.9999

           SET RACRT=8

           DO CRIT^RAUTL1

 +15       FOR RADTE=BEGDATE:0:ENDDATE

               SET RADTE=$ORDER(^RADPT("AR",RADTE))

               if RADTE'>0!(RADTE>ENDDATE)

                   QUIT 

               Begin DoDot:1

 +16               FOR RADFN=0:0

                       SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))

                       if RADFN'>0

                           QUIT 

                       Begin DoDot:2

 +17                       IF $DATA(^DPT(RADFN,0))

                               SET RANME=^(0)

                               SET RASSN=$$SSN^RAUTL

                               SET RANME=$EXTRACT($PIECE(RANME,"^"),1,25)

                               DO RACNI

 +18                       QUIT 

                       End DoDot:2

                       if RAXIT

                           QUIT 

 +19               QUIT 

               End DoDot:1

               if RAXIT

                   QUIT 

 +20       IF RAXIT

               DO Q

               QUIT 

 +21       SET RADIVN=""

 +22       FOR 

               SET RADIVN=$ORDER(^TMP($JOB,"RA D-TYPE",RADIVN))

               if RADIVN=""

                   QUIT 

               Begin DoDot:1

 +23               IF $ORDER(^TMP($JOB,"RALIST",RADIVN,0))'>0

                       SET ^TMP($JOB,"RALIST",RADIVN)=""

 +24               QUIT 

               End DoDot:1

 +25       DO PRINT^RALIST1

 +26      ; Kill and quit

Q          KILL ^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA P-TYPE"),^TMP($JOB,"RALIST")

 +1        KILL %DT,BEG,BEGDATE,C,DIC,END,ENDDATE,I,M,M1,PAGE,POP,RAPOP,RACNI,RACNT

 +2        KILL RACOUNT,RACRT,RADATE,RADFN,RADIVN,RADTE,RADTI,RAFLG,RAIN,RAINPUT

 +3        KILL RAMIS,RAMIS1,RAMUL,RAMUL1,RANME,RANOW,RAOUT,RAPROC,RAQI,RAQUIT,RASSN

 +4        KILL RADIVNUM,RASV,RASTAT,N,N1,RABILAT,RAUTIL,RAXIT,TMP,X,Y,ZTRTN,ZTSAVE

 +5        KILL DIROUT,DIRUT,DTOUT,DUOUT,RAMES,ZTDESC

 +6        if $DATA(RAPSTX)

               KILL RACCESS,RAPSTX

 +7        DO CLOSE^RAUTL

 +8        KILL DDH,DISYS

 +9        QUIT 

 +10      ;

RACNI      SET RADTI=9999999.9999-RADTE

           SET Y=RADTE

           DO D^RAUTL

           SET RADATE=Y

 +1        SET (RADIVN,Y)=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,3)

 +2        SET C=$PIECE(^DD(70.02,3,0),U,2)

           if Y]""

               DO Y^DIQ

           SET RADIVN(0)=Y

           if RADIVN(0)=""

               QUIT 

 +3        IF $DATA(^TMP($JOB,"RA D-TYPE",RADIVN(0),RADIVN))[0

               QUIT 

 +4        FOR RACNI=0:0

               SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))

               if RACNI'>0

                   QUIT 

               Begin DoDot:1

 +5                SET Y=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))

 +6                SET RAPROC=$PIECE(Y,U,2)

                   SET RAPROC(0)=$PIECE($GET(^RAMIS(71,+RAPROC,0)),U)

 +7       ;if AMIS code 25 or 26 (OR or Portable) was selected, all procedures

 +8       ;regardless of AMIS code must be allowed because any exam can have

 +9       ;a modifier of Operating Room or Portable.

 +10               if RAPROC(0)=""

                       QUIT 

                   IF RAMIS'=25&(RAMIS'=26)

                       IF $DATA(^TMP($JOB,"RA P-TYPE",RAPROC(0),RAPROC))[0

                           QUIT 

 +11               IF Y]""

                       IF $DATA(RACRT(+$PIECE(Y,"^",3)))

                           DO RACNI1

 +12               QUIT 

               End DoDot:1

               if RAXIT

                   QUIT 

 +13       QUIT 

RACNI1     IF $DATA(^RAMIS(71,"AC",RAMIS,+$PIECE(Y,"^",2)))

               SET RAMUL=$SELECT(RAMIS=25!(RAMIS=26):1,1:$ORDER(^RAMIS(71,"AC",RAMIS,+$PIECE(Y,"^",2),0)))

               DO PRT

               QUIT 

 +1        SET RAMUL=1

 +2        FOR M=0:0

               SET M=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M))

               if 'M

                   QUIT 

               Begin DoDot:1

 +3                SET M1=+$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",M,0))

 +4                SET M1=$PIECE($GET(^RAMIS(71.2,M1,0)),U,2)

 +5                if (RAMIS=26&(M1="p"))&('RAXIT)

                       DO PRT

                   if (RAMIS=25&(M1="o"))&('RAXIT)

                       DO PRT

 +6                QUIT 

               End DoDot:1

               if RAXIT

                   QUIT 

 +7        QUIT 

 +8       ;

PRT        IF $DATA(ZTQUEUED)

               DO STOPCHK^RAUTL9

               if $GET(ZTSTOP)=1

                   SET RAXIT=1

               if RAXIT

                   QUIT 

 +1        if RAMIS=25!(RAMIS=26)

               GOTO PRT1

 +2        KILL RABILAT

           SET RAMUL=$PIECE(^RAMIS(71,+$PIECE(Y,"^",2),2,RAMUL,0),"^",2)

           if RAMUL=""

               SET RAMUL=1

           IF $PIECE(^(0),"^",3)="Y"

               SET RABILAT=1

               if RAMUL=1

                   SET RAMUL=2

 +3        IF '$DATA(RABILAT)

               FOR RAMUL1=0:0

                   SET RAMUL1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAMUL1))

                   if RAMUL1'>0

                       QUIT 

                   IF $DATA(^(RAMUL1,0))

                       SET RAQI=+^(0)

                       IF $PIECE($GET(^RAMIS(71.2,RAQI,0)),U,2)="b"

                           SET RAMUL=RAMUL*2

                           QUIT 

PRT1       SET RACOUNT=RACOUNT+1

 +1        SET TMP=RANME_U_RASSN_U_$SELECT(RAMUL>1:"+",RAMUL=0:"-",1:"")_U

 +2        SET TMP=TMP_$EXTRACT($SELECT($DATA(^RAMIS(71,+$PIECE(Y,"^",2),0)):$PIECE(^(0),"^"),1:"Unknown"),1,25)_U

 +3        SET TMP=TMP_RADATE_U_$SELECT($DATA(^DIC(42,+$PIECE(Y,"^",6),0)):$PIECE(^(0),"^"),$DATA(^SC(+$PIECE(Y,"^",8),0)):$PIECE(^(0),"^"),1:"Unknown")

 +4        SET ^TMP($JOB,"RALIST",RADIVN(0),RACOUNT)=TMP

 +5        SET RACNT(RADIVN(0))=$GET(RACNT(RADIVN(0)))+RAMUL

 +6        IF $PIECE(Y,"^",4)="I"

               SET RAIN(RADIVN(0))=$GET(RAIN(RADIVN(0)))+RAMUL

               QUIT 

 +7        SET RAOUT(RADIVN(0))=$GET(RAOUT(RADIVN(0)))+RAMUL

 +8        QUIT