RAUTL4.m

RAUTL4 ;HISC/CAH,FPT,GJC AISC/SAW - Utility Routine ; Jan 05, 2022@16:30:37

 ;;5.0;Radiology/Nuclear Medicine;**123,186**;Mar 16, 1998;Build 1

 ;

 ; Supported IA #1252 reference to $$OUTPTPR^SDUTL3 & $$OUTPTAP^SDUTL3  5-P123

 ; Supported IA #10035 reference to (^DPT(DFN,.1)  5-P123

 ;

 ; 5-P123 6/25/2015 MJT RA*5*123 NSR 20140515 add primary care provider if pt is outpatient

 ;

EN1 ;ENTRY POINT FOR INPUT TRANSFORM FOR FIELD 5, FILE 74

 S RAX=$G(^RARPT(DA,0))

 I X="R",$D(^RA(79.1,+$P(^RADPT(+$P(RAX,U,2),"DT",(9999999.9999-$P(RAX,U,3)),0),U,4),0)),$P(^(0),U,17)'["Y" K X W !,"This Imaging Location does not allow the use of 'RELEASED/NOT VERIFIED' status!" G EXIT

 G EXIT:X'="V" S RACI=$S($D(RACNI):+RACNI,1:+$O(^RADPT(+$P(RAX,U,2),"DT",9999999.9999-$P(RAX,U,3),"P","B",+$P(RAX,U,4),0)))

 I '$D(^RADPT(+$P(RAX,U,2),"DT",9999999.9999-$P(RAX,U,3),"P",RACI,0)) K X W !?3,"Exam information is missing.  Unable to continue." G EXIT

 S RA0=^RADPT(+$P(RAX,U,2),"DT",9999999.9999-$P(RAX,U,3),"P",RACI,0),RAY=$S($D(^RAMIS(71,+$P(RA0,U,2),0)):$P(^(0),U,7),1:"N")

 I RAY'["Y",$D(^VA(200,+$P(RA0,U,12),0)) S RAY=$S($D(^("RA")):$P(^("RA"),U),1:"N")

 I RAY["Y",'$D(^VA(200,+$P(RA0,U,15),0)) K X W !?3,"Staff review is required to verify this report!" G EXIT

 I '$P(RA0,U,12),'$P(RA0,U,15) K X W !?3,"You must have at least an interpreting 'resident' or 'staff' entered before you can verify this report!" G EXIT

 I $D(^RA(79,+$P(^RADPT(+$P(RAX,U,2),"DT",(9999999.9999-$P(RAX,U,3)),0),U,3),.1)),$P(^(.1),U,16)="Y",$O(^RARPT(DA,"I",0))<0 K X W !?3,"An impression was not entered. Verifying is not allowed!"

 ; Handle the situation where a report moves from no report status

 ; (null) to a report status of verified.  This situation happens at

 ; sites when creating stub reports through the Imaging software.

 I $P(RAX,"^",5)="",(X="V") D

 . X:$D(^DD(74,5,1,2,2))#2 ^(2) ; kill 'ARES' xref

 . X:$D(^DD(74,5,1,3,2))#2 ^(2) ; kill 'ASTF' xref

 . Q

EXIT K RA0,RAX,RAY Q

ASK ;Prompt for range of entries, parse response

 ;INPUT VARIABLES:     ;ch

 ; RAF1: If defined, a list or range of numbers are permitted i.e,

 ;       1,2,3-8.  If not defined, only single number input is permitted.

 ; RACNT=highest possible number in range

 ; ^TMP($J,"RAEX",n)=array of acceptable numeric responses

 ;OUTPUT VARIABLES:

 ;  RADUP(n)=array of all selected numeric responses

 K RADUP S (RAERR,RAI)=0

 S X=$$USRSEL($D(RAF1)#2,$G(RACNT)) Q:X="^"!(X="")

 ; X returns: a single # -OR- a list of #'s i.e, 1-3,8 or 2,3,4 -OR- '^' 

 I '$D(RAF1),'$D(^TMP($J,"RAEX",+X)) W !!?3,*7,"Item ",+X," is not a valid selection.",! G ASK

 I '$D(RAF1) S X=+X,Y=^TMP($J,"RAEX",+X) Q

PARSE ; Parse out the list of numbers entered by the user.

 S RAI=RAI+1,RAPAR=$P(X,",",RAI) G EX:RAPAR="" I RAPAR?.N1"-".N S RADASH="" F RASEL=$P(RAPAR,"-"):1:$P(RAPAR,"-",2) D CHK G ASK:RAERR

 I '$D(RADASH) S RASEL=RAPAR D CHK

 K RADASH G ASK:RAERR,PARSE

 ;

CHK I $D(RADASH),+$P(RAPAR,"-",2)<+$P(RAPAR,"-") S RAERR=1 W !?3,*7,"Invalid range of numbers specified." Q

 I RASEL'?.N!(RASEL'=+RASEL)!(RASEL?16.N.E) D  Q

 . W !?3,$C(7),"Item ",RASEL," is not a valid selection.",!

 . S RAERR=1

 . Q

 I '$D(^TMP($J,"RAEX",RASEL)) W !?3,*7,"Item ",RASEL," is not a valid selection.",! S RAERR=1 Q

 I $D(RADUP(RASEL)) W !?3,*7,"Item ",RASEL," was already selected.",! S RAERR=1 Q

 S RADUP(RASEL)="" Q

EX S X="" I 'RAERR,$D(RADUP) S X=1

 Q

 ;

UPPER ;Convert X to uppercase letters, return as Y

 S Y=$$UP^XLFSTR(X)

 Q

ORDEL ; Inform the 'Rad' user that the 'Order' field is null!

 ; Called from the [RA STATUS ENTRY] template.

 W !!?5,"The value for the 'Order' field has been deleted, this"

 W !?5,"Examination Status is now inactive/invalid.  Please use"

 W !?5,"the 'List Exams with Inactive/Invalid Statuses' option to"

 W !?5,"generate a report showing all inactive/invalid exams.",!,$C(7)

 Q

EMAIL ; Sent the message off to the req. physician

 Q:'$D(DUZ)#2  ; DUZ not defined!

 Q:'($D(^TMP($J,"RA AUTOE"))\10)  ; no report data, abort

 N DUZ,XMDUZ,XMSUB,XMTEXT,XMY S XMDUZ=.5

 S XMTEXT="^TMP($J,""RA AUTOE"","

 S XMSUB="Rad/Nuc Med Report ("_$P($G(^RARPT(RA74IEN,0)),"^")_")"

 ;  ***  NSR 20140515  Start Mod  add primary care provider if pt is outpatient  5-P123  ***

 ;  ***  Also sends to associate provider if one identified  ; 5-P123

 S DFN=$P(RA74(0),U,2)

 I '$D(^DPT(DFN,.1)) S RAPCP=$$OUTPTPR^SDUTL3(DFN) S:RAPCP'="" XMY($P(RAPCP,U,1))="" S RAAP=$$OUTPTAP^SDUTL3(DFN) S:RAAP'="" XMY($P(RAAP,U,1))=""  ; 5-P123

 S XMY(RARPHYS)="" D ^XMD K ^TMP($J,"RA AUTOE")

 K RAAP,RAPCP    ; 5-P123

 ;  ***  NSR 20140515  End Mod  add primary care provider if pt is outpatient  5-P123  ***

 Q

ENV() ; Check the current environment the software is running under.

 ; If package is being installed DO NOT fire off message (0)

 ; If package wide variables are missing, DO NOT fire off message (0)

 Q:'$D(RACCESS(DUZ))\10!('$D(RAIMGTY))!('$D(RAMDIV))!('$D(RAMDV))!('$D(RAMLC)) 0 ; not in package

 Q:$D(XPDNM) 0 ; in environment check OR pre/post install routine

 Q 1

INCR(X) ; increment a variable by one

 S X=X+1,RAACNT=X

 Q RAACNT

 ;

USRSEL(RABOOL,RACNT) ; Allows the user to select a number or list of

 ; numbers within a certain range.

 ; Vars: RABOOL=1 if a list of #'s can be entered i.e, 1-3,8 -or- 2,3,4

 ;             =0 a single number is the only valid input

 ;        RACNT=the upper value within the valid range of numbers

 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 S DIR("A",1)="Type a '^' to STOP, or"

 S DIR("A")="CHOOSE FROM 1-"_RACNT_": "

 I RABOOL D  ; setup DIR to accept a list of #'s within our range

 . S DIR(0)="LACO^1:"_RACNT_":0",DIR("?",1)="Please enter a number or range of numbers seperated by a dash,",DIR("?")="or two or more numbers seperated by a combination of commas and dashes."

 . Q

 E  D  ; setup DIR to accept a single number within our range

 . S DIR(0)="NAO^1:"_RACNT_":0",DIR("?",1)="Enter the number corresponding to the exam you wish to select.",DIR("?")="A list or range of numbers will not be accepted."

 . Q

 D ^DIR S:$D(DTOUT)!($D(DUOUT)) Y="^" ; exit iff timeout or '^'

 ; this code effects the selection of exam record data when presented

 ; to the user from options: 'Profile of Rad/Nuc Med Exams', 'Case

 ; No. Exam Edit' & 'Select Report to Print by Patient'.

 ; Called from ^RAPTLU (patient exam lookup)

 S:$E(Y,$L(Y))="," Y=$$COMMA(Y)

 Q Y

COMMA(Y) ; If the last character in a string is a comma, strip it off

 ; example: 1-100, becomes 1-100

 N RA F RA=$L(Y):-1 Q:$E(Y,RA)'=","

 Q $E(Y,1,RA)

 ;

ASKFILM(RAITYP,RAY3) ;do higher exam statuses have ASK FOR FILM DATA?

 ;set to 'Y' (YES)? <case sensitive> p186

 ;Input: RAITYP = imaging type (external)

 ;  RAY3 = 0 node EXAMINATIONS multiple (#70.03)

 ;

 ;return: 'X' 0 for don't ask; 1 ask

 N RAIEN,RAORD,X,Y S X=0

 S (RAORD,Y)=$P($G(^RA(72,+$P(RAY3,U,3),0)),U,3)

 ;note: RAORD is order # for current status

 F  S Y=$O(^RA(72,"AA",RAITYP,Y)) Q:Y=""  D  Q:X=1

 .S RAIEN=$O(^RA(72,"AA",RAITYP,Y,0)) ;IEN file 72

 .;^DD(72,.24,0)="ASK FOR FILM DATA?^RS^Y:YES;N:NO;^.2;4^Q

 .S:$P($G(^RA(72,RAIEN,.2)),U,4)="Y" X=1

 .Q

 Q X

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RAUTL4   7169     printed  Feb 19, 2025@00:06:44                                                                                                                                                                                                      Page 2

RAUTL4    ;HISC/CAH,FPT,GJC AISC/SAW - Utility Routine ; Jan 05, 2022@16:30:37

 +1       ;;5.0;Radiology/Nuclear Medicine;**123,186**;Mar 16, 1998;Build 1

 +2       ;

 +3       ; Supported IA #1252 reference to $$OUTPTPR^SDUTL3 & $$OUTPTAP^SDUTL3  5-P123

 +4       ; Supported IA #10035 reference to (^DPT(DFN,.1)  5-P123

 +5       ;

 +6       ; 5-P123 6/25/2015 MJT RA*5*123 NSR 20140515 add primary care provider if pt is outpatient

 +7       ;

EN1       ;ENTRY POINT FOR INPUT TRANSFORM FOR FIELD 5, FILE 74

 +1        SET RAX=$GET(^RARPT(DA,0))

 +2        IF X="R"

               IF $DATA(^RA(79.1,+$PIECE(^RADPT(+$PIECE(RAX,U,2),"DT",(9999999.9999-$PIECE(RAX,U,3)),0),U,4),0))

                   IF $PIECE(^(0),U,17)'["Y"

                       KILL X

                       WRITE !,"This Imaging Location does not allow the use of 'RELEASED/NOT VERIFIED' status!"

                       GOTO EXIT

 +3        if X'="V"

               GOTO EXIT

           SET RACI=$SELECT($DATA(RACNI):+RACNI,1:+$ORDER(^RADPT(+$PIECE(RAX,U,2),"DT",9999999.9999-$PIECE(RAX,U,3),"P","B",+$PIECE(RAX,U,4),0)))

 +4        IF '$DATA(^RADPT(+$PIECE(RAX,U,2),"DT",9999999.9999-$PIECE(RAX,U,3),"P",RACI,0))

               KILL X

               WRITE !?3,"Exam information is missing.  Unable to continue."

               GOTO EXIT

 +5        SET RA0=^RADPT(+$PIECE(RAX,U,2),"DT",9999999.9999-$PIECE(RAX,U,3),"P",RACI,0)

           SET RAY=$SELECT($DATA(^RAMIS(71,+$PIECE(RA0,U,2),0)):$PIECE(^(0),U,7),1:"N")

 +6        IF RAY'["Y"

               IF $DATA(^VA(200,+$PIECE(RA0,U,12),0))

                   SET RAY=$SELECT($DATA(^("RA")):$PIECE(^("RA"),U),1:"N")

 +7        IF RAY["Y"

               IF '$DATA(^VA(200,+$PIECE(RA0,U,15),0))

                   KILL X

                   WRITE !?3,"Staff review is required to verify this report!"

                   GOTO EXIT

 +8        IF '$PIECE(RA0,U,12)

               IF '$PIECE(RA0,U,15)

                   KILL X

                   WRITE !?3,"You must have at least an interpreting 'resident' or 'staff' entered before you can verify this report!"

                   GOTO EXIT

 +9        IF $DATA(^RA(79,+$PIECE(^RADPT(+$PIECE(RAX,U,2),"DT",(9999999.9999-$PIECE(RAX,U,3)),0),U,3),.1))

               IF $PIECE(^(.1),U,16)="Y"

                   IF $ORDER(^RARPT(DA,"I",0))<0

                       KILL X

                       WRITE !?3,"An impression was not entered. Verifying is not allowed!"

 +10      ; Handle the situation where a report moves from no report status

 +11      ; (null) to a report status of verified.  This situation happens at

 +12      ; sites when creating stub reports through the Imaging software.

 +13       IF $PIECE(RAX,"^",5)=""

               IF (X="V")

                   Begin DoDot:1

 +14      ; kill 'ARES' xref

                       if $DATA(^DD(74,5,1,2,2))#2

                           XECUTE ^(2)

 +15      ; kill 'ASTF' xref

                       if $DATA(^DD(74,5,1,3,2))#2

                           XECUTE ^(2)

 +16                   QUIT 

                   End DoDot:1

EXIT       KILL RA0,RAX,RAY

           QUIT 

ASK       ;Prompt for range of entries, parse response

 +1       ;INPUT VARIABLES:     ;ch

 +2       ; RAF1: If defined, a list or range of numbers are permitted i.e,

 +3       ;       1,2,3-8.  If not defined, only single number input is permitted.

 +4       ; RACNT=highest possible number in range

 +5       ; ^TMP($J,"RAEX",n)=array of acceptable numeric responses

 +6       ;OUTPUT VARIABLES:

 +7       ;  RADUP(n)=array of all selected numeric responses

 +8        KILL RADUP

           SET (RAERR,RAI)=0

 +9        SET X=$$USRSEL($DATA(RAF1)#2,$GET(RACNT))

           if X="^"!(X="")

               QUIT 

 +10      ; X returns: a single # -OR- a list of #'s i.e, 1-3,8 or 2,3,4 -OR- '^' 

 +11       IF '$DATA(RAF1)

               IF '$DATA(^TMP($JOB,"RAEX",+X))

                   WRITE !!?3,*7,"Item ",+X," is not a valid selection.",!

                   GOTO ASK

 +12       IF '$DATA(RAF1)

               SET X=+X

               SET Y=^TMP($JOB,"RAEX",+X)

               QUIT 

PARSE     ; Parse out the list of numbers entered by the user.

 +1        SET RAI=RAI+1

           SET RAPAR=$PIECE(X,",",RAI)

           if RAPAR=""

               GOTO EX

           IF RAPAR?.N1"-".N

               SET RADASH=""

               FOR RASEL=$PIECE(RAPAR,"-"):1:$PIECE(RAPAR,"-",2)

                   DO CHK

                   if RAERR

                       GOTO ASK

 +2        IF '$DATA(RADASH)

               SET RASEL=RAPAR

               DO CHK

 +3        KILL RADASH

           if RAERR

               GOTO ASK

           GOTO PARSE

 +4       ;

CHK        IF $DATA(RADASH)

               IF +$PIECE(RAPAR,"-",2)<+$PIECE(RAPAR,"-")

                   SET RAERR=1

                   WRITE !?3,*7,"Invalid range of numbers specified."

                   QUIT 

 +1        IF RASEL'?.N!(RASEL'=+RASEL)!(RASEL?16.N.E)

               Begin DoDot:1

 +2                WRITE !?3,$CHAR(7),"Item ",RASEL," is not a valid selection.",!

 +3                SET RAERR=1

 +4                QUIT 

               End DoDot:1

               QUIT 

 +5        IF '$DATA(^TMP($JOB,"RAEX",RASEL))

               WRITE !?3,*7,"Item ",RASEL," is not a valid selection.",!

               SET RAERR=1

               QUIT 

 +6        IF $DATA(RADUP(RASEL))

               WRITE !?3,*7,"Item ",RASEL," was already selected.",!

               SET RAERR=1

               QUIT 

 +7        SET RADUP(RASEL)=""

           QUIT 

EX         SET X=""

           IF 'RAERR

               IF $DATA(RADUP)

                   SET X=1

 +1        QUIT 

 +2       ;

UPPER     ;Convert X to uppercase letters, return as Y

 +1        SET Y=$$UP^XLFSTR(X)

 +2        QUIT 

ORDEL     ; Inform the 'Rad' user that the 'Order' field is null!

 +1       ; Called from the [RA STATUS ENTRY] template.

 +2        WRITE !!?5,"The value for the 'Order' field has been deleted, this"

 +3        WRITE !?5,"Examination Status is now inactive/invalid.  Please use"

 +4        WRITE !?5,"the 'List Exams with Inactive/Invalid Statuses' option to"

 +5        WRITE !?5,"generate a report showing all inactive/invalid exams.",!,$CHAR(7)

 +6        QUIT 

EMAIL     ; Sent the message off to the req. physician

 +1       ; DUZ not defined!

           if '$DATA(DUZ)#2

               QUIT 

 +2       ; no report data, abort

           if '($DATA(^TMP($JOB,"RA AUTOE"))\10)

               QUIT 

 +3        NEW DUZ,XMDUZ,XMSUB,XMTEXT,XMY

           SET XMDUZ=.5

 +4        SET XMTEXT="^TMP($J,""RA AUTOE"","

 +5        SET XMSUB="Rad/Nuc Med Report ("_$PIECE($GET(^RARPT(RA74IEN,0)),"^")_")"

 +6       ;  ***  NSR 20140515  Start Mod  add primary care provider if pt is outpatient  5-P123  ***

 +7       ;  ***  Also sends to associate provider if one identified  ; 5-P123

 +8        SET DFN=$PIECE(RA74(0),U,2)

 +9       ; 5-P123

           IF '$DATA(^DPT(DFN,.1))

               SET RAPCP=$$OUTPTPR^SDUTL3(DFN)

               if RAPCP'=""

                   SET XMY($PIECE(RAPCP,U,1))=""

               SET RAAP=$$OUTPTAP^SDUTL3(DFN)

               if RAAP'=""

                   SET XMY($PIECE(RAAP,U,1))=""

 +10       SET XMY(RARPHYS)=""

           DO ^XMD

           KILL ^TMP($JOB,"RA AUTOE")

 +11      ; 5-P123

           KILL RAAP,RAPCP

 +12      ;  ***  NSR 20140515  End Mod  add primary care provider if pt is outpatient  5-P123  ***

 +13       QUIT 

ENV()     ; Check the current environment the software is running under.

 +1       ; If package is being installed DO NOT fire off message (0)

 +2       ; If package wide variables are missing, DO NOT fire off message (0)

 +3       ; not in package

           if '$DATA(RACCESS(DUZ))\10!('$DATA(RAIMGTY))!('$DATA(RAMDIV))!('$DATA(RAMDV))!('$DATA(RAMLC))

               QUIT 0

 +4       ; in environment check OR pre/post install routine

           if $DATA(XPDNM)

               QUIT 0

 +5        QUIT 1

INCR(X)   ; increment a variable by one

 +1        SET X=X+1

           SET RAACNT=X

 +2        QUIT RAACNT

 +3       ;

USRSEL(RABOOL,RACNT) ; Allows the user to select a number or list of

 +1       ; numbers within a certain range.

 +2       ; Vars: RABOOL=1 if a list of #'s can be entered i.e, 1-3,8 -or- 2,3,4

 +3       ;             =0 a single number is the only valid input

 +4       ;        RACNT=the upper value within the valid range of numbers

 +5        NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 +6        SET DIR("A",1)="Type a '^' to STOP, or"

 +7        SET DIR("A")="CHOOSE FROM 1-"_RACNT_": "

 +8       ; setup DIR to accept a list of #'s within our range

           IF RABOOL

               Begin DoDot:1

 +9                SET DIR(0)="LACO^1:"_RACNT_":0"

                   SET DIR("?",1)="Please enter a number or range of numbers seperated by a dash,"

                   SET DIR("?")="or two or more numbers seperated by a combination of commas and dashes."

 +10               QUIT 

               End DoDot:1

 +11      ; setup DIR to accept a single number within our range

          IF '$TEST

               Begin DoDot:1

 +12               SET DIR(0)="NAO^1:"_RACNT_":0"

                   SET DIR("?",1)="Enter the number corresponding to the exam you wish to select."

                   SET DIR("?")="A list or range of numbers will not be accepted."

 +13               QUIT 

               End DoDot:1

 +14      ; exit iff timeout or '^'

           DO ^DIR

           if $DATA(DTOUT)!($DATA(DUOUT))

               SET Y="^"

 +15      ; this code effects the selection of exam record data when presented

 +16      ; to the user from options: 'Profile of Rad/Nuc Med Exams', 'Case

 +17      ; No. Exam Edit' & 'Select Report to Print by Patient'.

 +18      ; Called from ^RAPTLU (patient exam lookup)

 +19       if $EXTRACT(Y,$LENGTH(Y))=","

               SET Y=$$COMMA(Y)

 +20       QUIT Y

COMMA(Y)  ; If the last character in a string is a comma, strip it off

 +1       ; example: 1-100, becomes 1-100

 +2        NEW RA

           FOR RA=$LENGTH(Y):-1

               if $EXTRACT(Y,RA)'=","

                   QUIT 

 +3        QUIT $EXTRACT(Y,1,RA)

 +4       ;

ASKFILM(RAITYP,RAY3) ;do higher exam statuses have ASK FOR FILM DATA?

 +1       ;set to 'Y' (YES)? <case sensitive> p186

 +2       ;Input: RAITYP = imaging type (external)

 +3       ;  RAY3 = 0 node EXAMINATIONS multiple (#70.03)

 +4       ;

 +5       ;return: 'X' 0 for don't ask; 1 ask

 +6        NEW RAIEN,RAORD,X,Y

           SET X=0

 +7        SET (RAORD,Y)=$PIECE($GET(^RA(72,+$PIECE(RAY3,U,3),0)),U,3)

 +8       ;note: RAORD is order # for current status

 +9        FOR 

               SET Y=$ORDER(^RA(72,"AA",RAITYP,Y))

               if Y=""

                   QUIT 

               Begin DoDot:1

 +10      ;IEN file 72

                   SET RAIEN=$ORDER(^RA(72,"AA",RAITYP,Y,0))

 +11      ;^DD(72,.24,0)="ASK FOR FILM DATA?^RS^Y:YES;N:NO;^.2;4^Q

 +12               if $PIECE($GET(^RA(72,RAIEN,.2)),U,4)="Y"

                       SET X=1

 +13               QUIT 

               End DoDot:1

               if X=1

                   QUIT 

 +14       QUIT X

 +15      ;