RAMAIN ;HISC/FPT,GJC,CAH AISC/MJK,RMO;VMP/PW-Utility File Maintenance ; Jul 07, 2022@10:41:55
;;5.0;Radiology/Nuclear Medicine;**31,43,50,54,87,133,183,192**;Mar 16, 1998;Build 1
;
; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Option File Access
3 ;;Major AMIS Code Enter/Edit
; --- p192
L3 ;add/edit AMIS codes
S DIC="^RAMIS(71.1,",DIC(0)="AELQ",DLAYGO=71.1 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y,DDH,I,POP,DISYS Q
S DA=+Y,DIE="^RAMIS(71.1,",DR=".01;2" D ^DIE
K %,%W,%Y,D0,DA,DE,DQ,DIE,DR,DI,I,POP G L3
; ---
4 ;;Film Type Enter/Edit
K DD,DIC,DLAYGO,DO
S DIC="^RA(78.4,",DIC(0)="AEMQL",DLAYGO=78.4 W ! D ^DIC
K DD,DIC,DLAYGO,DO
I +Y<0 D D Q4 Q
. D DSPLNKS^RAMAIN1
. K D,DI,X,Y
. Q
S DA=+Y,DIE="^RA(78.4,",DR=".01;2;3;4;5;S:+X'=1 Y=""@1"";6;@1"
D ^DIE S RA784=$G(^RA(78.4,DA,0)),RA784(1)=$P(RA784,U)
S RA784(5)=+$P(RA784,U,4),RA784(6)=$P(RA784,U,5)
I RA784(5),(RA784(6)']"") D
. N DIE,DR
. W !!?5,$C(7),"'"_RA784(1)_"' has been defined as a wasted film size."
. W !?5,"If a particular film size is deemed as a wasted piece of"
. W !?5,"film, the wasted piece of film must be associated with an"
. W !?5,"unwasted piece of film."
. W !!?5,"Redefining '"_RA784(1)_"' as an unwasted film size."
. S DIE="^RA(78.4,",DR="5///@" D ^DIE W " Done!"
. Q
K %,D0,DA,DE,DQ,DIE,DR,RA784,X,Y G 4
Q4 K I,POP,DISYS,DDH
Q
;
5 ;;Diagnostic Code Enter/Edit
S DIC="^RA(78.3,",DIC(0)="AEMQL",DLAYGO=78.3 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y,POP,I Q
S DA=+Y,DIE="^RA(78.3,",DR="2:5" D ^DIE K %,D0,DA,DE,DQ,DIE,DR,I,DI G 5
;
6 ;;Flash Card/Label Formatter
I '$D(RAFLH) D ;P183
.W !!?5,">>> Exam Label/Report Header/Report Footer/Flash Card Formatter <<<"
.W !!,$$CJ^XLFSTR("Note: re-compilation will remove all local modifications",$G(IOM,80))
.Q
S DIC="^RA(78.2,",DIC(0)="AEMQL",DLAYGO=78.2 W ! D ^DIC K DIC,DLAYGO G Q6:Y<0 S (RAFLH,DA)=+Y,DIE="^RA(78.2,",DR="[RA FLASH CARD EDIT]" D ^DIE K DE,DQ,DIE,DR I '$D(^RA(78.2,RAFLH,0)) G Q6
S RAFMT=RAFLH,RAK=0
F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D SETFLH^RAFLH2(RAK)
D CMP^RAFLH1
W !!,"<<<<<<----------------------------Column No.------------------------------>>>>>>"
W !!,"0--------1---------2---------3---------4---------5---------6---------7---------8"
W !,"1 0 0 0 0 0 0 0 0",! S RATEST="",RANUM=1,RAFFLF="!" D PRT^RAFLH K RAFFLF W !! G 6
Q6 S RAK=0 F S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 D KILFLH^RAFLH2(RAK)
K %,%W,%X,%Y,D,D0,D1,DA,FL,RA787,RATEST,RAII,RAK,RAFLH,RAFMT,RANUM,X,Y
K POP,I,DDH,DUOUT,DI,DISYS
Q
;
7 ;;Complication Type Enter/Edit
S DIC="^RA(78.1,",DIC(0)="AEMQL",DLAYGO=78.1 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y G Q7
S DA=+Y,DIE="^RA(78.1,",DR=".01;2" D ^DIE K %,D,D0,DA,DE,DQ,DIE,DR D Q7 G 7
Q7 K DI,DISYS,I,POP Q
;
8 ;;Sharing/Contract Agreement Entry/Edit
S DIC="^DIC(34,",DIC(0)="AELMQ",DIC("A")="Select Agreement/Contract: ",DLAYGO=34 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y,I,POP Q
S DA=+Y,DIE="^DIC(34,",DR=".01:3" D ^DIE K %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS G 8
;
9 ;;Standard Reports
S DIC="^RA(74.1,",DIC(0)="AEMQL",DLAYGO=74.1 W ! D ^DIC K DIC,DLAYGO I Y<0 K D,X,Y D Q9 Q
S DA=+Y,DIE="^RA(74.1,",DR="[RA STANDARD REPORT ENTRY]" D ^DIE K %,%W,%X,%Y,C,D,D0,DA,DE,DQ,DIE,DR,X,Y D Q9 G 9
Q9 K DDH,DI,DISYS,I,J,POP
Q
;
10 ;;Procedure Modifiers Entry
K DD,DO,DLAYGO,DIC,DA,DINUM,X,Y
;S (DIC,DLAYGO)="^RAMIS(71.2,",DIC(0)="AEMQL"
; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Changed next line to set DLAYGO equal to the file number instead of the file root
S DIC="^RAMIS(71.2,",DLAYGO=71.2,DIC(0)="AEMQL"
S DIC("A")="Select Procedure Modifier: ",DIC("W")="D PROHLP^RAMAIN"
W ! D ^DIC K DIC,DLAYGO I +Y'>0 K D,X,Y,POP,I,DDH,DG,DISYS,DUOUT Q
S DIE="^RAMIS(71.2,",DA=+Y,DR="3;4" D ^DIE
K %W,%X,%Y,D,DIE,DO,DD,DLAYGO,DA,DR,X,Y,POP,I,D0,DI,DISYS,DQ,C G 10
;
11 ;;Reports Distribution Edit
S DIC="^RABTCH(74.3,",DIC(0)="AEMQ" W ! D ^DIC K DIC I Y<0 K D,X,Y,I,POP Q
S DA=+Y,DIE="^RABTCH(74.3,",DR="[RA DISTRIBUTION EDIT]" D ^DIE K %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS,I,POP G 11
;
12 ;;Rad/Nuc Med Procedure Message Enter/Edit
S DIC="^RAMIS(71.4,",DIC(0)="AELMQ",DLAYGO=71.4
W ! D ^DIC K DIC,DLAYGO I Y<0 K D,DTOUT,DUOUT,X,Y Q
S DA=+Y
L +^RAMIS(71.4,DA):3 I '$T D G 12 ;*54
. K DIR S DIR(0)="EA",DIR("A")="Sorry, someone else is editing that entry. <cr> - continue " D ^DIR K DIR
K RAMLNA,RAMLNB S RAMSGDA=DA ;*50
S RAMLNA=$G(^RAMIS(71.4,DA,0)) ;*50
S DIE="^RAMIS(71.4,",DR=.01 D ^DIE
S RAMLNB=$G(^RAMIS(71.4,+$G(DA),0)) ;*50
I RAMLNB'=RAMLNA S DA=RAMSGDA D ORDITMS^RAMAIN3 ;*50
L -^RAMIS(71.4,RAMSGDA) ;*54
K %,%W,%X,%Y,D0,DA,DE,DQ,DR,DIE,X,Y,RAMLNA,RAMLNB,RAMSGDA
G 12
;
13 ;;Cost of Procedure Enter/Edit
I '$D(RACCESS(DUZ)) D SET^RAPSET1 I $D(XQUIT) K RACCESS,XQUIT Q
; ask img type
K ^TMP($J,"RA I-TYPE") D SELIMG^RAUTL7 G:$G(RAQUIT) 139
N RA0,RA1,RA2 S RA0="",RA2=""
131 S RA0=$O(^TMP($J,"RA I-TYPE",RA0)) G:RA0="" 133
132 S RA1=$O(^TMP($J,"RA I-TYPE",RA0,0)) G:'RA1 131
S RA2=RA1_U_RA2 G 131
133 G:RA2="" 139 S DIC="^RAMIS(71,",DIC(0)="AEMQ"
; restrict choice of procedure by img type selected
S DIC("S")="I RA2[$P(^(0),U,12)"
W ! D ^DIC K DIC I Y<0 K %,DTOUT,DUOUT,DIC,X,Y G 139
S DA=+Y,DIE="^RAMIS(71,",DR=10 D ^DIE
K D,D0,DA,DDH,DI,DIC,DIE,DQ,DR,X
G 133
139 K ^TMP($J,"RA I-TYPE"),RAQUIT
Q
;
;RA REASON EDIT /RA*5*133
14 ;;Reason Enter/Edit
S DIC="^RA(75.2,",DIC(0)="AEQL",DLAYGO=75.2 W ! D ^DIC K DIC,DLAYGO I Y<0 K DIC,DA Q
I $P(^RA(75.2,+Y,0),"^",5)="Y" W !!?10,"***National standardized reason - NO EDITING!***" G 14
S DA=+Y,DIE="^RA(75.2,",DR="2:4" D ^DIE K DIE,DR,DA,Y G 14
Q
PROHLP ; Help displays the modifiers and all associated imaging types.
D:'$D(IOM) HOME^%ZIS
N RAIT,RAIT1,RAIT2,RAIT3 Q:'+$O(^RAMIS(71.2,+Y,1,0)) ; Quit, no data
S (RAIT,RAIT3)=0
F S RAIT=+$O(^RAMIS(71.2,+Y,1,RAIT)) W:'RAIT ")" Q:'RAIT D
. S RAIT1=+$G(^RAMIS(71.2,+Y,1,RAIT,0))
. S RAIT2=$P($G(^RA(79.2,RAIT1,0)),"^",3)
. W:($X+5)>IOM !?2 W ?$X+1 W:'RAIT3 "(" W RAIT2 S RAIT3=1
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMAIN 6139 printed Apr 09, 2024@21:37:38 Page 2
RAMAIN ;HISC/FPT,GJC,CAH AISC/MJK,RMO;VMP/PW-Utility File Maintenance ; Jul 07, 2022@10:41:55
+1 ;;5.0;Radiology/Nuclear Medicine;**31,43,50,54,87,133,183,192**;Mar 16, 1998;Build 1
+2 ;
+3 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Option File Access
3 ;;Major AMIS Code Enter/Edit
+1 ; --- p192
L3 ;add/edit AMIS codes
+1 SET DIC="^RAMIS(71.1,"
SET DIC(0)="AELQ"
SET DLAYGO=71.1
WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL D,X,Y,DDH,I,POP,DISYS
QUIT
+2 SET DA=+Y
SET DIE="^RAMIS(71.1,"
SET DR=".01;2"
DO ^DIE
+3 KILL %,%W,%Y,D0,DA,DE,DQ,DIE,DR,DI,I,POP
GOTO L3
+4 ; ---
4 ;;Film Type Enter/Edit
+1 KILL DD,DIC,DLAYGO,DO
+2 SET DIC="^RA(78.4,"
SET DIC(0)="AEMQL"
SET DLAYGO=78.4
WRITE !
DO ^DIC
+3 KILL DD,DIC,DLAYGO,DO
+4 IF +Y<0
Begin DoDot:1
+5 DO DSPLNKS^RAMAIN1
+6 KILL D,DI,X,Y
+7 QUIT
End DoDot:1
DO Q4
QUIT
+8 SET DA=+Y
SET DIE="^RA(78.4,"
SET DR=".01;2;3;4;5;S:+X'=1 Y=""@1"";6;@1"
+9 DO ^DIE
SET RA784=$GET(^RA(78.4,DA,0))
SET RA784(1)=$PIECE(RA784,U)
+10 SET RA784(5)=+$PIECE(RA784,U,4)
SET RA784(6)=$PIECE(RA784,U,5)
+11 IF RA784(5)
IF (RA784(6)']"")
Begin DoDot:1
+12 NEW DIE,DR
+13 WRITE !!?5,$CHAR(7),"'"_RA784(1)_"' has been defined as a wasted film size."
+14 WRITE !?5,"If a particular film size is deemed as a wasted piece of"
+15 WRITE !?5,"film, the wasted piece of film must be associated with an"
+16 WRITE !?5,"unwasted piece of film."
+17 WRITE !!?5,"Redefining '"_RA784(1)_"' as an unwasted film size."
+18 SET DIE="^RA(78.4,"
SET DR="5///@"
DO ^DIE
WRITE " Done!"
+19 QUIT
End DoDot:1
+20 KILL %,D0,DA,DE,DQ,DIE,DR,RA784,X,Y
GOTO 4
Q4 KILL I,POP,DISYS,DDH
+1 QUIT
+2 ;
5 ;;Diagnostic Code Enter/Edit
+1 SET DIC="^RA(78.3,"
SET DIC(0)="AEMQL"
SET DLAYGO=78.3
WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL D,X,Y,POP,I
QUIT
+2 SET DA=+Y
SET DIE="^RA(78.3,"
SET DR="2:5"
DO ^DIE
KILL %,D0,DA,DE,DQ,DIE,DR,I,DI
GOTO 5
+3 ;
6 ;;Flash Card/Label Formatter
+1 ;P183
IF '$DATA(RAFLH)
Begin DoDot:1
+2 WRITE !!?5,">>> Exam Label/Report Header/Report Footer/Flash Card Formatter <<<"
+3 WRITE !!,$$CJ^XLFSTR("Note: re-compilation will remove all local modifications",$GET(IOM,80))
+4 QUIT
End DoDot:1
+5 SET DIC="^RA(78.2,"
SET DIC(0)="AEMQL"
SET DLAYGO=78.2
WRITE !
DO ^DIC
KILL DIC,DLAYGO
if Y<0
GOTO Q6
SET (RAFLH,DA)=+Y
SET DIE="^RA(78.2,"
SET DR="[RA FLASH CARD EDIT]"
DO ^DIE
KILL DE,DQ,DIE,DR
IF '$DATA(^RA(78.2,RAFLH,0))
GOTO Q6
+6 SET RAFMT=RAFLH
SET RAK=0
+7 FOR
SET RAK=$ORDER(^RA(78.7,RAK))
if RAK'>0
QUIT
DO SETFLH^RAFLH2(RAK)
+8 DO CMP^RAFLH1
+9 WRITE !!,"<<<<<<----------------------------Column No.------------------------------>>>>>>"
+10 WRITE !!,"0--------1---------2---------3---------4---------5---------6---------7---------8"
+11 WRITE !,"1 0 0 0 0 0 0 0 0",!
SET RATEST=""
SET RANUM=1
SET RAFFLF="!"
DO PRT^RAFLH
KILL RAFFLF
WRITE !!
GOTO 6
Q6 SET RAK=0
FOR
SET RAK=$ORDER(^RA(78.7,RAK))
if RAK'>0
QUIT
DO KILFLH^RAFLH2(RAK)
+1 KILL %,%W,%X,%Y,D,D0,D1,DA,FL,RA787,RATEST,RAII,RAK,RAFLH,RAFMT,RANUM,X,Y
+2 KILL POP,I,DDH,DUOUT,DI,DISYS
+3 QUIT
+4 ;
7 ;;Complication Type Enter/Edit
+1 SET DIC="^RA(78.1,"
SET DIC(0)="AEMQL"
SET DLAYGO=78.1
WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL D,X,Y
GOTO Q7
+2 SET DA=+Y
SET DIE="^RA(78.1,"
SET DR=".01;2"
DO ^DIE
KILL %,D,D0,DA,DE,DQ,DIE,DR
DO Q7
GOTO 7
Q7 KILL DI,DISYS,I,POP
QUIT
+1 ;
8 ;;Sharing/Contract Agreement Entry/Edit
+1 SET DIC="^DIC(34,"
SET DIC(0)="AELMQ"
SET DIC("A")="Select Agreement/Contract: "
SET DLAYGO=34
WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL D,X,Y,I,POP
QUIT
+2 SET DA=+Y
SET DIE="^DIC(34,"
SET DR=".01:3"
DO ^DIE
KILL %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS
GOTO 8
+3 ;
9 ;;Standard Reports
+1 SET DIC="^RA(74.1,"
SET DIC(0)="AEMQL"
SET DLAYGO=74.1
WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL D,X,Y
DO Q9
QUIT
+2 SET DA=+Y
SET DIE="^RA(74.1,"
SET DR="[RA STANDARD REPORT ENTRY]"
DO ^DIE
KILL %,%W,%X,%Y,C,D,D0,DA,DE,DQ,DIE,DR,X,Y
DO Q9
GOTO 9
Q9 KILL DDH,DI,DISYS,I,J,POP
+1 QUIT
+2 ;
10 ;;Procedure Modifiers Entry
+1 KILL DD,DO,DLAYGO,DIC,DA,DINUM,X,Y
+2 ;S (DIC,DLAYGO)="^RAMIS(71.2,",DIC(0)="AEMQL"
+3 ; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Changed next line to set DLAYGO equal to the file number instead of the file root
+4 SET DIC="^RAMIS(71.2,"
SET DLAYGO=71.2
SET DIC(0)="AEMQL"
+5 SET DIC("A")="Select Procedure Modifier: "
SET DIC("W")="D PROHLP^RAMAIN"
+6 WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF +Y'>0
KILL D,X,Y,POP,I,DDH,DG,DISYS,DUOUT
QUIT
+7 SET DIE="^RAMIS(71.2,"
SET DA=+Y
SET DR="3;4"
DO ^DIE
+8 KILL %W,%X,%Y,D,DIE,DO,DD,DLAYGO,DA,DR,X,Y,POP,I,D0,DI,DISYS,DQ,C
GOTO 10
+9 ;
11 ;;Reports Distribution Edit
+1 SET DIC="^RABTCH(74.3,"
SET DIC(0)="AEMQ"
WRITE !
DO ^DIC
KILL DIC
IF Y<0
KILL D,X,Y,I,POP
QUIT
+2 SET DA=+Y
SET DIE="^RABTCH(74.3,"
SET DR="[RA DISTRIBUTION EDIT]"
DO ^DIE
KILL %,%W,%X,%Y,D,D0,DA,DE,DQ,DIE,DR,X,Y,DI,DISYS,I,POP
GOTO 11
+3 ;
12 ;;Rad/Nuc Med Procedure Message Enter/Edit
+1 SET DIC="^RAMIS(71.4,"
SET DIC(0)="AELMQ"
SET DLAYGO=71.4
+2 WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL D,DTOUT,DUOUT,X,Y
QUIT
+3 SET DA=+Y
+4 ;*54
LOCK +^RAMIS(71.4,DA):3
IF '$TEST
Begin DoDot:1
+5 KILL DIR
SET DIR(0)="EA"
SET DIR("A")="Sorry, someone else is editing that entry. <cr> - continue "
DO ^DIR
KILL DIR
End DoDot:1
GOTO 12
+6 ;*50
KILL RAMLNA,RAMLNB
SET RAMSGDA=DA
+7 ;*50
SET RAMLNA=$GET(^RAMIS(71.4,DA,0))
+8 SET DIE="^RAMIS(71.4,"
SET DR=.01
DO ^DIE
+9 ;*50
SET RAMLNB=$GET(^RAMIS(71.4,+$GET(DA),0))
+10 ;*50
IF RAMLNB'=RAMLNA
SET DA=RAMSGDA
DO ORDITMS^RAMAIN3
+11 ;*54
LOCK -^RAMIS(71.4,RAMSGDA)
+12 KILL %,%W,%X,%Y,D0,DA,DE,DQ,DR,DIE,X,Y,RAMLNA,RAMLNB,RAMSGDA
+13 GOTO 12
+14 ;
13 ;;Cost of Procedure Enter/Edit
+1 IF '$DATA(RACCESS(DUZ))
DO SET^RAPSET1
IF $DATA(XQUIT)
KILL RACCESS,XQUIT
QUIT
+2 ; ask img type
+3 KILL ^TMP($JOB,"RA I-TYPE")
DO SELIMG^RAUTL7
if $GET(RAQUIT)
GOTO 139
+4 NEW RA0,RA1,RA2
SET RA0=""
SET RA2=""
131 SET RA0=$ORDER(^TMP($JOB,"RA I-TYPE",RA0))
if RA0=""
GOTO 133
132 SET RA1=$ORDER(^TMP($JOB,"RA I-TYPE",RA0,0))
if 'RA1
GOTO 131
+1 SET RA2=RA1_U_RA2
GOTO 131
133 if RA2=""
GOTO 139
SET DIC="^RAMIS(71,"
SET DIC(0)="AEMQ"
+1 ; restrict choice of procedure by img type selected
+2 SET DIC("S")="I RA2[$P(^(0),U,12)"
+3 WRITE !
DO ^DIC
KILL DIC
IF Y<0
KILL %,DTOUT,DUOUT,DIC,X,Y
GOTO 139
+4 SET DA=+Y
SET DIE="^RAMIS(71,"
SET DR=10
DO ^DIE
+5 KILL D,D0,DA,DDH,DI,DIC,DIE,DQ,DR,X
+6 GOTO 133
139 KILL ^TMP($JOB,"RA I-TYPE"),RAQUIT
+1 QUIT
+2 ;
+3 ;RA REASON EDIT /RA*5*133
14 ;;Reason Enter/Edit
+1 SET DIC="^RA(75.2,"
SET DIC(0)="AEQL"
SET DLAYGO=75.2
WRITE !
DO ^DIC
KILL DIC,DLAYGO
IF Y<0
KILL DIC,DA
QUIT
+2 IF $PIECE(^RA(75.2,+Y,0),"^",5)="Y"
WRITE !!?10,"***National standardized reason - NO EDITING!***"
GOTO 14
+3 SET DA=+Y
SET DIE="^RA(75.2,"
SET DR="2:4"
DO ^DIE
KILL DIE,DR,DA,Y
GOTO 14
+4 QUIT
PROHLP ; Help displays the modifiers and all associated imaging types.
+1 if '$DATA(IOM)
DO HOME^%ZIS
+2 ; Quit, no data
NEW RAIT,RAIT1,RAIT2,RAIT3
if '+$ORDER(^RAMIS(71.2,+Y,1,0))
QUIT
+3 SET (RAIT,RAIT3)=0
+4 FOR
SET RAIT=+$ORDER(^RAMIS(71.2,+Y,1,RAIT))
if 'RAIT
WRITE ")"
if 'RAIT
QUIT
Begin DoDot:1
+5 SET RAIT1=+$GET(^RAMIS(71.2,+Y,1,RAIT,0))
+6 SET RAIT2=$PIECE($GET(^RA(79.2,RAIT1,0)),"^",3)
+7 if ($X+5)>IOM
WRITE !?2
WRITE ?$X+1
if 'RAIT3
WRITE "("
WRITE RAIT2
SET RAIT3=1
+8 QUIT
End DoDot:1
+9 QUIT
