- 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)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPSET1 3694 printed Jan 18, 2025@03:39:58 Page 2
- 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)