RAPSET1 ;HISC/FPT,GJC AISC/MJK-Set Sign-on parameters ;5/22/97 14:22
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DIS W !!,LINE,!,"Welcome, you are signed on with the following parameters:"
W !!?35,"Printer Defaults",!?1,"Version : ",$G(^DD(70,0,"VR")),?35,"----------------",!?1,"Division : ",$E($S($D(^DIC(4,+RAMDIV,0)):$P(^(0),"^"),1:"Unknown"),1,20)
W ?35,"Flash Card : " W:RAFLH $E($P(RAMLC,"^",3)_" "_$S($D(^%ZIS(1,+RAFLH,1)):$P(^(1),"^"),1:""),1,30) W:'RAFLH "None"
W !?1,"Location : ",$E($S('$D(^RA(79.1,+RAMLC,0)):"Unknown",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"Unknown"),1,20),?49,$S($P(RAMLC,"^",2):$P(RAMLC,"^",2)_" card/visit",$P(RAMDV,"^",2):"1 card/exam",1:"No cards")
W !?1,"Img. Type: ",$S($D(^RA(79.2,+$P(RAMLC,"^",6),0)):$E($P(^(0),"^"),1,20),1:"Unknown"),?35,"Jacket Label: " W:RAJAC $E($P(RAMLC,"^",5)_" "_$S($D(^%ZIS(1,+RAJAC,1)):$P(^(1),"^"),1:""),1,30) W:'RAJAC "None"
W !?1,"User : ",$S($D(^VA(200,+DUZ,0)):$P(^(0),"^"),1:"Unknown"),?49,$S($P(RAMLC,"^",4):$P(RAMLC,"^",4)_" labels/visit",1:"")
W ! I $P($G(^RA(79.1,+$P(RAMLC,"^"),0)),"^",19) W ?1,"** INACTIVE LOCATION **"
W ?35,"Report : " W:RARPT $E($P(RAMLC,"^",10)_" "_$S($D(^%ZIS(1,+RARPT,1)):$P(^(1),"^"),1:""),1,30) W:'RARPT "None"
I $P($G(^RA(79.2,+$P(RAMLC,"^",6),0)),"^",5)="Y" D
. N RADOSE,RADSE
. W !?35,"Dosage : " W:$P(RALOC,"^",23)']"" "None"
. I $P(RALOC,"^",23) D
.. D GETS^DIQ(3.5,$P(RALOC,"^",23)_",",".01;.02","","RADOSE")
.. S RADSE=RADOSE(3.5,$P(RALOC,"^",23)_",",.01)_" "_RADOSE(3.5,$P(RALOC,"^",23)_",",.02)
.. W $E(RADSE,1,30)
. Q
W !,LINE
;
Q ; Kill and quit
I $D(RASWLOC),($D(XQUIT)),(XQUIT']"") K XQUIT ; RA LOC SWITCH option
K %ZIS,RAI,DEV,DEVI,DIC,DIV,DUOUT,I,LINE,LOC,RADEV,RADIV,RAFLH
K RAJAC,RALOC,RARPT,X,Y,POP,DISYS
Q
;
SET K RALONE G ^RAPSET:'$D(RAMDIV)!('$D(RAMDV))!('$D(RAMLC))!('$D(RAIMGTY)) Q
;
KILL K RACCESS,RAMDIV,RAMDV,RAIMGTY,RAMLC
Q
SETVARS(X) ; Set variables integral to package operation.
; This code is used in lieu of the Entry Actions for many of the
; Radiology/Nuclear Medicine options.
; Problems Resolved: '^' jump, independently invoking options
; 'X=0' ---> Silent, creates RACCESS array.
; 'X=1' ---> Interactive, calls ^RAPSET (prompts for sign-on location)
D @$S(X=1:"^RAPSET",1:"VARACC^RAUTL6(DUZ)") K %,%W,%Y,%Y1,C,POP
Q
SW(RAXAMI,RALOGI) ; During 'Case No. Exam Edit' the user picked an exam
; that has a different imaging type than the imaging type of our
; sign-on location. This subroutine askes the user if they want to
; switch locations. RAMASK set in CHECK^RACNLU (saves off 'Y'
; 0 node of exam)
; Input Variables: RAXAMI-> imaging type of the exam
; RALOGI-> sign-on location imaging type
;
; Output Variable: 1 if location switch invalid, 0 if valid switch.
S:RAXAMI="" RAXAMI="UNKNOWN" S:RALOGI="" RALOGI="UNKNOWN"
W !!?7,"Current Imaging Type: ",RALOGI,!?5,"Procedure Imaging Type: ",RAXAMI
W !!,"You must switch to a location of ",RAXAMI," imaging type."
N RA7002 S RA7002=$G(^RADPT(+$P(RAMASK,"^"),"DT",+$P(RAMASK,"^",2),0))
S:$D(RACCESS(DUZ,"LOC",+$P(RA7002,"^",4))) ^DISV(DUZ,"^RA(79.1,")=+$P(RA7002,"^",4)
I '$D(RACCESS(DUZ,"LOC",+$G(^DISV(DUZ,"^RA(79.1,")))) D
. N I S I=0 F S I=$O(RACCESS(DUZ,"LOC",I)) Q:I'>0 D
.. S:$D(^RA(79.1,"BIMG",+$P(RA7002,"^",2),I)) ^DISV(DUZ,"^RA(79.1,")=I
.. Q
. Q
Q:'$D(^RA(79.1,"BIMG",+$P(RA7002,"^",2),+$G(^DISV(DUZ,"^RA(79.1,")))) "1^Sorry, you don't have access privileges to edit cases of this imaging type."
K RAMLC S RASWLOC="" D SET^RAPSET1 K RASWLOC
Q $S($$GET1^DIQ(79.1,+$G(RAMLC)_",",6,"E")'=RAXAMI:"1^No matches for this sign-on location!",1:0)
RAPSET1 ;HISC/FPT,GJC AISC/MJK-Set Sign-on parameters ;5/22/97 14:22
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DIS WRITE !!,LINE,!,"Welcome, you are signed on with the following parameters:"
+1 WRITE !!?35,"Printer Defaults",!?1,"Version : ",$GET(^DD(70,0,"VR")),?35,"----------------",!?1,"Division : ",$EXTRACT($SELECT($DATA(^DIC(4,+RAMDIV,0)):$PIECE(^(0),"^"),1:"Unknown"),1,20)
+2 WRITE ?35,"Flash Card : "
IF RAFLH
WRITE $EXTRACT($PIECE(RAMLC,"^",3)_" "_$SELECT($DATA(^%ZIS(1,+RAFLH,1)):$PIECE(^(1),"^"),1:""),1,30)
IF 'RAFLH
WRITE "None"
+3 WRITE !?1,"Location : ",$EXTRACT($SELECT('$DATA(^RA(79.1,+RAMLC,0)):"Unknown",$DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:"Unknown"),1,20),?49,$SELECT($PIECE(RAMLC,"^",2):$PIECE(RAMLC,"^",2)_" card/visit",$PIECE(RAMDV,"^",2):"1 card/exam",1:"No card
s")
+4 WRITE !?1,"Img. Type: ",$SELECT($DATA(^RA(79.2,+$PIECE(RAMLC,"^",6),0)):$EXTRACT($PIECE(^(0),"^"),1,20),1:"Unknown"),?35,"Jacket Label: "
IF RAJAC
WRITE $EXTRACT($PIECE(RAMLC,"^",5)_" "_$SELECT($DATA(^%ZIS(1,+RAJAC,1)):$PIECE(^(1),"^"),1:""),1,30)
IF 'RAJAC
WRITE "None"
+5 WRITE !?1,"User : ",$SELECT($DATA(^VA(200,+DUZ,0)):$PIECE(^(0),"^"),1:"Unknown"),?49,$SELECT($PIECE(RAMLC,"^",4):$PIECE(RAMLC,"^",4)_" labels/visit",1:"")
+6 WRITE !
IF $PIECE($GET(^RA(79.1,+$PIECE(RAMLC,"^"),0)),"^",19)
WRITE ?1,"** INACTIVE LOCATION **"
+7 WRITE ?35,"Report : "
IF RARPT
WRITE $EXTRACT($PIECE(RAMLC,"^",10)_" "_$SELECT($DATA(^%ZIS(1,+RARPT,1)):$PIECE(^(1),"^"),1:""),1,30)
IF 'RARPT
WRITE "None"
+8 IF $PIECE($GET(^RA(79.2,+$PIECE(RAMLC,"^",6),0)),"^",5)="Y"
Begin DoDot:1
+9 NEW RADOSE,RADSE
+10 WRITE !?35,"Dosage : "
IF $PIECE(RALOC,"^",23)']""
WRITE "None"
+11 IF $PIECE(RALOC,"^",23)
Begin DoDot:2
+12 DO GETS^DIQ(3.5,$PIECE(RALOC,"^",23)_",",".01;.02","","RADOSE")
+13 SET RADSE=RADOSE(3.5,$PIECE(RALOC,"^",23)_",",.01)_" "_RADOSE(3.5,$PIECE(RALOC,"^",23)_",",.02)
+14 WRITE $EXTRACT(RADSE,1,30)
End DoDot:2
+15 QUIT
End DoDot:1
+16 WRITE !,LINE
+17 ;
Q ; Kill and quit
+1 ; RA LOC SWITCH option
IF $DATA(RASWLOC)
IF ($DATA(XQUIT))
IF (XQUIT']"")
KILL XQUIT
+2 KILL %ZIS,RAI,DEV,DEVI,DIC,DIV,DUOUT,I,LINE,LOC,RADEV,RADIV,RAFLH
+3 KILL RAJAC,RALOC,RARPT,X,Y,POP,DISYS
+4 QUIT
+5 ;
SET KILL RALONE
IF '$DATA(RAMDIV)!('$DATA(RAMDV))!('$DATA(RAMLC))!('$DATA(RAIMGTY))
GOTO ^RAPSET
QUIT
+1 ;
KILL KILL RACCESS,RAMDIV,RAMDV,RAIMGTY,RAMLC
+1 QUIT
SETVARS(X) ; Set variables integral to package operation.
+1 ; This code is used in lieu of the Entry Actions for many of the
+2 ; Radiology/Nuclear Medicine options.
+3 ; Problems Resolved: '^' jump, independently invoking options
+4 ; 'X=0' ---> Silent, creates RACCESS array.
+5 ; 'X=1' ---> Interactive, calls ^RAPSET (prompts for sign-on location)
+6 DO @$SELECT(X=1:"^RAPSET",1:"VARACC^RAUTL6(DUZ)")
KILL %,%W,%Y,%Y1,C,POP
+7 QUIT
SW(RAXAMI,RALOGI) ; During 'Case No. Exam Edit' the user picked an exam
+1 ; that has a different imaging type than the imaging type of our
+2 ; sign-on location. This subroutine askes the user if they want to
+3 ; switch locations. RAMASK set in CHECK^RACNLU (saves off 'Y'
+4 ; 0 node of exam)
+5 ; Input Variables: RAXAMI-> imaging type of the exam
+6 ; RALOGI-> sign-on location imaging type
+7 ;
+8 ; Output Variable: 1 if location switch invalid, 0 if valid switch.
+9 IF RAXAMI=""
SET RAXAMI="UNKNOWN"
IF RALOGI=""
SET RALOGI="UNKNOWN"
+10 WRITE !!?7,"Current Imaging Type: ",RALOGI,!?5,"Procedure Imaging Type: ",RAXAMI
+11 WRITE !!,"You must switch to a location of ",RAXAMI," imaging type."
+12 NEW RA7002
SET RA7002=$GET(^RADPT(+$PIECE(RAMASK,"^"),"DT",+$PIECE(RAMASK,"^",2),0))
+13 IF $DATA(RACCESS(DUZ,"LOC",+$PIECE(RA7002,"^",4)))
SET ^DISV(DUZ,"^RA(79.1,")=+$PIECE(RA7002,"^",4)
+14 IF '$DATA(RACCESS(DUZ,"LOC",+$GET(^DISV(DUZ,"^RA(79.1,"))))
Begin DoDot:1
+15 NEW I
SET I=0
FOR
SET I=$ORDER(RACCESS(DUZ,"LOC",I))
IF I'>0
QUIT
Begin DoDot:2
+16 IF $DATA(^RA(79.1,"BIMG",+$PIECE(RA7002,"^",2),I))
SET ^DISV(DUZ,"^RA(79.1,")=I
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 IF '$DATA(^RA(79.1,"BIMG",+$PIECE(RA7002,"^",2),+$GET(^DISV(DUZ,"^RA(79.1,"))))
QUIT "1^Sorry, you don't have access privileges to edit cases of this imaging type."
+20 KILL RAMLC
SET RASWLOC=""
DO SET^RAPSET1
KILL RASWLOC
+21 QUIT $SELECT($$GET1^DIQ(79.1,+$GET(RAMLC)_",",6,"E")'=RAXAMI:"1^No matches for this sign-on location!",1:0)
