MAGDMEDK ;WOIFO/LB Routine to find Medicine subspecialty [ 06/20/2001 08:56 ] ; 06/06/2005 09:25
;;3.0;IMAGING;**51**;26-August-2005
;; +---------------------------------------------------------------+
;; | 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. |
;; +---------------------------------------------------------------+
;;
Q
SUB(MAGSUB,MAGPAT) ;Get Medicine subspecialty and entries.
; an array should be produced and only for entries found from call to
; api SUB^MCARUTL2:
; MAGMC(#)=data formatted from call to SUB^MCARUTL2
Q:'$D(MAGPAT)!'$D(MAGSUB)
N I,II,X,Y,MAGMC,MAGXX,SUB
S MAGMC(0)="0^0"
D SUB^MCARUTL2(.MAGXX,MAGPAT,MAGSUB)
Q:'MAGXX
S I=0 F S I=$O(MAGXX(I)) Q:'I D
. S (X,Y)="",X=$P(MAGXX(I),"^"),%DT="ST" D ^%DT
. S MAGMC(MAGPAT,SUB,Y,I)=$G(MAGXX(I))
. I $D(MAGXX(I,2005)) S II=0 D
. . F S II=$O(MAGXX(I,2005,II)) Q:'II D
. . . S MAGMC(MAGPAT,SUB,Y,I,2005,II)=MAGXX(I,2005,II)
S MAGMC(0)="1^"_$G(MAGXX(0))
Q
PATSUB(MAGSUB1,MAGDFN) ;
Q:'MAGDFN
N I,MAGX
D PATSUB^MCARUTL2(.MAGX,MAGDFN)
Q:'MAGX
Q:'$D(MAGX(0))
S MAGSUB1(0)="1^"_+MAGX_"^"_$P(MAGX(0),"^",2)
; MAGSUB1(0)=1^#entries^msg text
S I=0 F S I=$O(MAGX(I)) Q:'I D
. S MAGSUB1(I)=$P(MAGX(I),"^")_" ("_$P(MAGX(I),"^",2)_")"
. ; MAGSUB1(#)=OPH (25) --25 being ien for procedure
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDMEDK 2119 printed Sep 23, 2025@19:36:56 Page 2
MAGDMEDK ;WOIFO/LB Routine to find Medicine subspecialty [ 06/20/2001 08:56 ] ; 06/06/2005 09:25
+1 ;;3.0;IMAGING;**51**;26-August-2005
+2 ;; +---------------------------------------------------------------+
+3 ;; | Property of the US Government. |
+4 ;; | No permission to copy or redistribute this software is given. |
+5 ;; | Use of unreleased versions of this software requires the user |
+6 ;; | to execute a written test agreement with the VistA Imaging |
+7 ;; | Development Office of the Department of Veterans Affairs, |
+8 ;; | telephone (301) 734-0100. |
+9 ;; | |
+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 QUIT
SUB(MAGSUB,MAGPAT) ;Get Medicine subspecialty and entries.
+1 ; an array should be produced and only for entries found from call to
+2 ; api SUB^MCARUTL2:
+3 ; MAGMC(#)=data formatted from call to SUB^MCARUTL2
+4 if '$DATA(MAGPAT)!'$DATA(MAGSUB)
QUIT
+5 NEW I,II,X,Y,MAGMC,MAGXX,SUB
+6 SET MAGMC(0)="0^0"
+7 DO SUB^MCARUTL2(.MAGXX,MAGPAT,MAGSUB)
+8 if 'MAGXX
QUIT
+9 SET I=0
FOR
SET I=$ORDER(MAGXX(I))
if 'I
QUIT
Begin DoDot:1
+10 SET (X,Y)=""
SET X=$PIECE(MAGXX(I),"^")
SET %DT="ST"
DO ^%DT
+11 SET MAGMC(MAGPAT,SUB,Y,I)=$GET(MAGXX(I))
+12 IF $DATA(MAGXX(I,2005))
SET II=0
Begin DoDot:2
+13 FOR
SET II=$ORDER(MAGXX(I,2005,II))
if 'II
QUIT
Begin DoDot:3
+14 SET MAGMC(MAGPAT,SUB,Y,I,2005,II)=MAGXX(I,2005,II)
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET MAGMC(0)="1^"_$GET(MAGXX(0))
+16 QUIT
PATSUB(MAGSUB1,MAGDFN) ;
+1 if 'MAGDFN
QUIT
+2 NEW I,MAGX
+3 DO PATSUB^MCARUTL2(.MAGX,MAGDFN)
+4 if 'MAGX
QUIT
+5 if '$DATA(MAGX(0))
QUIT
+6 SET MAGSUB1(0)="1^"_+MAGX_"^"_$PIECE(MAGX(0),"^",2)
+7 ; MAGSUB1(0)=1^#entries^msg text
+8 SET I=0
FOR
SET I=$ORDER(MAGX(I))
if 'I
QUIT
Begin DoDot:1
+9 SET MAGSUB1(I)=$PIECE(MAGX(I),"^")_" ("_$PIECE(MAGX(I),"^",2)_")"
+10 ; MAGSUB1(#)=OPH (25) --25 being ien for procedure
End DoDot:1
+11 QUIT
