- RAORD1 ;HISC/CAH,AISC/RMO - Request An Exam ; Nov 29, 2023@09:33:48
- ;;5.0;Radiology/Nuclear Medicine;**10,45,41,75,86,183,209**;Mar 16, 1998;Build 3
- ;
- ;Supported IA #10035 reference to ^DPT(
- ;Supported IA #10040 reference to ^SC(
- ;Supported IA #10060 reference to ^VA(200
- ;Supported IA #2055 reference to $$EXTERNAL^DILFD
- ;Supported IA #2378 reference to ORCHK^GMRAOR
- ;Supported IA #10061 reference to ^VADPT
- ;Supported IA #10112 reference to ^VASITE
- ;Supported IA #10103 reference to ^XLFDT
- ;Supported IA #10141 reference to ^XPDUTL
- ;Supported IA #10009 reference to FILE^DICN
- ;Supported IA #10018 reference to ^DIE
- ;
- ;*Billing Awareness Project:
- ; RABWDX Array: ICD Diagnosis^SC^AO^IR^EC^MST^HNC
- ; RABWDX is used in RABWORD* and RABWPCE*.
- K RABWDX
- ;*
- ;p209/KLM -INC29784322: New RAOUT
- S RAPKG="" N RAPTLKUP,RAGMTS,RACOPYOR,RAOUT
- G ADDORD:$D(RAVSTFLG)&($D(RALIFN))&($D(RAPIFN))
- ;
- I '$D(RAREGFLG),'$D(RAVSTFLG) N RAPTLOCK K RAWARD D G:'RAPTLKUP Q
- PAT .S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC
- .I Y<0 S RAPTLKUP=0 Q
- .S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(") G:'RAPTLOCK PAT
- .S (DFN,RADFN)=+Y,(VA200,RAPTLKUP)=1
- .W ! D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2)
- .D ELIG^RABWORD2
- .Q
- ;
- PL ;Ask for the patient location (REQ. LOCATION file: 75.1, field: #22)
- N RACPRS27 S RACPRS27=$$PATCH^XPDUTL("OR*3.0*243")
- S DIC("A")="Patient Location: ",DIC("B")=$S($D(RAWARD)#2:RAWARD,1:"")
- S DIC="^SC(",DIC(0)="AEMQ"
- ;
- ;With the installation of RA*5.0*86 and after the implementation of
- ;CPRS v27 all active locations are eligible for selection regardless
- ;of patient type.
- ;
- ;If RAWARD is defined it is set to the name of the ward; pass either a 0
- ;or 1.
- ;Pass either a 0 or 1 as a value for RACPRS27. If 1 then CPRS GUI v27
- ;(OR*3.0*243) is installed at this facility.
- S DIC("S")="I $$SCREEN^RAORD1A("_($D(RAWARD)#2)_","_(RACPRS27)_")"
- ;
- D ^DIC K DIC K:'$D(RAREGFLG) RAWARD G Q:Y<0 S RALIFN=+Y
- S DIC("A")="Person Requesting Order: "
- ;*Billing Awareness Project:
- S DIC("S")="I $$PROV^RABWORD()"
- ;Display Service Connected prompts if user is a Provider.
- ;DIC(0) updated w/P183
- S DIC="^VA(200,",DIC(0)="QEA",Y=DUZ S:$$PROV^RABWORD DIC("B")=$P(^VA(200,DUZ,0),"^",1)
- D ^DIC K DIC G Q:Y<0 S RAPIFN=+Y K DD,DO,VA200,VAERR,VAIP G ADDORD:$D(RAVSTFLG)
- ;
- ENADD ;OE/RR Entry Point for the ACTION Option
- K ORSTOP,ORTO,ORCOST,ORPURG
- I '$D(RAPKG) G Q:'$D(ORVP)!('$D(ORL))!('$D(ORNP)) S (DFN,RADFN)=+ORVP,RALIFN=+ORL,RAPIFN=$S(+ORNP:+ORNP,$D(RAPIFN):RAPIFN,1:+ORNP),RAFOERR=""
- ; RAFOERR is used as a flag to track when a user enters this option
- ; from OE/RR (frontdoor). If this variable exists when a request is
- ; being printed, exam information is omitted from the request.
- S RANME=^DPT(RADFN,0),RASEX=$P(RANME,"^",2),RANME=$P(RANME,"^") D EXAM^RADEM1:'$D(RAREGFLG)&($D(RAPKG)) I '$D(RAREGFLG) S VA200=1 D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2)
- D SAVE ; save off original value of RAMDV!
- S RAL0=$S($D(^SC(RALIFN,0)):^(0),1:0)
- S RADIV=+$$SITE^VASITE(DT,+$P(RAL0,"^",15)) S:RADIV<0 RADIV=0
- S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
- S RAMDV=$TR($G(^RA(79,+RADIV,.1)),"YyNn","1100")
- D:'$D(RACAT)#2 ;if not defined, define the variable RACAT
- .I $D(RAWARD)#2 S RACAT="INPATIENT" Q
- .N Y S Y=$G(^RADPT(RADFN,0)) I Y="" S RACAT="OUTPATIENT" Q
- .S RACAT=$$EXTERNAL^DILFD(70,.04,"",$P(Y,U,4))
- .S:RACAT="" RACAT="OUTPATIENT"
- .Q
- ; clear clin hist if:
- ; rad backdoor, or
- ; oe/rr's first order (quick or not)
- I $D(RAPKG) K ^TMP($J,"RAWP")
- I '$D(RAPKG),$G(XQORS)>1,$G(^TMP("XQORS",$J,XQORS-1,"ITM"))=1 K ^TMP($J,"RAWP")
- ;
- ADDORD I $D(RADR1) D ALLERGY,CREATE1 G Q
- ; Set flag variable 'RASTOP' to track if procedure messages (if any)
- ; have been displayed. Value altered in EN2+1^RAPRI & DISP+12^RAORDU1.
- D:'$D(VAEL) ELIG^VADPT
- I $D(^RAO(75.1,"B",RADFN)) D
- .I '$D(RAVSTFLG) D PREV^RABWORD2 Q
- .D ADDEXAM^RABWORD2
- D DISP^RAPRI G:RAIMGTYI'>0 Q
- ADDORD1 W !,"Select Procedure",$S(RACNT:" (1-"_RACNT_") ",1:" "),"or enter '?' for help: "
- R RARX:DTIME
- S:'$T RARX="^" G Q:RARX=""!($E(RARX)="^")
- S:RARX=" " RARX=$S($D(RASX):RASX,1:RARX)
- I $E(RARX)="?"!(RARX=0)!(RARX=" ")!(RARX?.E1N1"-"1N.E)!(RARX?.E1".".E) D HELP^RAPRI G Q:Y'=1 D DISP1^RAPRI G ADDORD1
- S RAEXMUL=1 K RAHSMULT
- F RAJ=1:1 S X=$P(RARX,",",RAJ) Q:X="" S RASTOP=0 W !!!,"Processing procedure: ",$S(+X&(+X'>RACNT):$P($G(RAPRC(X)),"^"),$E(X)'="`":X,1:"") D LOOKUP^RAPRI Q:$D(RAOUT) S:RAPRI>0 RASX="`"_RAPRI D:RAPRI>0 ALLERGY,CREATE Q:$D(RAOUT) K RAPRI
- I $D(RAREASK),'$D(RAOUT) K RAREASK D DISP1^RAPRI G ADDORD1
- Q ; Kill, unlock if locked, and quit
- D KILL^RAORD
- D SAVE ; reset RAMDV to its original value!
- I $$ORVR^RAORDU()'<3,(+$G(RAPTLOCK)),(+$G(RADFN)) D
- . D ULK^RAUTL19(RADFN_";DPT(")
- K:'$D(RAREGFLG)&('$D(RAVSTFLG)) RACAT,RADFN,RANME,RAWARD
- I '$D(RAPKG) K RAMDIV,RAMDV,RAMLC
- I $D(RAPKG) K ORIFN,ORIT,ORL,ORNP,ORNS,ORPCL,ORPK,ORPV,ORPURG,ORSTS,ORTX,ORVP,RAPKG
- K RAHSMULT,RAPOP,RAIMAG,RAREAST,RAREQLOC
- K C,DI,DIG,DIH,DISYS,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DN,I,ORCHART,POP,RAMDVZZ,RASCI,RASERIES
- Q
- CREATE S RACT=0 D MODS Q:$D(RAOUT)
- CREATE1 ;ask for the 'Date Desired' req'd P75
- S RAWHEN=$$DESDT^RAUTL12(RAPRI) S:RAWHEN=-1 RAOUT=1 Q:$D(RAOUT)#2
- S RAWHEN=$$FMTE^XLFDT(RAWHEN,1) ;convert to external format
- ; Ask pregnant if age is between 12 & 55. Ask once for mult requests
- ; RASKPREG is the variable used to track if the pregnant prompt has
- ; been asked. Ask only once for multiple requests.
- S:'$D(RASKPREG) RAPREG=$$PREG^RAORD1A(RADFN,$G(DT)),RASKPREG="" Q:$D(RAOUT)
- ;Reason for Study (req'd) & Clinical History (optional) asked in CH^RAUTL5 P75
- D CH^RAUTL5 Q:$D(RAOUT) ;RAOUT: defined if Reason for Study is nonexistent
- BAQUES ;*Billing Awareness Project
- ; Ask Ordering ICD-9 Diagnosis and Related SC/EI/MST/HNC questions.
- N RADTM D NOW^%DTC S RADTM=%
- D ASK^RABWORD(RADFN,RADTM)
- I '$D(RADR1) D DISP^RAORDU1 Q:$D(RAOUT) ; Display Order Responses.
- S X=RADFN,DIC="^RAO(75.1,",DIC(0)="L",DLAYGO=75.1
- D FILE^DICN K DIC Q:Y<0 S RAOIFN=+Y K DLAYGO
- I $D(RAREGFLG)!($D(RAVSTFLG)) S RANUM=$S('$D(RANUM):1,1:RANUM+1),RAORDS(RANUM)=RAOIFN
- I $D(^RA(79,+RADIV,.1)),$P(^(.1),"^",21)="y" S RALOCFLG=""
- W ! S DA=RAOIFN,DIE="^RAO(75.1,",DIE("NO^")="OUTOK"
- S DR=$S($D(RADR1):"[RA QUICK EXAM ORDER]",$D(RADR2):"[RA ORDER EXAM]",$D(RAEXMUL)&($D(RAFIN1)):"[RA QUICK EXAM ORDER]",1:"[RA ORDER EXAM]")
- ;*Billing Awareness Project
- ; If Order questions are being Re-Asked then Re-Ask ICD-9 Dx questions
- I DR="[RA ORDER EXAM]" D ASK^RABWORD(RADFN,RADTM) W !!
- D ^DIE
- K DIE("NO^"),DE,DQ,DIE,DR,RADR1,RADR2
- I $D(RAFIN),$D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0) D FILEDX^RABWORD(RADFN,RAOIFN) Q:'$D(RAFIN) D SETORD^RAORDU D OERR^RAORDU:'$D(RAPKG) D ^RAORDQ:$D(RAPKG) K RAORD0
- I '$D(RAFIN) W !?3,$C(7),"Request not complete. Must Delete..." S DA=RAOIFN,DIK="^RAO(75.1," D ^DIK W "...deletion complete!" I $D(RAREGFLG)!($D(RAVSTFLG)) K RAORDS(RANUM)
- I '$D(RAFIN),('$D(^RAO(75.1,RAOIFN,0))#2) Q ; record deleted!
- K RAFIN
- ; check if the 'stat' or 'urgent' alert is to be sent.
- N RALOC,RAORD0
- S RAORD0=$G(^RAO(75.1,RAOIFN,0)),RALOC=+$P(RAORD0,"^",20)
- Q:'RALOC ; if no 'SUBMIT TO' location, can't send stat/urgent alerts
- I $P(RAORD0,"^",6)=1!(($P(RAORD0,"^",6)=2)&($P(^RA(79.1,RALOC,0),"^",20)="Y")) D
- .; If 6th piece of RAORD0=1 *stat*, =2 *urgent*
- .Q:$$ORVR^RAORDU()<3
- .; needs OE/RR 3.0 or greater for stat/urgent alerts to fire
- .D OENO^RAUTL19(RAOIFN)
- .Q
- Q
- ;
- MODS ;RAPRI= Procedure IEN, RAIMAG=Imaging Type for the procedure.
- ;Edited 4/19/94, Type of Imaging is now a multiple in file 71.2. CEW
- S RAIMAG=+$$ITYPE^RASITE(RAPRI),DIC(0)="AEQMZ",DIC="^RAMIS(71.2,",DIC("A")="Select "_$P($G(^DIC(71.2,0)),"^")_": "
- S DIC("S")="I +$D(^RAMIS(71.2,""AB"",RAIMAG,+Y)),$S('$G(RASERIES):1,$P(^RAMIS(71.2,+Y,0),U,2)="""":1,1:0),$$INIMOD^RAORD1A($P($G(^RAMIS(71.2,+Y,0)),""^""))"
- D ^DIC K DIC,RAIMAG S:$D(DTOUT)!($D(DUOUT)) RAOUT=1 Q:$D(RAOUT)!(X="^")!(X="") I Y<1 W $C(7)," ??" G MODS
- S RACT=RACT+1,RAMOD(RACT)=$P(Y,"^",2) G MODS
- Q
- ;
- ALLERGY ; If patient has had a previous contrast media allergic reaction
- ; check procedure RAPRI for specific contrast media associations
- ; (new with RA*5*45)
- Q:'$$ORCHK^GMRAOR(RADFN,"CM")
- S RAPRI(0)=$G(^RAMIS(71,RAPRI,0))
- I $P(RAPRI(0),U,6)'="P" D ;not a parent check lone procedure
- .D CONTRAST^RAUTL2(RAPRI)
- .Q
- E S I=0 D ;check descendent procedures for CM
- .F S I=$O(^RAMIS(71,RAPRI,4,I)) Q:'I D CONTRAST^RAUTL2(+$G(^(I,0)))
- .K I
- .Q
- K RAPRI(0)
- Q
- SAVE ; Save original value of RAMDV before it is altered in the ENADD sub-
- ; routine. This code will also reset RAMDV to the sign-on value.
- Q:'$D(RAPKG) ; entered through OE/RR (RAMDV will not be set)
- Q:'$D(RAMDV)&('$D(RAMDVZZ)) ;entered through 'Request an Exam' option used stand-alone outside of Rad/NM pkg
- I '$D(RAMDVZZ) S RAMDVZZ=RAMDV
- E S RAMDV=RAMDVZZ
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORD1 9000 printed Feb 19, 2025@00:04:19 Page 2
- RAORD1 ;HISC/CAH,AISC/RMO - Request An Exam ; Nov 29, 2023@09:33:48
- +1 ;;5.0;Radiology/Nuclear Medicine;**10,45,41,75,86,183,209**;Mar 16, 1998;Build 3
- +2 ;
- +3 ;Supported IA #10035 reference to ^DPT(
- +4 ;Supported IA #10040 reference to ^SC(
- +5 ;Supported IA #10060 reference to ^VA(200
- +6 ;Supported IA #2055 reference to $$EXTERNAL^DILFD
- +7 ;Supported IA #2378 reference to ORCHK^GMRAOR
- +8 ;Supported IA #10061 reference to ^VADPT
- +9 ;Supported IA #10112 reference to ^VASITE
- +10 ;Supported IA #10103 reference to ^XLFDT
- +11 ;Supported IA #10141 reference to ^XPDUTL
- +12 ;Supported IA #10009 reference to FILE^DICN
- +13 ;Supported IA #10018 reference to ^DIE
- +14 ;
- +15 ;*Billing Awareness Project:
- +16 ; RABWDX Array: ICD Diagnosis^SC^AO^IR^EC^MST^HNC
- +17 ; RABWDX is used in RABWORD* and RABWPCE*.
- +18 KILL RABWDX
- +19 ;*
- +20 ;p209/KLM -INC29784322: New RAOUT
- +21 SET RAPKG=""
- NEW RAPTLKUP,RAGMTS,RACOPYOR,RAOUT
- +22 if $DATA(RAVSTFLG)&($DATA(RALIFN))&($DATA(RAPIFN))
- GOTO ADDORD
- +23 ;
- +24 IF '$DATA(RAREGFLG)
- IF '$DATA(RAVSTFLG)
- NEW RAPTLOCK
- KILL RAWARD
- Begin DoDot:1
- PAT SET DIC="^DPT("
- SET DIC(0)="AEMQ"
- WRITE !
- DO ^DIC
- KILL DIC
- +1 IF Y<0
- SET RAPTLKUP=0
- QUIT
- +2 SET RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
- if 'RAPTLOCK
- GOTO PAT
- +3 SET (DFN,RADFN)=+Y
- SET (VA200,RAPTLKUP)=1
- +4 WRITE !
- DO IN5^VADPT
- if VAIP(1)
- SET RAWARD=$PIECE(VAIP(5),"^",2)
- +5 DO ELIG^RABWORD2
- +6 QUIT
- End DoDot:1
- if 'RAPTLKUP
- GOTO Q
- +7 ;
- PL ;Ask for the patient location (REQ. LOCATION file: 75.1, field: #22)
- +1 NEW RACPRS27
- SET RACPRS27=$$PATCH^XPDUTL("OR*3.0*243")
- +2 SET DIC("A")="Patient Location: "
- SET DIC("B")=$SELECT($DATA(RAWARD)#2:RAWARD,1:"")
- +3 SET DIC="^SC("
- SET DIC(0)="AEMQ"
- +4 ;
- +5 ;With the installation of RA*5.0*86 and after the implementation of
- +6 ;CPRS v27 all active locations are eligible for selection regardless
- +7 ;of patient type.
- +8 ;
- +9 ;If RAWARD is defined it is set to the name of the ward; pass either a 0
- +10 ;or 1.
- +11 ;Pass either a 0 or 1 as a value for RACPRS27. If 1 then CPRS GUI v27
- +12 ;(OR*3.0*243) is installed at this facility.
- +13 SET DIC("S")="I $$SCREEN^RAORD1A("_($DATA(RAWARD)#2)_","_(RACPRS27)_")"
- +14 ;
- +15 DO ^DIC
- KILL DIC
- if '$DATA(RAREGFLG)
- KILL RAWARD
- if Y<0
- GOTO Q
- SET RALIFN=+Y
- +16 SET DIC("A")="Person Requesting Order: "
- +17 ;*Billing Awareness Project:
- +18 SET DIC("S")="I $$PROV^RABWORD()"
- +19 ;Display Service Connected prompts if user is a Provider.
- +20 ;DIC(0) updated w/P183
- +21 SET DIC="^VA(200,"
- SET DIC(0)="QEA"
- SET Y=DUZ
- if $$PROV^RABWORD
- SET DIC("B")=$PIECE(^VA(200,DUZ,0),"^",1)
- +22 DO ^DIC
- KILL DIC
- if Y<0
- GOTO Q
- SET RAPIFN=+Y
- KILL DD,DO,VA200,VAERR,VAIP
- if $DATA(RAVSTFLG)
- GOTO ADDORD
- +23 ;
- ENADD ;OE/RR Entry Point for the ACTION Option
- +1 KILL ORSTOP,ORTO,ORCOST,ORPURG
- +2 IF '$DATA(RAPKG)
- if '$DATA(ORVP)!('$DATA(ORL))!('$DATA(ORNP))
- GOTO Q
- SET (DFN,RADFN)=+ORVP
- SET RALIFN=+ORL
- SET RAPIFN=$SELECT(+ORNP:+ORNP,$DATA(RAPIFN):RAPIFN,1:+ORNP)
- SET RAFOERR=""
- +3 ; RAFOERR is used as a flag to track when a user enters this option
- +4 ; from OE/RR (frontdoor). If this variable exists when a request is
- +5 ; being printed, exam information is omitted from the request.
- +6 SET RANME=^DPT(RADFN,0)
- SET RASEX=$PIECE(RANME,"^",2)
- SET RANME=$PIECE(RANME,"^")
- if '$DATA(RAREGFLG)&($DATA(RAPKG))
- DO EXAM^RADEM1
- IF '$DATA(RAREGFLG)
- SET VA200=1
- DO IN5^VADPT
- if VAIP(1)
- SET RAWARD=$PIECE(VAIP(5),"^",2)
- +7 ; save off original value of RAMDV!
- DO SAVE
- +8 SET RAL0=$SELECT($DATA(^SC(RALIFN,0)):^(0),1:0)
- +9 SET RADIV=+$$SITE^VASITE(DT,+$PIECE(RAL0,"^",15))
- if RADIV<0
- SET RADIV=0
- +10 SET RADIV=$SELECT($DATA(^RA(79,RADIV,0)):RADIV,1:$ORDER(^RA(79,0)))
- +11 SET RAMDV=$TRANSLATE($GET(^RA(79,+RADIV,.1)),"YyNn","1100")
- +12 ;if not defined, define the variable RACAT
- if '$DATA(RACAT)#2
- Begin DoDot:1
- +13 IF $DATA(RAWARD)#2
- SET RACAT="INPATIENT"
- QUIT
- +14 NEW Y
- SET Y=$GET(^RADPT(RADFN,0))
- IF Y=""
- SET RACAT="OUTPATIENT"
- QUIT
- +15 SET RACAT=$$EXTERNAL^DILFD(70,.04,"",$PIECE(Y,U,4))
- +16 if RACAT=""
- SET RACAT="OUTPATIENT"
- +17 QUIT
- End DoDot:1
- +18 ; clear clin hist if:
- +19 ; rad backdoor, or
- +20 ; oe/rr's first order (quick or not)
- +21 IF $DATA(RAPKG)
- KILL ^TMP($JOB,"RAWP")
- +22 IF '$DATA(RAPKG)
- IF $GET(XQORS)>1
- IF $GET(^TMP("XQORS",$JOB,XQORS-1,"ITM"))=1
- KILL ^TMP($JOB,"RAWP")
- +23 ;
- ADDORD IF $DATA(RADR1)
- DO ALLERGY
- DO CREATE1
- GOTO Q
- +1 ; Set flag variable 'RASTOP' to track if procedure messages (if any)
- +2 ; have been displayed. Value altered in EN2+1^RAPRI & DISP+12^RAORDU1.
- +3 if '$DATA(VAEL)
- DO ELIG^VADPT
- +4 IF $DATA(^RAO(75.1,"B",RADFN))
- Begin DoDot:1
- +5 IF '$DATA(RAVSTFLG)
- DO PREV^RABWORD2
- QUIT
- +6 DO ADDEXAM^RABWORD2
- End DoDot:1
- +7 DO DISP^RAPRI
- if RAIMGTYI'>0
- GOTO Q
- ADDORD1 WRITE !,"Select Procedure",$SELECT(RACNT:" (1-"_RACNT_") ",1:" "),"or enter '?' for help: "
- +1 READ RARX:DTIME
- +2 if '$TEST
- SET RARX="^"
- if RARX=""!($EXTRACT(RARX)="^")
- GOTO Q
- +3 if RARX=" "
- SET RARX=$SELECT($DATA(RASX):RASX,1:RARX)
- +4 IF $EXTRACT(RARX)="?"!(RARX=0)!(RARX=" ")!(RARX?.E1N1"-"1N.E)!(RARX?.E1".".E)
- DO HELP^RAPRI
- if Y'=1
- GOTO Q
- DO DISP1^RAPRI
- GOTO ADDORD1
- +5 SET RAEXMUL=1
- KILL RAHSMULT
- +6 FOR RAJ=1:1
- SET X=$PIECE(RARX,",",RAJ)
- if X=""
- QUIT
- SET RASTOP=0
- WRITE !!!,"Processing procedure: ",$SELECT(+X&(+X'>RACNT):$PIECE($GET(RAPRC(X)),"^"),$EXTRACT(X)'="`":X,1:"")
- DO LOOKUP^RAPRI
- if $DATA(RAOUT)
- QUIT
- if RAPRI>0
- SET RASX="`"_RAPRI
- if RAPRI>0
- DO ALLERGY
- DO CREATE
- if $DATA(RAOUT)
- QUIT
- KILL RAPRI
- +7 IF $DATA(RAREASK)
- IF '$DATA(RAOUT)
- KILL RAREASK
- DO DISP1^RAPRI
- GOTO ADDORD1
- Q ; Kill, unlock if locked, and quit
- +1 DO KILL^RAORD
- +2 ; reset RAMDV to its original value!
- DO SAVE
- +3 IF $$ORVR^RAORDU()'<3
- IF (+$GET(RAPTLOCK))
- IF (+$GET(RADFN))
- Begin DoDot:1
- +4 DO ULK^RAUTL19(RADFN_";DPT(")
- End DoDot:1
- +5 if '$DATA(RAREGFLG)&('$DATA(RAVSTFLG))
- KILL RACAT,RADFN,RANME,RAWARD
- +6 IF '$DATA(RAPKG)
- KILL RAMDIV,RAMDV,RAMLC
- +7 IF $DATA(RAPKG)
- KILL ORIFN,ORIT,ORL,ORNP,ORNS,ORPCL,ORPK,ORPV,ORPURG,ORSTS,ORTX,ORVP,RAPKG
- +8 KILL RAHSMULT,RAPOP,RAIMAG,RAREAST,RAREQLOC
- +9 KILL C,DI,DIG,DIH,DISYS,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DN,I,ORCHART,POP,RAMDVZZ,RASCI,RASERIES
- +10 QUIT
- CREATE SET RACT=0
- DO MODS
- if $DATA(RAOUT)
- QUIT
- CREATE1 ;ask for the 'Date Desired' req'd P75
- +1 SET RAWHEN=$$DESDT^RAUTL12(RAPRI)
- if RAWHEN=-1
- SET RAOUT=1
- if $DATA(RAOUT)#2
- QUIT
- +2 ;convert to external format
- SET RAWHEN=$$FMTE^XLFDT(RAWHEN,1)
- +3 ; Ask pregnant if age is between 12 & 55. Ask once for mult requests
- +4 ; RASKPREG is the variable used to track if the pregnant prompt has
- +5 ; been asked. Ask only once for multiple requests.
- +6 if '$DATA(RASKPREG)
- SET RAPREG=$$PREG^RAORD1A(RADFN,$GET(DT))
- SET RASKPREG=""
- if $DATA(RAOUT)
- QUIT
- +7 ;Reason for Study (req'd) & Clinical History (optional) asked in CH^RAUTL5 P75
- +8 ;RAOUT: defined if Reason for Study is nonexistent
- DO CH^RAUTL5
- if $DATA(RAOUT)
- QUIT
- BAQUES ;*Billing Awareness Project
- +1 ; Ask Ordering ICD-9 Diagnosis and Related SC/EI/MST/HNC questions.
- +2 NEW RADTM
- DO NOW^%DTC
- SET RADTM=%
- +3 DO ASK^RABWORD(RADFN,RADTM)
- +4 ; Display Order Responses.
- IF '$DATA(RADR1)
- DO DISP^RAORDU1
- if $DATA(RAOUT)
- QUIT
- +5 SET X=RADFN
- SET DIC="^RAO(75.1,"
- SET DIC(0)="L"
- SET DLAYGO=75.1
- +6 DO FILE^DICN
- KILL DIC
- if Y<0
- QUIT
- SET RAOIFN=+Y
- KILL DLAYGO
- +7 IF $DATA(RAREGFLG)!($DATA(RAVSTFLG))
- SET RANUM=$SELECT('$DATA(RANUM):1,1:RANUM+1)
- SET RAORDS(RANUM)=RAOIFN
- +8 IF $DATA(^RA(79,+RADIV,.1))
- IF $PIECE(^(.1),"^",21)="y"
- SET RALOCFLG=""
- +9 WRITE !
- SET DA=RAOIFN
- SET DIE="^RAO(75.1,"
- SET DIE("NO^")="OUTOK"
- +10 SET DR=$SELECT($DATA(RADR1):"[RA QUICK EXAM ORDER]",$DATA(RADR2):"[RA ORDER EXAM]",$DATA(RAEXMUL)&($DATA(RAFIN1)):"[RA QUICK EXAM ORDER]",1:"[RA ORDER EXAM]")
- +11 ;*Billing Awareness Project
- +12 ; If Order questions are being Re-Asked then Re-Ask ICD-9 Dx questions
- +13 IF DR="[RA ORDER EXAM]"
- DO ASK^RABWORD(RADFN,RADTM)
- WRITE !!
- +14 DO ^DIE
- +15 KILL DIE("NO^"),DE,DQ,DIE,DR,RADR1,RADR2
- +16 IF $DATA(RAFIN)
- IF $DATA(^RAO(75.1,RAOIFN,0))
- SET RAORD0=^(0)
- DO FILEDX^RABWORD(RADFN,RAOIFN)
- if '$DATA(RAFIN)
- QUIT
- DO SETORD^RAORDU
- if '$DATA(RAPKG)
- DO OERR^RAORDU
- if $DATA(RAPKG)
- DO ^RAORDQ
- KILL RAORD0
- +17 IF '$DATA(RAFIN)
- WRITE !?3,$CHAR(7),"Request not complete. Must Delete..."
- SET DA=RAOIFN
- SET DIK="^RAO(75.1,"
- DO ^DIK
- WRITE "...deletion complete!"
- IF $DATA(RAREGFLG)!($DATA(RAVSTFLG))
- KILL RAORDS(RANUM)
- +18 ; record deleted!
- IF '$DATA(RAFIN)
- IF ('$DATA(^RAO(75.1,RAOIFN,0))#2)
- QUIT
- +19 KILL RAFIN
- +20 ; check if the 'stat' or 'urgent' alert is to be sent.
- +21 NEW RALOC,RAORD0
- +22 SET RAORD0=$GET(^RAO(75.1,RAOIFN,0))
- SET RALOC=+$PIECE(RAORD0,"^",20)
- +23 ; if no 'SUBMIT TO' location, can't send stat/urgent alerts
- if 'RALOC
- QUIT
- +24 IF $PIECE(RAORD0,"^",6)=1!(($PIECE(RAORD0,"^",6)=2)&($PIECE(^RA(79.1,RALOC,0),"^",20)="Y"))
- Begin DoDot:1
- +25 ; If 6th piece of RAORD0=1 *stat*, =2 *urgent*
- +26 if $$ORVR^RAORDU()<3
- QUIT
- +27 ; needs OE/RR 3.0 or greater for stat/urgent alerts to fire
- +28 DO OENO^RAUTL19(RAOIFN)
- +29 QUIT
- End DoDot:1
- +30 QUIT
- +31 ;
- MODS ;RAPRI= Procedure IEN, RAIMAG=Imaging Type for the procedure.
- +1 ;Edited 4/19/94, Type of Imaging is now a multiple in file 71.2. CEW
- +2 SET RAIMAG=+$$ITYPE^RASITE(RAPRI)
- SET DIC(0)="AEQMZ"
- SET DIC="^RAMIS(71.2,"
- SET DIC("A")="Select "_$PIECE($GET(^DIC(71.2,0)),"^")_": "
- +3 SET DIC("S")="I +$D(^RAMIS(71.2,""AB"",RAIMAG,+Y)),$S('$G(RASERIES):1,$P(^RAMIS(71.2,+Y,0),U,2)="""":1,1:0),$$INIMOD^RAORD1A($P($G(^RAMIS(71.2,+Y,0)),""^""))"
- +4 DO ^DIC
- KILL DIC,RAIMAG
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET RAOUT=1
- if $DATA(RAOUT)!(X="^")!(X="")
- QUIT
- IF Y<1
- WRITE $CHAR(7)," ??"
- GOTO MODS
- +5 SET RACT=RACT+1
- SET RAMOD(RACT)=$PIECE(Y,"^",2)
- GOTO MODS
- +6 QUIT
- +7 ;
- ALLERGY ; If patient has had a previous contrast media allergic reaction
- +1 ; check procedure RAPRI for specific contrast media associations
- +2 ; (new with RA*5*45)
- +3 if '$$ORCHK^GMRAOR(RADFN,"CM")
- QUIT
- +4 SET RAPRI(0)=$GET(^RAMIS(71,RAPRI,0))
- +5 ;not a parent check lone procedure
- IF $PIECE(RAPRI(0),U,6)'="P"
- Begin DoDot:1
- +6 DO CONTRAST^RAUTL2(RAPRI)
- +7 QUIT
- End DoDot:1
- +8 ;check descendent procedures for CM
- IF '$TEST
- SET I=0
- Begin DoDot:1
- +9 FOR
- SET I=$ORDER(^RAMIS(71,RAPRI,4,I))
- if 'I
- QUIT
- DO CONTRAST^RAUTL2(+$GET(^(I,0)))
- +10 KILL I
- +11 QUIT
- End DoDot:1
- +12 KILL RAPRI(0)
- +13 QUIT
- SAVE ; Save original value of RAMDV before it is altered in the ENADD sub-
- +1 ; routine. This code will also reset RAMDV to the sign-on value.
- +2 ; entered through OE/RR (RAMDV will not be set)
- if '$DATA(RAPKG)
- QUIT
- +3 ;entered through 'Request an Exam' option used stand-alone outside of Rad/NM pkg
- if '$DATA(RAMDV)&('$DATA(RAMDVZZ))
- QUIT
- +4 IF '$DATA(RAMDVZZ)
- SET RAMDVZZ=RAMDV
- +5 IF '$TEST
- SET RAMDV=RAMDVZZ
- +6 QUIT