RAORDR1 ;ABV/SCR/MKN - Refer Pending/Hold Requests continued ; Jul 08, 2022@10:36:51
;;5.0;Radiology/Nuclear Medicine;**148,161,170,190**;Mar 16, 1998;Build 1
;
; Routine/File IA Type
; -------------------------------------
; DEM^VADPT 10061 (S)
; GETDLG^ORCD 5493 (C)
; SAVE^ORWDX NONE
; SEND^ORWDX 5656 (C)
; VALID^ORWDXA NONE
; ^OR(100 5771,6475 (C)
; 101.41 NONE
; 101.42 2698 (C)
; 101.43 2843 (C)
; 100.98 3004 (C)
;
Q
;
MAKECONS(RAOIFN) ;Create Consult using Order Dialog GMRCOR CONSULT
;RAOIFN is the IEN in file #75.1
;
N DA,DFN,DIC,DIE,DR,ORDIALOG,RADFN,RADLG,RADTDES,RAFIELDS,RAFILE,RAIENS,RAMAP,RAN,RAN1,RANEWORD,RAO,RAOIEN,RAORDG
N RAORDIEN,RAORDITM,RAORDLOC,RAORDS,RAORDTXT,RAOREA,RAORGTX,RAORNP,RAORIT,RAORL,RAORNP,RAORPRE,RAORPREG,RAORTYP
N RAORVP,RAORWANT,RAQUIT,RAORD,RARET,RARTRN,RAUCID,RAURG,RAWPN,RAX,RAY,RAOILOC,VADM,X,Y,RAITYP
S RADLG="GMRCOR CONSULT"
K DIC S DIC=101.41,X=RADLG D ^DIC I Y=-1 D ERROR("Quick Order ""GMRCOR CONSULT"" not found in ORDER DIALOG file") Q 0
S RAORIT=+Y
D GETDLG^ORCD(RAORIT)
I $$CHECKDLG=1 D ERROR("Order dialog missing essential items") Q 0
;Now set up the input parameters for ORWDX SAVE
S RAFILE=75.1 ;RAD\NUC MED ORDER
S RAIENS=RAOIFN_","
S RAFIELDS=".01;2;3;7;12;13;14;20;21;22;" ; ALL FIELDS
D GETS^DIQ(RAFILE,RAIENS,RAFIELDS,"IE","RARTRN","RAERR")
S (RADFN,DFN,RAORVP)=$G(RARTRN(75.1,RAIENS,.01,"I")) ;Patient DFN P2
S (RAORDIEN,RAORD)=$G(RARTRN(75.1,RAIENS,7,"I")) ;RAD Order IEN P100
S RAORTYP=$G(RARTRN(75.1,RAIENS,3,"E")) ;Type of imaging P79.2
S RAITYP=$G(RARTRN(75.1,RAIENS,3,"I")) ;Type of imaging p79.2 (internal)
S RAOILOC=$G(RARTRN(75.1,RAIENS,20,"I")) ;p161 - Imaging Location p79.1
S RAORPRE=$G(RARTRN(75.1,RAIENS,12,"E")) ;PRE-OP DATE/TIME
S RAORPREG=$G(RARTRN(75.1,RAIENS,13,"E")) ;PREGNANT - set of codes Y,N,U
S RAORNP=$G(RARTRN(75.1,RAIENS,14,"I")) ;Ordering Provider P200
S (RADTDES,RAORWANT)=$G(RARTRN(75.1,RAIENS,21,"E")) ;Date Desired for consult
S RAORL=$G(RARTRN(75.1,RAIENS,22,"I"))
S RAORDLOC=$G(RARTRN(75.1,RAIENS,22,"E")) ;Ordering Location P44
K DIC S DIC=100.98,X="CONSULTS" D ^DIC I Y=-1 D ERROR("Quick Order ""CONSULTS"" display group not found") Q 0
S RAORDG=+Y
;Now add the responses to the dialog
;p161 start
;Use I-LOC from order to lookup CCC in 79.1
;P170 - It's possible for the order to not have a 'submit to' location, in which case we'll try to
;determine a location based on imaging type and user's division.
I $G(RAOILOC)="" S RAOILOC=$$GETILOC^RAORDR2(RAITYP)
I $G(RAOILOC)=0 D ERROR("No Imaging location found/selected") Q 0
;if the I-LOC doesn't have a CCC
I '$O(^RA(79.1,RAOILOC,"CON",0)) S RAOILOC=$$GETILOC^RAORDR2(RAITYP) ;no CCC on order location
I $G(RAOILOC)=0 D ERROR("No Consult title associated with I-LOC") Q 0
;p170 end
;
I $D(^RA(79.1,RAOILOC,"CON")) D
.I RAORTYP["MAMMOGRAPHY" S RAMAP=$$MAMMO() Q
.S RAI=$O(^RA(79.1,RAOILOC,"CON",0)) S RAMAP=$$GET1^DIQ(79.11,RAI_","_RAOILOC_",",.01)
.Q
I $G(RAMAP)=0 Q 0
I $G(RAMAP)="" D ERROR("No Consult title associated with I-LOC") Q 0
;p170 - change next line to FIND^DIC to allow for partial matches
;S RAORDITM=$$FIND1^DIC(101.43,,,RAMAP) I RAORDITM=0 D ERROR("Orderable Item "_RAMAP_" not found in Orderable item file") Q 0
D FIND^DIC(101.43,,"@;.01","P",RAMAP,,,,,"RAOI",) I $D(RAOI)=10 D
.N RAJ S RAJ=0 F S RAJ=$O(RAOI("DILIST",RAJ)) Q:RAJ="" D
..I $P($G(RAOI("DILIST",RAJ,0)),U,2)=RAMAP S RAORDITM=+$G(RAOI("DILIST",RAJ,0))
..Q
.Q
I $G(RAORDITM)'>0 D ERROR("Orderable Item "_RAMAP_" not found in Orderable item file") Q 0
;p161 end
D UPORDLG("OR GTX ORDERABLE ITEM",RAORDITM)
K DIC S DIC=101.42,X="ROUTINE" D ^DIC I Y=-1 D ERROR("Urgency ""ROUTINE"" not found in ORDER URGENCY file") Q 0
S RAURG=+Y
D UPORDLG("OR GTX URGENCY",RAURG)
D UPORDLG("OR GTX CATEGORY","O") ;Outpatient
D UPORDLG("OR GTX PLACE OF CONSULTATION","C") ;"Consultant's Choice"
D UPORDLG("OR GTX PROVIDER","") ;Attention field not known
;
D GETS^DIQ(100,RAORDIEN_",",".8*","IE","RAO")
S RAORDTXT=$G(RAO(100.008,"1,"_RAORDIEN_",",.1,1))
I RAORDTXT="" D ERROR("Order Text not found in ORDER file at IEN "_RAORDIEN) Q 0
D UPORDLG("OR GTX FREE TEXT","Encounter for other specified special examinations")
D UPORDLG("OR GTX CODE","Z01.89") ;p161 - Add Provisional DX Code
D UPORDLG("OR GTX CLINICALLY INDICATED DATE",RADTDES)
S ORDIALOG("ORCHECK")=0 ;No Order Checks
S ORDIALOG("ORTS")=0
;Set up Reason For Study in ORDIALOG
S RAWPN=RAORGTX("OR GTX WORD PROCESSING 1")
S ORDIALOG(RAWPN_",1")="ORDIALOG(""WP"",15,1)"
D GETREAS^RAORDR2 Q:RAQUIT 0
;Clean up ORDIALOG to leave only answers
S RAN="" F S RAN=$O(ORDIALOG(RAN)) Q:RAN="" D
.M:RAN="WP" RANEWORD(RAN)=ORDIALOG(RAN) I RAN'="WP",RAN'="ORCHECK",RAN'="ORTS" S RAN1="" D
..F S RAN1=$O(ORDIALOG(RAN,RAN1)) Q:RAN1="" S:RAN1=1 RANEWORD(RAN,RAN1)=ORDIALOG(RAN,RAN1)
S RAX=$O(ORDIALOG("WP","")) I RAX]"" S RANEWORD(RAX,1)="ORDIALOG(""WP"","_RAX_",1)"
K ORDIALOG M ORDIALOG=RANEWORD
;Create Consult Order
L +^XTMP("ORPTLK-"_RADFN):5 I '$T D ERROR("Another person is editing orders for this patient.") Q 0 ;p161 -Lock Patient (CPRS)
D SAVE^ORWDX(.RARET,RAORVP,RAORNP,RAORL,RADLG,RAORDG,RAORIT,"",.ORDIALOG,"","","",0)
L -^XTMP("ORPTLK-"_RADFN) ;Unlock patient
S RAORDIEN=0,RAX=$G(RARET(1)) I RAX]"" S RAORDIEN=$P($P($P(RAX,U),"~",2),";")
I 'RAORDIEN Q 0
L +^OR(100,+RAORDIEN):5 I '$T D ERROR("Another person is working on this order.") Q 0 ;p161 -Lock order (CPRS)
D VALID^ORWDXA(.RAO,RAORDIEN,"OC",DUZ) ;Signature on chart
K RAORDS S RAORDS(1)=RAORDIEN_";1^0^1^W"
D SEND^ORWDX(.RAO,RAORVP,RAORNP,RAORL," ",.RAORDS)
;Set Signature Status to "Electronic" and Reason to ADMINISTRATIVELY RELEASED BY POLICY
S DA(1)=RAORDIEN,DA=1,DIE="^OR(100,"_RAORDIEN_",8,"
S DR="4///1;1///ADMINISTRATIVELY RELEASED BY POLICY;7///@"
D ^DIE
L -^OR(100,+RAORDIEN) ;unlock order
;
;Put Radiology order on hold
S RAX=$O(^RA(75.2,"B","COMMUNITY CARE APPT","")) D HOLD(RAOIFN,.RAX)
;Now add comment to show UCID if it exists - p161/Need to remove!
S RAX=$G(^OR(100,RAORDIEN,4)) I $P(RAX,";",2)="GMRC" D
.S RAX=+RAX,RAUCID=$$GET1^DIQ(123,RAX,80)
.I RAUCID]"" S RAX="Placed on hold due to transfer to Community Care with UCID "_RAUCID D
..;RADORD is IEN of original radiology order in file #100
..S DA(1)=RAORD,DIE="^OR(100,"_RAORD_",8,",DA=$O(^OR(100,RAORD,8,"A"),-1) I DA S DR="1///"_RAX D ^DIE
;
Q RAORDIEN
;
HOLD(RAOIFN,RAOREA) ;Put the original radiology order on hold
N RAOSTS
S RAOSTS=3 D ^RAORDU
Q
;
USRPRMT() ;Prompt for consult/request service -p161 REMOVE!
N DIR,Y,DIRUT S DIR(0)="P^RA(79.1,RAOILOC,""CON"",:QEZ" D ^DIR I $D(DIRUT) Q ""
S RAMAP=$G(Y(0,0))
Q RAMAP
;
CHECKDLG() ;
N RAI,RARES,RAX,RAY,X,Y
S RARES=0 F RAI=1:1 S RAX=$P($T(DLGLST+RAI),";",2) Q:RAX="//" D
.K DIC S DIC=101.41,X=RAX D ^DIC I Y=-1 D ERROR("Order Dialog "_RAX_" not found") S RARES=1
.S RAY=+Y
.I '$D(ORDIALOG(RAY)) D ERROR("Order Dialog "_RAX_" not found") S RARES=1
.S RAORGTX(RAX)=RAY
Q RARES
;
UPORDLG(RADLGNA,RADATA) ;Stuff answer into Order Dialog array ORDIALOG
N RAX
S RAX=$G(RAORGTX(RADLGNA)),ORDIALOG(RAX,1)=RADATA
Q
;
DLGLST ;
;OR GTX ORDERABLE ITEM
;OR GTX URGENCY
;OR GTX CATEGORY
;OR GTX WORD PROCESSING 1
;OR GTX PROVIDER
;OR GTX FREE TEXT
;OR GTX PLACE OF CONSULTATION
;OR GTX CODE
;OR GTX FREE TEXT OI
;OR GTX CLINICALLY INDICATED DATE
;//
ERROR(RAERR) ;
W !!,RAERR
Q
;
GETDIAG(RAORDIEN) ;RETURN POINTER TO #80 FROM ORDER ENTRY
;
N RADIAG,RAFILE,RAFLD,RAERR,RAIENS
S RAFILE=100.051 ;DIAGNOSIS SUB-FILE
S RAIENS=1_","_RAORDIEN_","
S RAFLD=.01
S RADIAG=$$GET1^DIQ(RAFILE,RAIENS,RAFLD,"I",,"RAERR") ;If there is no entry for DX in 5.1, -1 returns in piece 1
I $D(RAERR) S RADIAG="-1^"_RAERR("DIERR",1,"TEXT",1)
Q RADIAG
;
MAMMO() ;
N RARES,DIR,DIRUT,RAI,RATOM,RAMAM,Y
W !!,"Please select the type of Mammography order from the following options:"
S DIR(0)="S^1:Diagnostic Mammography;2:Screen Mammography"
D ^DIR
I $D(DIRUT) S RARES=0 Q 0
S RAARAY("TYPEOFSERVICE")=$S(Y=1:"4^Diagnostic",1:"4^Screen")
S RATOM=$S(+Y=2:"SCREEN",1:"DIAGNOSTIC"),RAMAP=""
S RAI=0 F S RAI=$O(^RA(79.1,RAOILOC,"CON",RAI)) Q:RAI="" D
.S RAMAM=$$GET1^DIQ(79.11,RAI_","_RAOILOC_",",.01) I RAMAM[RATOM S RAMAP=RAMAM
.Q
Q $G(RAMAP)
;
MAP(RAIN) ;
N RAI,RARES,RAX
S RARES=""
F RAI=1:1 S RAX=$T(ORDITEMS+RAI) Q:RAX=" ;//" I $P(RAX,";",2)=RAIN S RARES=$P(RAX,";",3) Q
Q RARES
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDR1 8768 printed Jan 19, 2023@22:10:58 Page 2
RAORDR1 ;ABV/SCR/MKN - Refer Pending/Hold Requests continued ; Jul 08, 2022@10:36:51
+1 ;;5.0;Radiology/Nuclear Medicine;**148,161,170,190**;Mar 16, 1998;Build 1
+2 ;
+3 ; Routine/File IA Type
+4 ; -------------------------------------
+5 ; DEM^VADPT 10061 (S)
+6 ; GETDLG^ORCD 5493 (C)
+7 ; SAVE^ORWDX NONE
+8 ; SEND^ORWDX 5656 (C)
+9 ; VALID^ORWDXA NONE
+10 ; ^OR(100 5771,6475 (C)
+11 ; 101.41 NONE
+12 ; 101.42 2698 (C)
+13 ; 101.43 2843 (C)
+14 ; 100.98 3004 (C)
+15 ;
+16 QUIT
+17 ;
MAKECONS(RAOIFN) ;Create Consult using Order Dialog GMRCOR CONSULT
+1 ;RAOIFN is the IEN in file #75.1
+2 ;
+3 NEW DA,DFN,DIC,DIE,DR,ORDIALOG,RADFN,RADLG,RADTDES,RAFIELDS,RAFILE,RAIENS,RAMAP,RAN,RAN1,RANEWORD,RAO,RAOIEN,RAORDG
+4 NEW RAORDIEN,RAORDITM,RAORDLOC,RAORDS,RAORDTXT,RAOREA,RAORGTX,RAORNP,RAORIT,RAORL,RAORNP,RAORPRE,RAORPREG,RAORTYP
+5 NEW RAORVP,RAORWANT,RAQUIT,RAORD,RARET,RARTRN,RAUCID,RAURG,RAWPN,RAX,RAY,RAOILOC,VADM,X,Y,RAITYP
+6 SET RADLG="GMRCOR CONSULT"
+7 KILL DIC
SET DIC=101.41
SET X=RADLG
DO ^DIC
IF Y=-1
DO ERROR("Quick Order ""GMRCOR CONSULT"" not found in ORDER DIALOG file")
QUIT 0
+8 SET RAORIT=+Y
+9 DO GETDLG^ORCD(RAORIT)
+10 IF $$CHECKDLG=1
DO ERROR("Order dialog missing essential items")
QUIT 0
+11 ;Now set up the input parameters for ORWDX SAVE
+12 ;RAD\NUC MED ORDER
SET RAFILE=75.1
+13 SET RAIENS=RAOIFN_","
+14 ; ALL FIELDS
SET RAFIELDS=".01;2;3;7;12;13;14;20;21;22;"
+15 DO GETS^DIQ(RAFILE,RAIENS,RAFIELDS,"IE","RARTRN","RAERR")
+16 ;Patient DFN P2
SET (RADFN,DFN,RAORVP)=$GET(RARTRN(75.1,RAIENS,.01,"I"))
+17 ;RAD Order IEN P100
SET (RAORDIEN,RAORD)=$GET(RARTRN(75.1,RAIENS,7,"I"))
+18 ;Type of imaging P79.2
SET RAORTYP=$GET(RARTRN(75.1,RAIENS,3,"E"))
+19 ;Type of imaging p79.2 (internal)
SET RAITYP=$GET(RARTRN(75.1,RAIENS,3,"I"))
+20 ;p161 - Imaging Location p79.1
SET RAOILOC=$GET(RARTRN(75.1,RAIENS,20,"I"))
+21 ;PRE-OP DATE/TIME
SET RAORPRE=$GET(RARTRN(75.1,RAIENS,12,"E"))
+22 ;PREGNANT - set of codes Y,N,U
SET RAORPREG=$GET(RARTRN(75.1,RAIENS,13,"E"))
+23 ;Ordering Provider P200
SET RAORNP=$GET(RARTRN(75.1,RAIENS,14,"I"))
+24 ;Date Desired for consult
SET (RADTDES,RAORWANT)=$GET(RARTRN(75.1,RAIENS,21,"E"))
+25 SET RAORL=$GET(RARTRN(75.1,RAIENS,22,"I"))
+26 ;Ordering Location P44
SET RAORDLOC=$GET(RARTRN(75.1,RAIENS,22,"E"))
+27 KILL DIC
SET DIC=100.98
SET X="CONSULTS"
DO ^DIC
IF Y=-1
DO ERROR("Quick Order ""CONSULTS"" display group not found")
QUIT 0
+28 SET RAORDG=+Y
+29 ;Now add the responses to the dialog
+30 ;p161 start
+31 ;Use I-LOC from order to lookup CCC in 79.1
+32 ;P170 - It's possible for the order to not have a 'submit to' location, in which case we'll try to
+33 ;determine a location based on imaging type and user's division.
+34 IF $GET(RAOILOC)=""
SET RAOILOC=$$GETILOC^RAORDR2(RAITYP)
+35 IF $GET(RAOILOC)=0
DO ERROR("No Imaging location found/selected")
QUIT 0
+36 ;if the I-LOC doesn't have a CCC
+37 ;no CCC on order location
IF '$ORDER(^RA(79.1,RAOILOC,"CON",0))
SET RAOILOC=$$GETILOC^RAORDR2(RAITYP)
+38 IF $GET(RAOILOC)=0
DO ERROR("No Consult title associated with I-LOC")
QUIT 0
+39 ;p170 end
+40 ;
+41 IF $DATA(^RA(79.1,RAOILOC,"CON"))
Begin DoDot:1
+42 IF RAORTYP["MAMMOGRAPHY"
SET RAMAP=$$MAMMO()
QUIT
+43 SET RAI=$ORDER(^RA(79.1,RAOILOC,"CON",0))
SET RAMAP=$$GET1^DIQ(79.11,RAI_","_RAOILOC_",",.01)
+44 QUIT
End DoDot:1
+45 IF $GET(RAMAP)=0
QUIT 0
+46 IF $GET(RAMAP)=""
DO ERROR("No Consult title associated with I-LOC")
QUIT 0
+47 ;p170 - change next line to FIND^DIC to allow for partial matches
+48 ;S RAORDITM=$$FIND1^DIC(101.43,,,RAMAP) I RAORDITM=0 D ERROR("Orderable Item "_RAMAP_" not found in Orderable item file") Q 0
+49 DO FIND^DIC(101.43,,"@;.01","P",RAMAP,,,,,"RAOI",)
IF $DATA(RAOI)=10
Begin DoDot:1
+50 NEW RAJ
SET RAJ=0
FOR
SET RAJ=$ORDER(RAOI("DILIST",RAJ))
if RAJ=""
QUIT
Begin DoDot:2
+51 IF $PIECE($GET(RAOI("DILIST",RAJ,0)),U,2)=RAMAP
SET RAORDITM=+$GET(RAOI("DILIST",RAJ,0))
+52 QUIT
End DoDot:2
+53 QUIT
End DoDot:1
+54 IF $GET(RAORDITM)'>0
DO ERROR("Orderable Item "_RAMAP_" not found in Orderable item file")
QUIT 0
+55 ;p161 end
+56 DO UPORDLG("OR GTX ORDERABLE ITEM",RAORDITM)
+57 KILL DIC
SET DIC=101.42
SET X="ROUTINE"
DO ^DIC
IF Y=-1
DO ERROR("Urgency ""ROUTINE"" not found in ORDER URGENCY file")
QUIT 0
+58 SET RAURG=+Y
+59 DO UPORDLG("OR GTX URGENCY",RAURG)
+60 ;Outpatient
DO UPORDLG("OR GTX CATEGORY","O")
+61 ;"Consultant's Choice"
DO UPORDLG("OR GTX PLACE OF CONSULTATION","C")
+62 ;Attention field not known
DO UPORDLG("OR GTX PROVIDER","")
+63 ;
+64 DO GETS^DIQ(100,RAORDIEN_",",".8*","IE","RAO")
+65 SET RAORDTXT=$GET(RAO(100.008,"1,"_RAORDIEN_",",.1,1))
+66 IF RAORDTXT=""
DO ERROR("Order Text not found in ORDER file at IEN "_RAORDIEN)
QUIT 0
+67 DO UPORDLG("OR GTX FREE TEXT","Encounter for other specified special examinations")
+68 ;p161 - Add Provisional DX Code
DO UPORDLG("OR GTX CODE","Z01.89")
+69 DO UPORDLG("OR GTX CLINICALLY INDICATED DATE",RADTDES)
+70 ;No Order Checks
SET ORDIALOG("ORCHECK")=0
+71 SET ORDIALOG("ORTS")=0
+72 ;Set up Reason For Study in ORDIALOG
+73 SET RAWPN=RAORGTX("OR GTX WORD PROCESSING 1")
+74 SET ORDIALOG(RAWPN_",1")="ORDIALOG(""WP"",15,1)"
+75 DO GETREAS^RAORDR2
if RAQUIT
QUIT 0
+76 ;Clean up ORDIALOG to leave only answers
+77 SET RAN=""
FOR
SET RAN=$ORDER(ORDIALOG(RAN))
if RAN=""
QUIT
Begin DoDot:1
+78 if RAN="WP"
MERGE RANEWORD(RAN)=ORDIALOG(RAN)
IF RAN'="WP"
IF RAN'="ORCHECK"
IF RAN'="ORTS"
SET RAN1=""
Begin DoDot:2
+79 FOR
SET RAN1=$ORDER(ORDIALOG(RAN,RAN1))
if RAN1=""
QUIT
if RAN1=1
SET RANEWORD(RAN,RAN1)=ORDIALOG(RAN,RAN1)
End DoDot:2
End DoDot:1
+80 SET RAX=$ORDER(ORDIALOG("WP",""))
IF RAX]""
SET RANEWORD(RAX,1)="ORDIALOG(""WP"","_RAX_",1)"
+81 KILL ORDIALOG
MERGE ORDIALOG=RANEWORD
+82 ;Create Consult Order
+83 ;p161 -Lock Patient (CPRS)
LOCK +^XTMP("ORPTLK-"_RADFN):5
IF '$TEST
DO ERROR("Another person is editing orders for this patient.")
QUIT 0
+84 DO SAVE^ORWDX(.RARET,RAORVP,RAORNP,RAORL,RADLG,RAORDG,RAORIT,"",.ORDIALOG,"","","",0)
+85 ;Unlock patient
LOCK -^XTMP("ORPTLK-"_RADFN)
+86 SET RAORDIEN=0
SET RAX=$GET(RARET(1))
IF RAX]""
SET RAORDIEN=$PIECE($PIECE($PIECE(RAX,U),"~",2),";")
+87 IF 'RAORDIEN
QUIT 0
+88 ;p161 -Lock order (CPRS)
LOCK +^OR(100,+RAORDIEN):5
IF '$TEST
DO ERROR("Another person is working on this order.")
QUIT 0
+89 ;Signature on chart
DO VALID^ORWDXA(.RAO,RAORDIEN,"OC",DUZ)
+90 KILL RAORDS
SET RAORDS(1)=RAORDIEN_";1^0^1^W"
+91 DO SEND^ORWDX(.RAO,RAORVP,RAORNP,RAORL," ",.RAORDS)
+92 ;Set Signature Status to "Electronic" and Reason to ADMINISTRATIVELY RELEASED BY POLICY
+93 SET DA(1)=RAORDIEN
SET DA=1
SET DIE="^OR(100,"_RAORDIEN_",8,"
+94 SET DR="4///1;1///ADMINISTRATIVELY RELEASED BY POLICY;7///@"
+95 DO ^DIE
+96 ;unlock order
LOCK -^OR(100,+RAORDIEN)
+97 ;
+98 ;Put Radiology order on hold
+99 SET RAX=$ORDER(^RA(75.2,"B","COMMUNITY CARE APPT",""))
DO HOLD(RAOIFN,.RAX)
+100 ;Now add comment to show UCID if it exists - p161/Need to remove!
+101 SET RAX=$GET(^OR(100,RAORDIEN,4))
IF $PIECE(RAX,";",2)="GMRC"
Begin DoDot:1
+102 SET RAX=+RAX
SET RAUCID=$$GET1^DIQ(123,RAX,80)
+103 IF RAUCID]""
SET RAX="Placed on hold due to transfer to Community Care with UCID "_RAUCID
Begin DoDot:2
+104 ;RADORD is IEN of original radiology order in file #100
+105 SET DA(1)=RAORD
SET DIE="^OR(100,"_RAORD_",8,"
SET DA=$ORDER(^OR(100,RAORD,8,"A"),-1)
IF DA
SET DR="1///"_RAX
DO ^DIE
End DoDot:2
End DoDot:1
+106 ;
+107 QUIT RAORDIEN
+108 ;
HOLD(RAOIFN,RAOREA) ;Put the original radiology order on hold
+1 NEW RAOSTS
+2 SET RAOSTS=3
DO ^RAORDU
+3 QUIT
+4 ;
USRPRMT() ;Prompt for consult/request service -p161 REMOVE!
+1 NEW DIR,Y,DIRUT
SET DIR(0)="P^RA(79.1,RAOILOC,""CON"",:QEZ"
DO ^DIR
IF $DATA(DIRUT)
QUIT ""
+2 SET RAMAP=$GET(Y(0,0))
+3 QUIT RAMAP
+4 ;
CHECKDLG() ;
+1 NEW RAI,RARES,RAX,RAY,X,Y
+2 SET RARES=0
FOR RAI=1:1
SET RAX=$PIECE($TEXT(DLGLST+RAI),";",2)
if RAX="//"
QUIT
Begin DoDot:1
+3 KILL DIC
SET DIC=101.41
SET X=RAX
DO ^DIC
IF Y=-1
DO ERROR("Order Dialog "_RAX_" not found")
SET RARES=1
+4 SET RAY=+Y
+5 IF '$DATA(ORDIALOG(RAY))
DO ERROR("Order Dialog "_RAX_" not found")
SET RARES=1
+6 SET RAORGTX(RAX)=RAY
End DoDot:1
+7 QUIT RARES
+8 ;
UPORDLG(RADLGNA,RADATA) ;Stuff answer into Order Dialog array ORDIALOG
+1 NEW RAX
+2 SET RAX=$GET(RAORGTX(RADLGNA))
SET ORDIALOG(RAX,1)=RADATA
+3 QUIT
+4 ;
DLGLST ;
+1 ;OR GTX ORDERABLE ITEM
+2 ;OR GTX URGENCY
+3 ;OR GTX CATEGORY
+4 ;OR GTX WORD PROCESSING 1
+5 ;OR GTX PROVIDER
+6 ;OR GTX FREE TEXT
+7 ;OR GTX PLACE OF CONSULTATION
+8 ;OR GTX CODE
+9 ;OR GTX FREE TEXT OI
+10 ;OR GTX CLINICALLY INDICATED DATE
+11 ;//
ERROR(RAERR) ;
+1 WRITE !!,RAERR
+2 QUIT
+3 ;
GETDIAG(RAORDIEN) ;RETURN POINTER TO #80 FROM ORDER ENTRY
+1 ;
+2 NEW RADIAG,RAFILE,RAFLD,RAERR,RAIENS
+3 ;DIAGNOSIS SUB-FILE
SET RAFILE=100.051
+4 SET RAIENS=1_","_RAORDIEN_","
+5 SET RAFLD=.01
+6 ;If there is no entry for DX in 5.1, -1 returns in piece 1
SET RADIAG=$$GET1^DIQ(RAFILE,RAIENS,RAFLD,"I",,"RAERR")
+7 IF $DATA(RAERR)
SET RADIAG="-1^"_RAERR("DIERR",1,"TEXT",1)
+8 QUIT RADIAG
+9 ;
MAMMO() ;
+1 NEW RARES,DIR,DIRUT,RAI,RATOM,RAMAM,Y
+2 WRITE !!,"Please select the type of Mammography order from the following options:"
+3 SET DIR(0)="S^1:Diagnostic Mammography;2:Screen Mammography"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
SET RARES=0
QUIT 0
+6 SET RAARAY("TYPEOFSERVICE")=$SELECT(Y=1:"4^Diagnostic",1:"4^Screen")
+7 SET RATOM=$SELECT(+Y=2:"SCREEN",1:"DIAGNOSTIC")
SET RAMAP=""
+8 SET RAI=0
FOR
SET RAI=$ORDER(^RA(79.1,RAOILOC,"CON",RAI))
if RAI=""
QUIT
Begin DoDot:1
+9 SET RAMAM=$$GET1^DIQ(79.11,RAI_","_RAOILOC_",",.01)
IF RAMAM[RATOM
SET RAMAP=RAMAM
+10 QUIT
End DoDot:1
+11 QUIT $GET(RAMAP)
+12 ;
MAP(RAIN) ;
+1 NEW RAI,RARES,RAX
+2 SET RARES=""
+3 FOR RAI=1:1
SET RAX=$TEXT(ORDITEMS+RAI)
if RAX=" ;//"
QUIT
IF $PIECE(RAX,";",2)=RAIN
SET RARES=$PIECE(RAX,";",3)
QUIT
+4 QUIT RARES
+5 ;
