MAGDHOWE ;WOIFO/PMK/JSJ - Clinical Specialty MWL & HL7 Editor ; Apr 27, 2022@11:43:08
;;3.0;IMAGING;**138,231,278**;Mar 19, 2002;Build 138
;; Per VA Directive 6402, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
;
; Supported IA #2053 reference UPDATE^DIE subroutine call
; Supported IA #10013 reference ^DIK subroutine call
; Supported IA #2056 reference $$GET1^DIQ function call
; Supported IA #2056 reference GETS^DIQ subroutine call
; Private IA #7095 to read GMRC PROCEDURE file (#123.3)
; Controlled IA #4171 to read REQUEST SERVICES file (#123.5)
; Supported IA #10026 reference ^DIR subroutine call
;
ENTRY ; entry point from menu
N CHANGE,CHOICE,CLINIC,CPT,HL7SUBLIST,IEN,IENS,IPROCIDX,ISPECIDX,LOCATION
N MSG,OPTION,PROCEDURE,PROMPT,SERVICE,QRSCP,X
N DIERR,IENS,MAGERR,MAGFDA,MAGIENS
S CHANGE=0 ; use for counting updates
S (MSG(1),MSG(3))=""
S MSG(2)=" CLINICAL SPECIALTY DICOM & HL7 file (#2006.5831) Editor"
W !! D HEADING^MAGDTRDX(.MSG)
W !!,"Add/Edit a Consult or a Procedure?"
S OPTION(1)="1:Consult"
S OPTION(2)="2:Procedure"
S OPTION(3)="3:Display the existing dictionary"
S OPTION(4)="4:Quit"
S PROMPT="Enter an option"
S X=$$CHOOSE(PROMPT,"",.CHOICE,.OPTION) Q:X<0
;
I CHOICE=4 Q
D CHOICE G ENTRY
Q
CHOICE ; option driver
I CHOICE=3 D WORKLIST^MAGDTRDX W !,"-- End of File --",!! Q
;
I CHOICE=1 D Q:X<0 ; add a consult (PROCEDURE=0)
. S X=$$CONSULT(.SERVICE,.PROCEDURE)
. Q
E D Q:X<0 ; add a procedure within a service
. S X=$$PROC(.PROCEDURE,.SERVICE)
. Q
S IEN=$$IREQUEST^MAGDHOW1(+SERVICE,+PROCEDURE)
I IEN D Q
. W !!,"An entry for the "
. I PROCEDURE="" W $P(SERVICE,"^",2)," consult"
. E D
. . W $P(PROCEDURE,"^",2)," procedure"
. . W !,"for the ",$P(SERVICE,"^",2)," service"
. . Q
. W !,"is already on file."
. D UPDATE(IEN)
. Q
;
S X=$$ISPECIDX(.ISPECIDX) Q:X<0
S X=$$IPROCIDX(.IPROCIDX) Q:X<0
S X=$$LOCATION(.LOCATION) Q:X<0
S X=$$CPT(.CPT) Q:X<0
S X=$$HL7SUBL(.HL7SUBLIST) Q:X<0
S X=$$QRSCP(.QRSCP) Q:X<0
S X=$$CLINIC(.CLINIC) Q:X<0
;
D DISPLAY
;
W !!
S X=$$YESNO("Create this entry","n",.CHOICE) Q:X<-1
I CHOICE'="YES" W " -- entry not created" Q
;
; create the entry
S IENS="+1,"
S MAGFDA(2006.5831,IENS,.01)=$P(SERVICE,"^",1) ; REQUEST SERVICE (-> 123.5)
S MAGFDA(2006.5831,IENS,2)=$P(PROCEDURE,"^",1) ; PROCEDURE (-> 123.3)
S MAGFDA(2006.5831,IENS,3)=$P(ISPECIDX,"^",1) ; SPECIALTY INDEX (-> 2005.84)
S MAGFDA(2006.5831,IENS,4)=$P(IPROCIDX,"^",1) ; PROCEDURE INDEX (-> 2005.85)
S MAGFDA(2006.5831,IENS,5)=$P(LOCATION,"^",1) ; LOCATION (-> 4)
S MAGFDA(2006.5831,IENS,6)=$P(CPT,"^",1) ; CPT (-> 81)
S MAGFDA(2006.5831,IENS,7)=$P(HL7SUBLIST,"^",1) ; HL7 HL0 SUBSCRIBER LIST (-> 779.4)
S MAGFDA(2006.5831,IENS,8)=$P(QRSCP,"^",1) ; Query/Retrieve Provider
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) W !!,"*** Entry NOT Created ***" Q
E W " -- entry created"
S IEN=MAGIENS(1)
; output the CLINIC
S I=0 F S I=$O(CLINIC(I)) Q:'I D
. N DIERR,MAGERR,MAGFDA,MAGIENS
. S MAGFDA(2006.58311,"+1,"_IEN_",",.01)=$P(CLINIC(I),"^",1)
. D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
. Q
;
Q
;
UPDATE(IEN) ; delete or update the consult or procedure
N CLINIC,CPT,HL7SUBLIST,I,IPROCIDX,ISPECIDX,LOCATION,PROCEDURE,SERVICE,X
S X=^MAG(2006.5831,IEN,0)
S SERVICE=$P(X,"^",1),PROCEDURE=$P(X,"^",2)
S SERVICE=SERVICE_"^"_$$GET1^DIQ(123.5,SERVICE,.01)
S PROCEDURE=PROCEDURE_"^"_$$GET1^DIQ(123.3,PROCEDURE,.01)
S ISPECIDX=$$GETVALUE(2005.84,$P(X,"^",3),".01;3")
S IPROCIDX=$$GETVALUE(2005.85,$P(X,"^",4),".01;3")
S LOCATION=$$GETVALUE(4,$P(X,"^",5),".01;99")
S CPT=$$GETVALUE(81,$P(X,"^",6),".01;2")
S HL7SUBLIST=$$GETVALUE(779.4,$P(X,"^",7),".01")
S QRSCP=$P(X,"^",8),QRSCP=QRSCP_"^"_QRSCP ; ien same as name
S I=0 F S I=$O(^MAG(2006.5831,IEN,1,I)) Q:'I D
. S CLINIC(I)=$$GETVALUE(44,^MAG(2006.5831,IEN,1,I,0),".01")
. Q
D DISPLAY
;
S X=$$YESNO("Change this entry","n",.CHOICE) Q:X<-1
I CHOICE'="YES" W " -- entry not changed" Q
W !
S X=$$YESNO("Delete the entire entry","n",.CHOICE) Q:X<-1
I CHOICE="YES" D Q ; delete the entire entry
. N DA,DIK
. S DIK="^MAG(2006.5831,",DA=IEN
. D ^DIK
. W " -- entry deleted"
. Q
W " -- entry not deleted"
;
D UPDATE1 ; update the entry
Q
;
UPDATE1 ; update a the consult or procedure
N DIERR,IENS,MAGERR,MAGFDA,MAGIENS,X
;
S X=$$ISPECIDX(.ISPECIDX) Q:X<0
S X=$$IPROCIDX(.IPROCIDX) Q:X<0
S X=$$LOCATION(.LOCATION) Q:X<0
S X=$$CPT(.CPT) Q:X<0
S X=$$HL7SUBL(.HL7SUBLIST) Q:X<0
S X=$$QRSCP(.QRSCP) Q:X<0
S X=$$CLINIC(.CLINIC) Q:X<0
;
I CHANGE=0 W !!,"No changes" Q
;
D DISPLAY
;
W !
S X=$$YESNO("Update this entry","n",.CHOICE) Q:X<-1
I CHOICE'="YES" W " -- entry not updated" Q
;
; update the entry
S IENS=IEN_","
S MAGFDA(2006.5831,IENS,3)=$P(ISPECIDX,"^",1) ; SPECIALTY INDEX (-> 2005.84)
S MAGFDA(2006.5831,IENS,4)=$P(IPROCIDX,"^",1) ; PROCEDURE INDEX (-> 2005.85)
S MAGFDA(2006.5831,IENS,5)=$P(LOCATION,"^",1) ; LOCATION (-> 4)
S MAGFDA(2006.5831,IENS,6)=$P(CPT,"^",1) ; CPT (-> 81)
S MAGFDA(2006.5831,IENS,7)=$P(HL7SUBLIST,"^",1) ; HL7 HL0 SUBSCRIBER LIST (-> 779.4)
S MAGFDA(2006.5831,IENS,8)=$P(QRSCP,"^",1) ; Query/Retrieve Provider
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) W !!,"*** Entry NOT Updated ***"
E W !!,"Entry Updated"
;
; update the CLINIC
S I=0 F S I=$O(^MAG(2006.5831,IEN,1,I)) Q:'I D
. N DIK,DA ; delete the old CLINIC
. S DA(1)=IEN,DA=I,DIK="^MAG(2006.5831,"_DA(1)_",1," D ^DIK
. Q
S I=0 F S I=$O(CLINIC(I)) Q:'I D
. N DIERR,MAGERR,MAGFDA,MAGIENS
. S MAGFDA(2006.58311,"+1,"_IEN_",",.01)=$P(CLINIC(I),"^",1)
. D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
. Q
Q
;
CONSULT(SERVICE,PROCEDURE) ;
S PROCEDURE=""
Q $$LOOKUP(.SERVICE,"Request Service",123.5,".01",1)
;
PROC(PROCEDURE,SERVICE) ;
N A,CHOICE,I,J,OPTION,OPTIONIEN,X
S X=$$LOOKUP(.PROCEDURE,"Procedure",123.3,".01",1)
I X<0 Q X ; lookup failed
D GETS^DIQ(123.3,+PROCEDURE,"**","EI","A")
S I="" F J=1:1 S I=$O(A(123.32,I)) Q:I="" D
. S OPTION(J)=J_":"_A(123.32,I,.01,"E")
. S OPTIONIEN(J)=A(123.32,I,.01,"I")
. Q
S I=$O(OPTION(""))
I I="" D Q -1
. W !,"No RELATED SERVICE on file"
I $O(OPTION(I))="" D
. S SERVICE=OPTIONIEN(I)_"^"_$P(OPTION(I),":",2)
. W !,"Request Service: ",$P(OPTION(I),":",2)
. Q
E D
. S PROMPT="Select the Request Service from the list"
. S X=$$CHOOSE(PROMPT,"",.CHOICE,.OPTION) Q:X<0
. S SERVICE=OPTIONIEN(CHOICE)_"^"_$P(OPTION(CHOICE),":",2)
. Q
Q X
;
ISPECIDX(ISPECIDX) ;
Q $$LOOKUP(.ISPECIDX,"Imaging Specialty Index",2005.84,".01;3",1)
;
IPROCIDX(IPROCIDX) ;
Q $$LOOKUP(.IPROCIDX,"Imaging Procedure Index",2005.85,".01;3",0)
;
LOCATION(LOCATION) ;
Q $$LOOKUP(.LOCATION,"Acquisition Institution",4,"99;.01",1)
;
HL7SUBL(HL7SUBLIST) ;
Q $$LOOKUP(.HL7SUBLIST,"HL7 (Optimized) Subscription List",779.4,".01",0)
;
QRSCP(QRSCP) ;
Q $$LOOKUP(.QRSCP,"Query/Retrieve Provider",2006.587,,0)
;
CPT(CPT) ;
I $G(CPT)="",+PROCEDURE D ; lookup CPT in Medicine Package
. N A,MCAR6972 ; PROCEDURE/SUBSPECIALTY file (#697.2)
. S MCAR6972=$$GET1^DIQ(123.3,+PROCEDURE,.05,"I")
. I MCAR6972 D
. . D GETS^DIQ(697.2,MCAR6972,"**","I","A")
. . Q:'$D(A(697.21,"1,2,",.01,"I")) ; no CPT code
. . S CPT=A(697.21,"1,2,",.01,"I") ; get first CPT code
. . S CPT=CPT_"^"_$$GET1^DIQ(81,+CPT,.01) ; CPT code
. . S CPT=CPT_"^"_$$GET1^DIQ(81,+CPT,2) ; CPT name
. . Q
. Q
Q $$LOOKUP(.CPT,"CPT Code",81,".01;2",0)
;
CLINIC(CLINIC) ;
N DONE,I,J,TMP,X
S J=0
W !
I $D(CLINIC) D
. S I=0 F S I=$O(CLINIC(I)) Q:'I D
. . S DONE=0 F D Q:DONE
. . . W !,"Clinic: ",$$P(CLINIC(I))," ",$TR($J("",40-$X)," ","-")," Remove this clinic? n// "
. . . R X:DTIME E S X="^"
. . . I X["^" S DONE=-1,I=99999 Q
. . . I X="" S X="NO" W X
. . . I "YyNn"'[$E(X) W !,"Enter YES to keep the clinic or NO to remove it." Q
. . . I "Yy"[$E(X) W " -- removed" S CHANGE=CHANGE+1
. . . E S J=J+1,TMP(CLINIC(I))=""
. . . S DONE=1
. . . Q
. . Q
. W !
. Q
F I=J+1:1 D Q:X<1
. N NEWCLINIC
. S X=$$LOOKUP(.NEWCLINIC,"Clinic #"_I,44,".01",0) Q:X<1
. I $D(TMP(NEWCLINIC)) W " -- already there" S I=I-1 Q
. S TMP(NEWCLINIC)="",CHANGE=CHANGE+1
. Q
K CLINIC ; remove any duplicates
S (I,J)=0 F S I=$O(TMP(I)) Q:'I S J=J+1,CLINIC(J)=I
Q 1
;
LOOKUP(ITEM,NAME,FILE,FIELDS,REQUIRED) ; lookup entry
N A,DIR,DONE,I,RETURN,TMP,X,Y,DTOUT ;P278 JSJ add TMP
;
S DONE=0
;
I $D(ITEM) D Q:DONE DONE
. W !!,NAME,": ",$$P(ITEM)
. S X=$$YESNO("Change this value","n",.CHOICE) Q:X<-1
. I CHOICE'="YES" S DONE=1 Q
. S CHANGE=CHANGE+1
. Q
;
I FILE=2006.587 D Q RETURN ; special code for Query/Retrieve Provider
. N DEFAULT
. S DEFAULT=$P($G(ITEM),"^",2)
. I DEFAULT'="" D
. . S X=$$YESNO("Delete the Query/Retrieve Provider","n",.CHOICE) Q:X<-1
. . I CHOICE="YES" S ITEM="",RETURN=1,DONE=1
. . Q
. E D
. . S X=$$YESNO("Specify a Query/Retrieve Provider","n",.CHOICE) Q:X<-1
. . I CHOICE'="YES" S ITEM="",RETURN=1,DONE=1
. . Q
. I DONE Q ; don't want a Query/Retrieve Provider
. W !
. S ITEM=$$PICKSCP^MAGDSTQ9(DEFAULT,"Q/R")
. I ITEM="" S RETURN=-1 Q
. S ITEM=ITEM_"^"_ITEM,RETURN=1
. Q
;
S DIR("A")="Enter the "_NAME ; prompt
S DIR("B")=$P($G(ITEM),"^",2) I DIR("B")="" K DIR("B") ; default
S $P(DIR(0),"^",1)=$S(REQUIRED:"P",1:"PO")
S $P(DIR(0),"^",2)=FILE_":EMZ"
I FILE="2005.85" D BLDPXLST ;P278 - for procedure list, only display/allow procedures linked to the selected specialty
D ^DIR
I $G(DTOUT) Q -1 ;P278 JSJ handle timeout to prevent passing through required field
I Y="^" Q -1
I Y="^^" Q -2
I Y=-1 S ITEM="" Q 0
I FILE="2005.85",Y]"" S Y=$G(TMP(Y),-999) ;P278 JSJ
S ITEM=$$GETVALUE(FILE,+Y,FIELDS)
Q 1
;
GETVALUE(FILE,IEN,FIELDS) ;
N I,VALUE
S VALUE=IEN
F I=1:1:$L(FIELDS,";") D
. S VALUE=VALUE_"^"_$$GET1^DIQ(FILE,IEN,$P(FIELDS,";",I))
. Q
Q VALUE
;
BLDPXLST ;build alpha sorted procedure list filtered by specialty ;P278 added sub
NEW J,LLIST,NAME
S $P(DIR(0),"^",1)=$S(REQUIRED:"SA",1:"SAO") ;change to 'set of codes'
S DIR("A")=DIR("A")_": " ;keep colon at end of prompt
K DIR("L"),TMP
S DIR("L")=""
S NAME="",J=0
S LLIST=""
F S NAME=$O(^MAG(2005.85,"B",NAME)) Q:NAME="" D
. N NONE,ND0,OK,SPEC,FOUND S FOUND=0,OK="",SPEC=0
. Q:'$G(ISPECIDX)
. S SPEC=+ISPECIDX D SPEC^MAGSIXGT
. S IEN=$O(^MAG(2005.85,"B",NAME,""),-1) Q:'IEN
. I $O(^MAG(2005.85,IEN,1,"B",""))="" S FOUND=2
. I 'FOUND N SPECX S (FOUND,SPECX)=0 D Q:'FOUND
.. F S SPECX=$O(OK(3,SPECX)) Q:'SPECX!FOUND I $D(^MAG(2005.85,IEN,1,"B",SPECX)) S FOUND=1
. Q:'FOUND
. S ND0=$G(^MAG(2005.85,IEN,0)) Q:$P(ND0,"^",3)="I"
. S J=J+1
. S DIR("L",J)=" "_J_" "_NAME
. S $P(LLIST,";",J)=J_":"_NAME
. S TMP(J)=IEN
S $P(DIR(0),"^",2)=LLIST
Q
;
DISPLAY ; Display data
N I,X
W !
W !," Request Service = ",$$P(SERVICE)
W !," Procedure = ",$$P(PROCEDURE)
W !," Specialty Index = ",$$P(ISPECIDX)
W !," Procedure Index = ",$$P(IPROCIDX)
W !," Worklist = ",$P(ISPECIDX,"^",3)
I IPROCIDX W "/",$P(IPROCIDX,"^",3)
W " (",$P(ISPECIDX,"^",2)
I IPROCIDX W "/",$P(IPROCIDX,"^",2)
W ")"
W !," Acquired at = ",$$P(LOCATION)
W !," CPT Code = ",$$P(CPT)
W !," HL7 Subscriber List = ",$$P(HL7SUBLIST)
W !,"Query/Retrieve Provider = ",$$P(QRSCP)
S I=0 F S I=$O(CLINIC(I)) Q:'I D
. W !," Clinic = ",$$P(CLINIC(I))
. Q
W !
; output Associated Stop Code(s) if any
D GETS^DIQ(123.5,+SERVICE,"**","E","X")
I $D(X(123.5688)) D
. S I="" F S I=$O(X(123.5688,I)) Q:I="" D
. . W !,"Associated Stop Code = ",X(123.5688,I,.01,"E")
. . Q
. Q
E D
. W !,"Warning: No Associated Stop Codes are defined for this Request Service."
. W !," Use CONSULT ASSOCIATED STOP CODE menu option to define them."
W !
Q
;
P(X) ;
N Z
S Z=$P(X,"^",2)
I $P(X,"^",3)'="" S Z=Z_" -- "_$P(X,"^",3)
Q Z
;
YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
N DIR,DIRUT,DIROUT,X,Y
S DIR(0)="Y" S DIR("A")=PROMPT M DIR("A")=PROMPT
I $G(DEFAULT)'="" S DIR("B")=DEFAULT
D ^DIR
I $D(DIROUT) Q -2
I $D(DIRUT) Q -1
S CHOICE=Y(0)
Q 1
;
CHOOSE(PROMPT,DEFAULT,CHOICE,OPTION) ; generic question driver
N DIR,DIRUT,DIROUT,I,X,Y
S DIR(0)="S^",I=0
F S I=$O(OPTION(I)) Q:'I D
. S DIR(0)=DIR(0)_$S(I>1:";",1:"")_OPTION(I)
. Q
S DIR("A")=PROMPT
I $G(DEFAULT)'="" S DIR("B")=DEFAULT
D ^DIR
I $D(DIROUT) Q -2
I $D(DIRUT) Q -1
S CHOICE=Y
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDHOWE 13726 printed Dec 13, 2024@02:00:13 Page 2
MAGDHOWE ;WOIFO/PMK/JSJ - Clinical Specialty MWL & HL7 Editor ; Apr 27, 2022@11:43:08
+1 ;;3.0;IMAGING;**138,231,278**;Mar 19, 2002;Build 138
+2 ;; Per VA Directive 6402, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ;
+18 ; Supported IA #2053 reference UPDATE^DIE subroutine call
+19 ; Supported IA #10013 reference ^DIK subroutine call
+20 ; Supported IA #2056 reference $$GET1^DIQ function call
+21 ; Supported IA #2056 reference GETS^DIQ subroutine call
+22 ; Private IA #7095 to read GMRC PROCEDURE file (#123.3)
+23 ; Controlled IA #4171 to read REQUEST SERVICES file (#123.5)
+24 ; Supported IA #10026 reference ^DIR subroutine call
+25 ;
ENTRY ; entry point from menu
+1 NEW CHANGE,CHOICE,CLINIC,CPT,HL7SUBLIST,IEN,IENS,IPROCIDX,ISPECIDX,LOCATION
+2 NEW MSG,OPTION,PROCEDURE,PROMPT,SERVICE,QRSCP,X
+3 NEW DIERR,IENS,MAGERR,MAGFDA,MAGIENS
+4 ; use for counting updates
SET CHANGE=0
+5 SET (MSG(1),MSG(3))=""
+6 SET MSG(2)=" CLINICAL SPECIALTY DICOM & HL7 file (#2006.5831) Editor"
+7 WRITE !!
DO HEADING^MAGDTRDX(.MSG)
+8 WRITE !!,"Add/Edit a Consult or a Procedure?"
+9 SET OPTION(1)="1:Consult"
+10 SET OPTION(2)="2:Procedure"
+11 SET OPTION(3)="3:Display the existing dictionary"
+12 SET OPTION(4)="4:Quit"
+13 SET PROMPT="Enter an option"
+14 SET X=$$CHOOSE(PROMPT,"",.CHOICE,.OPTION)
if X<0
QUIT
+15 ;
+16 IF CHOICE=4
QUIT
+17 DO CHOICE
GOTO ENTRY
+18 QUIT
CHOICE ; option driver
+1 IF CHOICE=3
DO WORKLIST^MAGDTRDX
WRITE !,"-- End of File --",!!
QUIT
+2 ;
+3 ; add a consult (PROCEDURE=0)
IF CHOICE=1
Begin DoDot:1
+4 SET X=$$CONSULT(.SERVICE,.PROCEDURE)
+5 QUIT
End DoDot:1
if X<0
QUIT
+6 ; add a procedure within a service
IF '$TEST
Begin DoDot:1
+7 SET X=$$PROC(.PROCEDURE,.SERVICE)
+8 QUIT
End DoDot:1
if X<0
QUIT
+9 SET IEN=$$IREQUEST^MAGDHOW1(+SERVICE,+PROCEDURE)
+10 IF IEN
Begin DoDot:1
+11 WRITE !!,"An entry for the "
+12 IF PROCEDURE=""
WRITE $PIECE(SERVICE,"^",2)," consult"
+13 IF '$TEST
Begin DoDot:2
+14 WRITE $PIECE(PROCEDURE,"^",2)," procedure"
+15 WRITE !,"for the ",$PIECE(SERVICE,"^",2)," service"
+16 QUIT
End DoDot:2
+17 WRITE !,"is already on file."
+18 DO UPDATE(IEN)
+19 QUIT
End DoDot:1
QUIT
+20 ;
+21 SET X=$$ISPECIDX(.ISPECIDX)
if X<0
QUIT
+22 SET X=$$IPROCIDX(.IPROCIDX)
if X<0
QUIT
+23 SET X=$$LOCATION(.LOCATION)
if X<0
QUIT
+24 SET X=$$CPT(.CPT)
if X<0
QUIT
+25 SET X=$$HL7SUBL(.HL7SUBLIST)
if X<0
QUIT
+26 SET X=$$QRSCP(.QRSCP)
if X<0
QUIT
+27 SET X=$$CLINIC(.CLINIC)
if X<0
QUIT
+28 ;
+29 DO DISPLAY
+30 ;
+31 WRITE !!
+32 SET X=$$YESNO("Create this entry","n",.CHOICE)
if X<-1
QUIT
+33 IF CHOICE'="YES"
WRITE " -- entry not created"
QUIT
+34 ;
+35 ; create the entry
+36 SET IENS="+1,"
+37 ; REQUEST SERVICE (-> 123.5)
SET MAGFDA(2006.5831,IENS,.01)=$PIECE(SERVICE,"^",1)
+38 ; PROCEDURE (-> 123.3)
SET MAGFDA(2006.5831,IENS,2)=$PIECE(PROCEDURE,"^",1)
+39 ; SPECIALTY INDEX (-> 2005.84)
SET MAGFDA(2006.5831,IENS,3)=$PIECE(ISPECIDX,"^",1)
+40 ; PROCEDURE INDEX (-> 2005.85)
SET MAGFDA(2006.5831,IENS,4)=$PIECE(IPROCIDX,"^",1)
+41 ; LOCATION (-> 4)
SET MAGFDA(2006.5831,IENS,5)=$PIECE(LOCATION,"^",1)
+42 ; CPT (-> 81)
SET MAGFDA(2006.5831,IENS,6)=$PIECE(CPT,"^",1)
+43 ; HL7 HL0 SUBSCRIBER LIST (-> 779.4)
SET MAGFDA(2006.5831,IENS,7)=$PIECE(HL7SUBLIST,"^",1)
+44 ; Query/Retrieve Provider
SET MAGFDA(2006.5831,IENS,8)=$PIECE(QRSCP,"^",1)
+45 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+46 IF $DATA(DIERR)
WRITE !!,"*** Entry NOT Created ***"
QUIT
+47 IF '$TEST
WRITE " -- entry created"
+48 SET IEN=MAGIENS(1)
+49 ; output the CLINIC
+50 SET I=0
FOR
SET I=$ORDER(CLINIC(I))
if 'I
QUIT
Begin DoDot:1
+51 NEW DIERR,MAGERR,MAGFDA,MAGIENS
+52 SET MAGFDA(2006.58311,"+1,"_IEN_",",.01)=$PIECE(CLINIC(I),"^",1)
+53 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+54 QUIT
End DoDot:1
+55 ;
+56 QUIT
+57 ;
UPDATE(IEN) ; delete or update the consult or procedure
+1 NEW CLINIC,CPT,HL7SUBLIST,I,IPROCIDX,ISPECIDX,LOCATION,PROCEDURE,SERVICE,X
+2 SET X=^MAG(2006.5831,IEN,0)
+3 SET SERVICE=$PIECE(X,"^",1)
SET PROCEDURE=$PIECE(X,"^",2)
+4 SET SERVICE=SERVICE_"^"_$$GET1^DIQ(123.5,SERVICE,.01)
+5 SET PROCEDURE=PROCEDURE_"^"_$$GET1^DIQ(123.3,PROCEDURE,.01)
+6 SET ISPECIDX=$$GETVALUE(2005.84,$PIECE(X,"^",3),".01;3")
+7 SET IPROCIDX=$$GETVALUE(2005.85,$PIECE(X,"^",4),".01;3")
+8 SET LOCATION=$$GETVALUE(4,$PIECE(X,"^",5),".01;99")
+9 SET CPT=$$GETVALUE(81,$PIECE(X,"^",6),".01;2")
+10 SET HL7SUBLIST=$$GETVALUE(779.4,$PIECE(X,"^",7),".01")
+11 ; ien same as name
SET QRSCP=$PIECE(X,"^",8)
SET QRSCP=QRSCP_"^"_QRSCP
+12 SET I=0
FOR
SET I=$ORDER(^MAG(2006.5831,IEN,1,I))
if 'I
QUIT
Begin DoDot:1
+13 SET CLINIC(I)=$$GETVALUE(44,^MAG(2006.5831,IEN,1,I,0),".01")
+14 QUIT
End DoDot:1
+15 DO DISPLAY
+16 ;
+17 SET X=$$YESNO("Change this entry","n",.CHOICE)
if X<-1
QUIT
+18 IF CHOICE'="YES"
WRITE " -- entry not changed"
QUIT
+19 WRITE !
+20 SET X=$$YESNO("Delete the entire entry","n",.CHOICE)
if X<-1
QUIT
+21 ; delete the entire entry
IF CHOICE="YES"
Begin DoDot:1
+22 NEW DA,DIK
+23 SET DIK="^MAG(2006.5831,"
SET DA=IEN
+24 DO ^DIK
+25 WRITE " -- entry deleted"
+26 QUIT
End DoDot:1
QUIT
+27 WRITE " -- entry not deleted"
+28 ;
+29 ; update the entry
DO UPDATE1
+30 QUIT
+31 ;
UPDATE1 ; update a the consult or procedure
+1 NEW DIERR,IENS,MAGERR,MAGFDA,MAGIENS,X
+2 ;
+3 SET X=$$ISPECIDX(.ISPECIDX)
if X<0
QUIT
+4 SET X=$$IPROCIDX(.IPROCIDX)
if X<0
QUIT
+5 SET X=$$LOCATION(.LOCATION)
if X<0
QUIT
+6 SET X=$$CPT(.CPT)
if X<0
QUIT
+7 SET X=$$HL7SUBL(.HL7SUBLIST)
if X<0
QUIT
+8 SET X=$$QRSCP(.QRSCP)
if X<0
QUIT
+9 SET X=$$CLINIC(.CLINIC)
if X<0
QUIT
+10 ;
+11 IF CHANGE=0
WRITE !!,"No changes"
QUIT
+12 ;
+13 DO DISPLAY
+14 ;
+15 WRITE !
+16 SET X=$$YESNO("Update this entry","n",.CHOICE)
if X<-1
QUIT
+17 IF CHOICE'="YES"
WRITE " -- entry not updated"
QUIT
+18 ;
+19 ; update the entry
+20 SET IENS=IEN_","
+21 ; SPECIALTY INDEX (-> 2005.84)
SET MAGFDA(2006.5831,IENS,3)=$PIECE(ISPECIDX,"^",1)
+22 ; PROCEDURE INDEX (-> 2005.85)
SET MAGFDA(2006.5831,IENS,4)=$PIECE(IPROCIDX,"^",1)
+23 ; LOCATION (-> 4)
SET MAGFDA(2006.5831,IENS,5)=$PIECE(LOCATION,"^",1)
+24 ; CPT (-> 81)
SET MAGFDA(2006.5831,IENS,6)=$PIECE(CPT,"^",1)
+25 ; HL7 HL0 SUBSCRIBER LIST (-> 779.4)
SET MAGFDA(2006.5831,IENS,7)=$PIECE(HL7SUBLIST,"^",1)
+26 ; Query/Retrieve Provider
SET MAGFDA(2006.5831,IENS,8)=$PIECE(QRSCP,"^",1)
+27 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+28 IF $DATA(DIERR)
WRITE !!,"*** Entry NOT Updated ***"
+29 IF '$TEST
WRITE !!,"Entry Updated"
+30 ;
+31 ; update the CLINIC
+32 SET I=0
FOR
SET I=$ORDER(^MAG(2006.5831,IEN,1,I))
if 'I
QUIT
Begin DoDot:1
+33 ; delete the old CLINIC
NEW DIK,DA
+34 SET DA(1)=IEN
SET DA=I
SET DIK="^MAG(2006.5831,"_DA(1)_",1,"
DO ^DIK
+35 QUIT
End DoDot:1
+36 SET I=0
FOR
SET I=$ORDER(CLINIC(I))
if 'I
QUIT
Begin DoDot:1
+37 NEW DIERR,MAGERR,MAGFDA,MAGIENS
+38 SET MAGFDA(2006.58311,"+1,"_IEN_",",.01)=$PIECE(CLINIC(I),"^",1)
+39 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+40 QUIT
End DoDot:1
+41 QUIT
+42 ;
CONSULT(SERVICE,PROCEDURE) ;
+1 SET PROCEDURE=""
+2 QUIT $$LOOKUP(.SERVICE,"Request Service",123.5,".01",1)
+3 ;
PROC(PROCEDURE,SERVICE) ;
+1 NEW A,CHOICE,I,J,OPTION,OPTIONIEN,X
+2 SET X=$$LOOKUP(.PROCEDURE,"Procedure",123.3,".01",1)
+3 ; lookup failed
IF X<0
QUIT X
+4 DO GETS^DIQ(123.3,+PROCEDURE,"**","EI","A")
+5 SET I=""
FOR J=1:1
SET I=$ORDER(A(123.32,I))
if I=""
QUIT
Begin DoDot:1
+6 SET OPTION(J)=J_":"_A(123.32,I,.01,"E")
+7 SET OPTIONIEN(J)=A(123.32,I,.01,"I")
+8 QUIT
End DoDot:1
+9 SET I=$ORDER(OPTION(""))
+10 IF I=""
Begin DoDot:1
+11 WRITE !,"No RELATED SERVICE on file"
End DoDot:1
QUIT -1
+12 IF $ORDER(OPTION(I))=""
Begin DoDot:1
+13 SET SERVICE=OPTIONIEN(I)_"^"_$PIECE(OPTION(I),":",2)
+14 WRITE !,"Request Service: ",$PIECE(OPTION(I),":",2)
+15 QUIT
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 SET PROMPT="Select the Request Service from the list"
+18 SET X=$$CHOOSE(PROMPT,"",.CHOICE,.OPTION)
if X<0
QUIT
+19 SET SERVICE=OPTIONIEN(CHOICE)_"^"_$PIECE(OPTION(CHOICE),":",2)
+20 QUIT
End DoDot:1
+21 QUIT X
+22 ;
ISPECIDX(ISPECIDX) ;
+1 QUIT $$LOOKUP(.ISPECIDX,"Imaging Specialty Index",2005.84,".01;3",1)
+2 ;
IPROCIDX(IPROCIDX) ;
+1 QUIT $$LOOKUP(.IPROCIDX,"Imaging Procedure Index",2005.85,".01;3",0)
+2 ;
LOCATION(LOCATION) ;
+1 QUIT $$LOOKUP(.LOCATION,"Acquisition Institution",4,"99;.01",1)
+2 ;
HL7SUBL(HL7SUBLIST) ;
+1 QUIT $$LOOKUP(.HL7SUBLIST,"HL7 (Optimized) Subscription List",779.4,".01",0)
+2 ;
QRSCP(QRSCP) ;
+1 QUIT $$LOOKUP(.QRSCP,"Query/Retrieve Provider",2006.587,,0)
+2 ;
CPT(CPT) ;
+1 ; lookup CPT in Medicine Package
IF $GET(CPT)=""
IF +PROCEDURE
Begin DoDot:1
+2 ; PROCEDURE/SUBSPECIALTY file (#697.2)
NEW A,MCAR6972
+3 SET MCAR6972=$$GET1^DIQ(123.3,+PROCEDURE,.05,"I")
+4 IF MCAR6972
Begin DoDot:2
+5 DO GETS^DIQ(697.2,MCAR6972,"**","I","A")
+6 ; no CPT code
if '$DATA(A(697.21,"1,2,",.01,"I"))
QUIT
+7 ; get first CPT code
SET CPT=A(697.21,"1,2,",.01,"I")
+8 ; CPT code
SET CPT=CPT_"^"_$$GET1^DIQ(81,+CPT,.01)
+9 ; CPT name
SET CPT=CPT_"^"_$$GET1^DIQ(81,+CPT,2)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT $$LOOKUP(.CPT,"CPT Code",81,".01;2",0)
+13 ;
CLINIC(CLINIC) ;
+1 NEW DONE,I,J,TMP,X
+2 SET J=0
+3 WRITE !
+4 IF $DATA(CLINIC)
Begin DoDot:1
+5 SET I=0
FOR
SET I=$ORDER(CLINIC(I))
if 'I
QUIT
Begin DoDot:2
+6 SET DONE=0
FOR
Begin DoDot:3
+7 WRITE !,"Clinic: ",$$P(CLINIC(I))," ",$TRANSLATE($JUSTIFY("",40-$X)," ","-")," Remove this clinic? n// "
+8 READ X:DTIME
IF '$TEST
SET X="^"
+9 IF X["^"
SET DONE=-1
SET I=99999
QUIT
+10 IF X=""
SET X="NO"
WRITE X
+11 IF "YyNn"'[$EXTRACT(X)
WRITE !,"Enter YES to keep the clinic or NO to remove it."
QUIT
+12 IF "Yy"[$EXTRACT(X)
WRITE " -- removed"
SET CHANGE=CHANGE+1
+13 IF '$TEST
SET J=J+1
SET TMP(CLINIC(I))=""
+14 SET DONE=1
+15 QUIT
End DoDot:3
if DONE
QUIT
+16 QUIT
End DoDot:2
+17 WRITE !
+18 QUIT
End DoDot:1
+19 FOR I=J+1:1
Begin DoDot:1
+20 NEW NEWCLINIC
+21 SET X=$$LOOKUP(.NEWCLINIC,"Clinic #"_I,44,".01",0)
if X<1
QUIT
+22 IF $DATA(TMP(NEWCLINIC))
WRITE " -- already there"
SET I=I-1
QUIT
+23 SET TMP(NEWCLINIC)=""
SET CHANGE=CHANGE+1
+24 QUIT
End DoDot:1
if X<1
QUIT
+25 ; remove any duplicates
KILL CLINIC
+26 SET (I,J)=0
FOR
SET I=$ORDER(TMP(I))
if 'I
QUIT
SET J=J+1
SET CLINIC(J)=I
+27 QUIT 1
+28 ;
LOOKUP(ITEM,NAME,FILE,FIELDS,REQUIRED) ; lookup entry
+1 ;P278 JSJ add TMP
NEW A,DIR,DONE,I,RETURN,TMP,X,Y,DTOUT
+2 ;
+3 SET DONE=0
+4 ;
+5 IF $DATA(ITEM)
Begin DoDot:1
+6 WRITE !!,NAME,": ",$$P(ITEM)
+7 SET X=$$YESNO("Change this value","n",.CHOICE)
if X<-1
QUIT
+8 IF CHOICE'="YES"
SET DONE=1
QUIT
+9 SET CHANGE=CHANGE+1
+10 QUIT
End DoDot:1
if DONE
QUIT DONE
+11 ;
+12 ; special code for Query/Retrieve Provider
IF FILE=2006.587
Begin DoDot:1
+13 NEW DEFAULT
+14 SET DEFAULT=$PIECE($GET(ITEM),"^",2)
+15 IF DEFAULT'=""
Begin DoDot:2
+16 SET X=$$YESNO("Delete the Query/Retrieve Provider","n",.CHOICE)
if X<-1
QUIT
+17 IF CHOICE="YES"
SET ITEM=""
SET RETURN=1
SET DONE=1
+18 QUIT
End DoDot:2
+19 IF '$TEST
Begin DoDot:2
+20 SET X=$$YESNO("Specify a Query/Retrieve Provider","n",.CHOICE)
if X<-1
QUIT
+21 IF CHOICE'="YES"
SET ITEM=""
SET RETURN=1
SET DONE=1
+22 QUIT
End DoDot:2
+23 ; don't want a Query/Retrieve Provider
IF DONE
QUIT
+24 WRITE !
+25 SET ITEM=$$PICKSCP^MAGDSTQ9(DEFAULT,"Q/R")
+26 IF ITEM=""
SET RETURN=-1
QUIT
+27 SET ITEM=ITEM_"^"_ITEM
SET RETURN=1
+28 QUIT
End DoDot:1
QUIT RETURN
+29 ;
+30 ; prompt
SET DIR("A")="Enter the "_NAME
+31 ; default
SET DIR("B")=$PIECE($GET(ITEM),"^",2)
IF DIR("B")=""
KILL DIR("B")
+32 SET $PIECE(DIR(0),"^",1)=$SELECT(REQUIRED:"P",1:"PO")
+33 SET $PIECE(DIR(0),"^",2)=FILE_":EMZ"
+34 ;P278 - for procedure list, only display/allow procedures linked to the selected specialty
IF FILE="2005.85"
DO BLDPXLST
+35 DO ^DIR
+36 ;P278 JSJ handle timeout to prevent passing through required field
IF $GET(DTOUT)
QUIT -1
+37 IF Y="^"
QUIT -1
+38 IF Y="^^"
QUIT -2
+39 IF Y=-1
SET ITEM=""
QUIT 0
+40 ;P278 JSJ
IF FILE="2005.85"
IF Y]""
SET Y=$GET(TMP(Y),-999)
+41 SET ITEM=$$GETVALUE(FILE,+Y,FIELDS)
+42 QUIT 1
+43 ;
GETVALUE(FILE,IEN,FIELDS) ;
+1 NEW I,VALUE
+2 SET VALUE=IEN
+3 FOR I=1:1:$LENGTH(FIELDS,";")
Begin DoDot:1
+4 SET VALUE=VALUE_"^"_$$GET1^DIQ(FILE,IEN,$PIECE(FIELDS,";",I))
+5 QUIT
End DoDot:1
+6 QUIT VALUE
+7 ;
BLDPXLST ;build alpha sorted procedure list filtered by specialty ;P278 added sub
+1 NEW J,LLIST,NAME
+2 ;change to 'set of codes'
SET $PIECE(DIR(0),"^",1)=$SELECT(REQUIRED:"SA",1:"SAO")
+3 ;keep colon at end of prompt
SET DIR("A")=DIR("A")_": "
+4 KILL DIR("L"),TMP
+5 SET DIR("L")=""
+6 SET NAME=""
SET J=0
+7 SET LLIST=""
+8 FOR
SET NAME=$ORDER(^MAG(2005.85,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+9 NEW NONE,ND0,OK,SPEC,FOUND
SET FOUND=0
SET OK=""
SET SPEC=0
+10 if '$GET(ISPECIDX)
QUIT
+11 SET SPEC=+ISPECIDX
DO SPEC^MAGSIXGT
+12 SET IEN=$ORDER(^MAG(2005.85,"B",NAME,""),-1)
if 'IEN
QUIT
+13 IF $ORDER(^MAG(2005.85,IEN,1,"B",""))=""
SET FOUND=2
+14 IF 'FOUND
NEW SPECX
SET (FOUND,SPECX)=0
Begin DoDot:2
+15 FOR
SET SPECX=$ORDER(OK(3,SPECX))
if 'SPECX!FOUND
QUIT
IF $DATA(^MAG(2005.85,IEN,1,"B",SPECX))
SET FOUND=1
End DoDot:2
if 'FOUND
QUIT
+16 if 'FOUND
QUIT
+17 SET ND0=$GET(^MAG(2005.85,IEN,0))
if $PIECE(ND0,"^",3)="I"
QUIT
+18 SET J=J+1
+19 SET DIR("L",J)=" "_J_" "_NAME
+20 SET $PIECE(LLIST,";",J)=J_":"_NAME
+21 SET TMP(J)=IEN
End DoDot:1
+22 SET $PIECE(DIR(0),"^",2)=LLIST
+23 QUIT
+24 ;
DISPLAY ; Display data
+1 NEW I,X
+2 WRITE !
+3 WRITE !," Request Service = ",$$P(SERVICE)
+4 WRITE !," Procedure = ",$$P(PROCEDURE)
+5 WRITE !," Specialty Index = ",$$P(ISPECIDX)
+6 WRITE !," Procedure Index = ",$$P(IPROCIDX)
+7 WRITE !," Worklist = ",$PIECE(ISPECIDX,"^",3)
+8 IF IPROCIDX
WRITE "/",$PIECE(IPROCIDX,"^",3)
+9 WRITE " (",$PIECE(ISPECIDX,"^",2)
+10 IF IPROCIDX
WRITE "/",$PIECE(IPROCIDX,"^",2)
+11 WRITE ")"
+12 WRITE !," Acquired at = ",$$P(LOCATION)
+13 WRITE !," CPT Code = ",$$P(CPT)
+14 WRITE !," HL7 Subscriber List = ",$$P(HL7SUBLIST)
+15 WRITE !,"Query/Retrieve Provider = ",$$P(QRSCP)
+16 SET I=0
FOR
SET I=$ORDER(CLINIC(I))
if 'I
QUIT
Begin DoDot:1
+17 WRITE !," Clinic = ",$$P(CLINIC(I))
+18 QUIT
End DoDot:1
+19 WRITE !
+20 ; output Associated Stop Code(s) if any
+21 DO GETS^DIQ(123.5,+SERVICE,"**","E","X")
+22 IF $DATA(X(123.5688))
Begin DoDot:1
+23 SET I=""
FOR
SET I=$ORDER(X(123.5688,I))
if I=""
QUIT
Begin DoDot:2
+24 WRITE !,"Associated Stop Code = ",X(123.5688,I,.01,"E")
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 WRITE !,"Warning: No Associated Stop Codes are defined for this Request Service."
+29 WRITE !," Use CONSULT ASSOCIATED STOP CODE menu option to define them."
End DoDot:1
+30 WRITE !
+31 QUIT
+32 ;
P(X) ;
+1 NEW Z
+2 SET Z=$PIECE(X,"^",2)
+3 IF $PIECE(X,"^",3)'=""
SET Z=Z_" -- "_$PIECE(X,"^",3)
+4 QUIT Z
+5 ;
YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
+1 NEW DIR,DIRUT,DIROUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")=PROMPT
MERGE DIR("A")=PROMPT
+3 IF $GET(DEFAULT)'=""
SET DIR("B")=DEFAULT
+4 DO ^DIR
+5 IF $DATA(DIROUT)
QUIT -2
+6 IF $DATA(DIRUT)
QUIT -1
+7 SET CHOICE=Y(0)
+8 QUIT 1
+9 ;
CHOOSE(PROMPT,DEFAULT,CHOICE,OPTION) ; generic question driver
+1 NEW DIR,DIRUT,DIROUT,I,X,Y
+2 SET DIR(0)="S^"
SET I=0
+3 FOR
SET I=$ORDER(OPTION(I))
if 'I
QUIT
Begin DoDot:1
+4 SET DIR(0)=DIR(0)_$SELECT(I>1:";",1:"")_OPTION(I)
+5 QUIT
End DoDot:1
+6 SET DIR("A")=PROMPT
+7 IF $GET(DEFAULT)'=""
SET DIR("B")=DEFAULT
+8 DO ^DIR
+9 IF $DATA(DIROUT)
QUIT -2
+10 IF $DATA(DIRUT)
QUIT -1
+11 SET CHOICE=Y
+12 QUIT 1
