MAGTP004 ;WOIFO/FG,MLH - TELEPATHOLOGY RPCS ; 25 Jun 2013 3:30 PM
;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 2013
;; Per VHA Directive 2004-038, 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. |
;; +---------------------------------------------------------------+
;;
Q ;
;
;***** GET A LIST OF ALL UNRELEASED OR RELEASED REPORTS,
; FILTER BY BACK DAYS FOR UNRELEASED REPORTS,
; FILTER BY STATION NUMBER IF CONSULTATIONS ARE PRESENT FOR A CASE
; RPC: MAGTP GET ACTIVE
;
; .MAGRY Reference to a local or global variable where the results
; are returned to.
;
; FLAG Flag that controls execution:
;
; 0 Selects only unreleased reports.
;
; 1 Selected only released reports.
; One may go back in time by DAYS number
; of days (see next input)
;
; DAYS Number of days one may go back in time to
; retrieve data in case of released reports.
;
; STAT 1) If STATion ID is not null and in the Reading List
; in file (#2006.13) display the case if
; it has a consultation for an interpreting
; station number equal to STAT
; 2) If STAT is null, display all cases.
;
; Return Values
; =============
;
; If @MAGRY@(0) 1st '^'-piece is < 0, then an error
; occurred during execution of the procedure: [code]^^[error explanation]
;
; Otherwise, the output array is as follows:
;
; @MAGRY@(0) Description
; ^01: 0
; ^02: Total Number of Lines
; ^03: "Released Reports" or "Unreleased Reports"
;
; @MAGRY@(i) Description
; ^01: Case Number
; ^02: Reserved Entry (0/1 for Not Reserved/Reserved)
; ^03: Initials of who reserved the case in the LAB DATA file (#63)
; ^04: Patient's Name
; ^05: Patient's ID Number
; ^06: Priority
; ^07: Slide(s) Available
; ^08: Date/Time Specimen Taken
; ^09: Case Status
; ^10: Site Initials
; ^11: AP Section
; ^12: Year
; ^13: Accession Number
; ^14: ICN
; ^15: Specimen Count
; ^16: Reading Method
; ^17: Patient's Short ID
; ^18: Is there a Note? (Yes/No)
; ^19: Number of image(s)
; Notes
; =====
;
; The ^TMP("MAGTP",$J,"AC") global node is used by this procedure
; if the count (CT) gets too large (CT>100).
;
GETAC(MAGRY,FLAG,DAYS,STAT) ; RPC [MAGTP GET ACTIVE]
N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGUTERR"
K MAGRY
N SITE,MAGIEN,GBLRET,TYPE,SELFLAG
; Use indirection, work if an Array or a Global Array is returned
S GBLRET=0
S MAGRY="MAGRY"
S SELFLAG=0
;
; If STATion ID is passed, check that it is in
; the Reading List in file (#2006.13)
;
I $G(STAT)]"" D Q:$D(@MAGRY@(0))=1
. S SITE=$$IEN^XUAF4(STAT) ; Supported IA #2171 ; Site Number
. I SITE="" S @MAGRY@(0)="-3^^Invalid Site" Q
. S MAGIEN=$O(^MAG(2006.13,1,5,"B",SITE,""))
. I MAGIEN="" S @MAGRY@(0)="-2^^Site Not in Reading List" Q
. ;
. ; Check type of Reading Site:
. ; If TYPE="CONSULTATION", select only the cases with their station number matching STAT
. ;
. S TYPE=$$GET1^DIQ(2006.135,MAGIEN_",1,",.02)
. I TYPE="CONSULTATION" S SELFLAG=1
. Q
N CT,TODAY,REC,LRSS,YEAR,LRX,LRAA,LRAC
N LRAN,LRSF,LRDFN,LRI,IEN,RDATE,RDADD
N PNM,DFN,LRAC,OUTPUT,TEXT,ST,XDT,IN,XREC
S FLAG=$G(FLAG,0) ; Default to unreleased
S CT=0
S TODAY=+$$NOW^XLFDT ; Present date for comparison
;; Search Accession/Case Worklist #2005.42 instead
S ST=$S($G(FLAG)=1:"R",1:"U") ;READ - Released, UNREAD - Un released
S XDT=0 F S XDT=$O(^MAG(2005.42,"C",ST,XDT)) Q:'XDT D
. S IN=0 F S IN=$O(^MAG(2005.42,"C",ST,XDT,IN)) Q:'IN D
. . S XREC=$G(^MAG(2005.42,IN,0)),LRAC=$P(XREC,U) Q:LRAC=""
. . S LRSS=$P(LRAC," ")
. . S LRSF=$S(LRSS="CY":63.09,LRSS="EM":63.02,1:63.08)
. . S YEAR=DT\10000*10000,LRAA=$O(^LRO(68,"B",LRSS,0))
. . S LRAN=+$P(LRAC," ",3) Q:'LRAN
. . S LRDFN=$P($G(^LRO(68,LRAA,1,YEAR,1,LRAN,0)),"^",1) Q:'LRDFN
. . S LRI=$P($G(^LRO(68,LRAA,1,YEAR,1,LRAN,3)),"^",5) Q:'LRI
. . S IEN=LRI_","_LRDFN_","
. . Q:'$$GET1^DIQ(LRSF,IEN,.01,"I") ; Skip bad entries
. . S RDATE=+$$GET1^DIQ(LRSF,IEN,.11,"I") ; Release date if any
. . Q:$S(RDATE:1,1:0)'=FLAG ; Unreleased/Released selection
. . I FLAG D Q:(TODAY>RDADD)
. . . S DAYS=$G(DAYS,90) ; Released only for last DAYS, default 90
. . . S RDADD=$$FMADD^XLFDT(RDATE,DAYS) ; Calculate Release Date + DAYS
. . . Q
. . I SELFLAG Q:'$$ISCONSLT^MAGTP009(LRAC,SITE) ; Quit if no consultations for that case and site
. . S PNM=$$GET1^DIQ(63,LRDFN_",",".03")
. . S DFN=$$GET1^DIQ(63,LRDFN_",",".03","I")
. . S REC=IN ;#2005.42 ien
. . ;OUTPUT contains pieces ^02:^17 defined above in the @MAGRY@(i) description
. . S OUTPUT=$$GETCASE^MAGTP009(LRSS,LRAC,LRSF,IEN,REC,FLAG,PNM,DFN)
. . S CT=CT+1
. . I (CT>100),'GBLRET D
. . . D ARY2GLB^MAGTP009(.MAGRY)
. . . S GBLRET=1
. . . Q
. . S @MAGRY@(CT)=LRAC_U_OUTPUT
. . Q
. Q
; Worklist Header
S TEXT=$S(FLAG:"Released Reports",1:"Unreleased Reports")
S @MAGRY@(0)="0^"_CT_U_TEXT
Q ;end GETAC
;
;***** GET SPECIMEN, SMEAR/PREP/BLOCK AND STAIN/PROCEDURE/SLIDE
; INFO FOR A SPECIFIED CASE
; RPC: MAGTP GET SLIDES
;
; .MAGRY Reference to a local variable where the results
; are returned to.
;
; LRSS AP Section
;
; YEAR Accession Year (Two figures)
;
; LRAN Accession Number
;
; Return Values
; =============
;
; If MAGRY(0) 1st '^'-piece is 0, then an error
; occurred during execution of the procedure: 0^0^ ERROR explanation
;
; Otherwise, the output array is as follows:
;
; MAGRY(0) Description
; ^01: 1
; ^02: Total Number of Lines
; ^03: "Specimen"
; ^04: "Smear Prep"
; ^05: "Stain/Procedure"
; ^06: "# of Slides"
; ^07: "Last Stain Date"
;
; MAGRY(i) Description
; ^01: Specimen
; ^02: Smear Prep/Block Name
; ^03: Stain/Procedure/Slide Name
; ^04: Number of Stains/Procedures/Slides
; ^05: Date of Entry of the Last Stain/Procedure/Slide
;
GETSD(MAGRY,LRSS,YEAR,LRAN) ; RPC [MAGTP GET SLIDES]
K MAGRY
N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
N INPUT
S INPUT=$$CONTEXT^MAGTP006(.MAGRY,LRSS,YEAR,LRAN) Q:'MAGRY(0)
N MAGOUT,MAGERR
N LRSF,IEN,SUBF,NIEN,CT,N,SPEC
N J,NIENJ,NJ,START,SMEAR,SUBFJ,SUBFK
N NIENJK,NJK,SLIDE,INDX,INDXJ,INDXJK,LAST
S LRSF=$P(INPUT,","),IEN=$P(INPUT,",",2,4)
; Get all info for specimen(s), then sort through it
D GETS^DIQ(LRSF,IEN,".012*","IE","MAGOUT","MAGERR")
I $D(MAGERR) S MAGRY(0)="0^0^Access Error: "_MAGERR("DIERR",1,"TEXT",1) Q
S SUBF=+$$GET1^DID(LRSF,.012,"","SPECIFIER") ; Subfields of Specimen
S START=$O(^DD(SUBF,1),-1),J=START
;
; Extract subfields, sub-subfields
;
F S J=$O(^DD(SUBF,J)) Q:J'>0 D
. S SUBFJ(J)=+$$GET1^DID(SUBF,J_",","","SPECIFIER")
. S SUBFK(J)=+$$GET1^DID(SUBFJ(J),"1,","","SPECIFIER")
. Q
;
; NIEN may be ordered incorrectly, set index
;
S NIEN=""
F S NIEN=$O(MAGOUT(SUBF,NIEN)) Q:NIEN="" D
. S INDX($P(NIEN,","))=""
S CT=1,N=""
F S N=$O(INDX(N)) Q:N="" D
. S NIEN=N_","_IEN
. S SPEC=MAGOUT(SUBF,NIEN,.01,"E")
. S MAGRY(CT)=SPEC ; Record specimen
. S J=START
. F S J=$O(^DD(SUBF,J)) Q:J'>0 D
. . K INDXJ ; Subnodes: Smear Prep/Block
. . S NIENJ=""
. . F S NIENJ=$O(MAGOUT(SUBFJ(J),NIENJ)) Q:NIENJ="" D
. . . S:$P(NIENJ,",",2)=N INDXJ($P(NIENJ,",",1,2))=""
. . Q:'$D(INDXJ) ; Quit if no subnodes
. . S NJ=""
. . F S NJ=$O(INDXJ(NJ)) Q:NJ="" D
. . . S NIENJ=NJ_","_IEN
. . . S SMEAR=MAGOUT(SUBFJ(J),NIENJ,.01,"E")
. . . K INDXJK ; Sub-subnodes: Stain/Procedure/Slide
. . . S NIENJK=""
. . . F S NIENJK=$O(MAGOUT(SUBFK(J),NIENJK)) Q:NIENJK="" D
. . . . S:$P(NIENJK,",",2,3)=NJ INDXJK($P(NIENJK,",",1,3))=""
. . . Q:'$D(INDXJK) ; Quit if no sub-subnodes
. . . S NJK=""
. . . F S NJK=$O(INDXJK(NJK)) Q:NJK="" D
. . . . S NIENJK=NJK_","_IEN
. . . . S SLIDE=MAGOUT(SUBFK(J),NIENJK,.01,"E")
. . . . S SLIDE=SLIDE_U_MAGOUT(SUBFK(J),NIENJK,.02,"E")
. . . . S SLIDE=SLIDE_U_$TR($$FMTE^XLFDT(MAGOUT(SUBFK(J),NIENJK,.04,"I"),"5Z"),"@"," ")
. . . . S MAGRY(CT)=SPEC_U_SMEAR_U_SLIDE
. . . . S CT=CT+1
. . . . Q
. . . Q
. . Q
. ; If no slides for a specimen increase counter, output specimen only
. S LAST=$O(MAGRY(""),-1)
. S:$P(MAGRY(LAST),U,4)="" CT=CT+1
. Q
S MAGRY(0)="1^"_LAST_"^Specimen^Smear Prep^Stain/Procedure^# of Slides^Last Stain Date/Time"
Q ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGTP004 10191 printed Sep 23, 2025@19:44:56 Page 2
MAGTP004 ;WOIFO/FG,MLH - TELEPATHOLOGY RPCS ; 25 Jun 2013 3:30 PM
+1 ;;3.0;IMAGING;**138**;Mar 19, 2002;Build 5380;Sep 03, 2013
+2 ;; Per VHA Directive 2004-038, 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 ;
QUIT
+18 ;
+19 ;***** GET A LIST OF ALL UNRELEASED OR RELEASED REPORTS,
+20 ; FILTER BY BACK DAYS FOR UNRELEASED REPORTS,
+21 ; FILTER BY STATION NUMBER IF CONSULTATIONS ARE PRESENT FOR A CASE
+22 ; RPC: MAGTP GET ACTIVE
+23 ;
+24 ; .MAGRY Reference to a local or global variable where the results
+25 ; are returned to.
+26 ;
+27 ; FLAG Flag that controls execution:
+28 ;
+29 ; 0 Selects only unreleased reports.
+30 ;
+31 ; 1 Selected only released reports.
+32 ; One may go back in time by DAYS number
+33 ; of days (see next input)
+34 ;
+35 ; DAYS Number of days one may go back in time to
+36 ; retrieve data in case of released reports.
+37 ;
+38 ; STAT 1) If STATion ID is not null and in the Reading List
+39 ; in file (#2006.13) display the case if
+40 ; it has a consultation for an interpreting
+41 ; station number equal to STAT
+42 ; 2) If STAT is null, display all cases.
+43 ;
+44 ; Return Values
+45 ; =============
+46 ;
+47 ; If @MAGRY@(0) 1st '^'-piece is < 0, then an error
+48 ; occurred during execution of the procedure: [code]^^[error explanation]
+49 ;
+50 ; Otherwise, the output array is as follows:
+51 ;
+52 ; @MAGRY@(0) Description
+53 ; ^01: 0
+54 ; ^02: Total Number of Lines
+55 ; ^03: "Released Reports" or "Unreleased Reports"
+56 ;
+57 ; @MAGRY@(i) Description
+58 ; ^01: Case Number
+59 ; ^02: Reserved Entry (0/1 for Not Reserved/Reserved)
+60 ; ^03: Initials of who reserved the case in the LAB DATA file (#63)
+61 ; ^04: Patient's Name
+62 ; ^05: Patient's ID Number
+63 ; ^06: Priority
+64 ; ^07: Slide(s) Available
+65 ; ^08: Date/Time Specimen Taken
+66 ; ^09: Case Status
+67 ; ^10: Site Initials
+68 ; ^11: AP Section
+69 ; ^12: Year
+70 ; ^13: Accession Number
+71 ; ^14: ICN
+72 ; ^15: Specimen Count
+73 ; ^16: Reading Method
+74 ; ^17: Patient's Short ID
+75 ; ^18: Is there a Note? (Yes/No)
+76 ; ^19: Number of image(s)
+77 ; Notes
+78 ; =====
+79 ;
+80 ; The ^TMP("MAGTP",$J,"AC") global node is used by this procedure
+81 ; if the count (CT) gets too large (CT>100).
+82 ;
GETAC(MAGRY,FLAG,DAYS,STAT) ; RPC [MAGTP GET ACTIVE]
+1 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERRA^MAGUTERR"
+2 KILL MAGRY
+3 NEW SITE,MAGIEN,GBLRET,TYPE,SELFLAG
+4 ; Use indirection, work if an Array or a Global Array is returned
+5 SET GBLRET=0
+6 SET MAGRY="MAGRY"
+7 SET SELFLAG=0
+8 ;
+9 ; If STATion ID is passed, check that it is in
+10 ; the Reading List in file (#2006.13)
+11 ;
+12 IF $GET(STAT)]""
Begin DoDot:1
+13 ; Supported IA #2171 ; Site Number
SET SITE=$$IEN^XUAF4(STAT)
+14 IF SITE=""
SET @MAGRY@(0)="-3^^Invalid Site"
QUIT
+15 SET MAGIEN=$ORDER(^MAG(2006.13,1,5,"B",SITE,""))
+16 IF MAGIEN=""
SET @MAGRY@(0)="-2^^Site Not in Reading List"
QUIT
+17 ;
+18 ; Check type of Reading Site:
+19 ; If TYPE="CONSULTATION", select only the cases with their station number matching STAT
+20 ;
+21 SET TYPE=$$GET1^DIQ(2006.135,MAGIEN_",1,",.02)
+22 IF TYPE="CONSULTATION"
SET SELFLAG=1
+23 QUIT
End DoDot:1
if $DATA(@MAGRY@(0))=1
QUIT
+24 NEW CT,TODAY,REC,LRSS,YEAR,LRX,LRAA,LRAC
+25 NEW LRAN,LRSF,LRDFN,LRI,IEN,RDATE,RDADD
+26 NEW PNM,DFN,LRAC,OUTPUT,TEXT,ST,XDT,IN,XREC
+27 ; Default to unreleased
SET FLAG=$GET(FLAG,0)
+28 SET CT=0
+29 ; Present date for comparison
SET TODAY=+$$NOW^XLFDT
+30 ;; Search Accession/Case Worklist #2005.42 instead
+31 ;READ - Released, UNREAD - Un released
SET ST=$SELECT($GET(FLAG)=1:"R",1:"U")
+32 SET XDT=0
FOR
SET XDT=$ORDER(^MAG(2005.42,"C",ST,XDT))
if 'XDT
QUIT
Begin DoDot:1
+33 SET IN=0
FOR
SET IN=$ORDER(^MAG(2005.42,"C",ST,XDT,IN))
if 'IN
QUIT
Begin DoDot:2
+34 SET XREC=$GET(^MAG(2005.42,IN,0))
SET LRAC=$PIECE(XREC,U)
if LRAC=""
QUIT
+35 SET LRSS=$PIECE(LRAC," ")
+36 SET LRSF=$SELECT(LRSS="CY":63.09,LRSS="EM":63.02,1:63.08)
+37 SET YEAR=DT\10000*10000
SET LRAA=$ORDER(^LRO(68,"B",LRSS,0))
+38 SET LRAN=+$PIECE(LRAC," ",3)
if 'LRAN
QUIT
+39 SET LRDFN=$PIECE($GET(^LRO(68,LRAA,1,YEAR,1,LRAN,0)),"^",1)
if 'LRDFN
QUIT
+40 SET LRI=$PIECE($GET(^LRO(68,LRAA,1,YEAR,1,LRAN,3)),"^",5)
if 'LRI
QUIT
+41 SET IEN=LRI_","_LRDFN_","
+42 ; Skip bad entries
if '$$GET1^DIQ(LRSF,IEN,.01,"I")
QUIT
+43 ; Release date if any
SET RDATE=+$$GET1^DIQ(LRSF,IEN,.11,"I")
+44 ; Unreleased/Released selection
if $SELECT(RDATE
QUIT
+45 IF FLAG
Begin DoDot:3
+46 ; Released only for last DAYS, default 90
SET DAYS=$GET(DAYS,90)
+47 ; Calculate Release Date + DAYS
SET RDADD=$$FMADD^XLFDT(RDATE,DAYS)
+48 QUIT
End DoDot:3
if (TODAY>RDADD)
QUIT
+49 ; Quit if no consultations for that case and site
IF SELFLAG
if '$$ISCONSLT^MAGTP009(LRAC,SITE)
QUIT
+50 SET PNM=$$GET1^DIQ(63,LRDFN_",",".03")
+51 SET DFN=$$GET1^DIQ(63,LRDFN_",",".03","I")
+52 ;#2005.42 ien
SET REC=IN
+53 ;OUTPUT contains pieces ^02:^17 defined above in the @MAGRY@(i) description
+54 SET OUTPUT=$$GETCASE^MAGTP009(LRSS,LRAC,LRSF,IEN,REC,FLAG,PNM,DFN)
+55 SET CT=CT+1
+56 IF (CT>100)
IF 'GBLRET
Begin DoDot:3
+57 DO ARY2GLB^MAGTP009(.MAGRY)
+58 SET GBLRET=1
+59 QUIT
End DoDot:3
+60 SET @MAGRY@(CT)=LRAC_U_OUTPUT
+61 QUIT
End DoDot:2
+62 QUIT
End DoDot:1
+63 ; Worklist Header
+64 SET TEXT=$SELECT(FLAG:"Released Reports",1:"Unreleased Reports")
+65 SET @MAGRY@(0)="0^"_CT_U_TEXT
+66 ;end GETAC
QUIT
+67 ;
+68 ;***** GET SPECIMEN, SMEAR/PREP/BLOCK AND STAIN/PROCEDURE/SLIDE
+69 ; INFO FOR A SPECIFIED CASE
+70 ; RPC: MAGTP GET SLIDES
+71 ;
+72 ; .MAGRY Reference to a local variable where the results
+73 ; are returned to.
+74 ;
+75 ; LRSS AP Section
+76 ;
+77 ; YEAR Accession Year (Two figures)
+78 ;
+79 ; LRAN Accession Number
+80 ;
+81 ; Return Values
+82 ; =============
+83 ;
+84 ; If MAGRY(0) 1st '^'-piece is 0, then an error
+85 ; occurred during execution of the procedure: 0^0^ ERROR explanation
+86 ;
+87 ; Otherwise, the output array is as follows:
+88 ;
+89 ; MAGRY(0) Description
+90 ; ^01: 1
+91 ; ^02: Total Number of Lines
+92 ; ^03: "Specimen"
+93 ; ^04: "Smear Prep"
+94 ; ^05: "Stain/Procedure"
+95 ; ^06: "# of Slides"
+96 ; ^07: "Last Stain Date"
+97 ;
+98 ; MAGRY(i) Description
+99 ; ^01: Specimen
+100 ; ^02: Smear Prep/Block Name
+101 ; ^03: Stain/Procedure/Slide Name
+102 ; ^04: Number of Stains/Procedures/Slides
+103 ; ^05: Date of Entry of the Last Stain/Procedure/Slide
+104 ;
GETSD(MAGRY,LRSS,YEAR,LRAN) ; RPC [MAGTP GET SLIDES]
+1 KILL MAGRY
+2 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERRA^MAGGTERR"
+3 NEW INPUT
+4 SET INPUT=$$CONTEXT^MAGTP006(.MAGRY,LRSS,YEAR,LRAN)
if 'MAGRY(0)
QUIT
+5 NEW MAGOUT,MAGERR
+6 NEW LRSF,IEN,SUBF,NIEN,CT,N,SPEC
+7 NEW J,NIENJ,NJ,START,SMEAR,SUBFJ,SUBFK
+8 NEW NIENJK,NJK,SLIDE,INDX,INDXJ,INDXJK,LAST
+9 SET LRSF=$PIECE(INPUT,",")
SET IEN=$PIECE(INPUT,",",2,4)
+10 ; Get all info for specimen(s), then sort through it
+11 DO GETS^DIQ(LRSF,IEN,".012*","IE","MAGOUT","MAGERR")
+12 IF $DATA(MAGERR)
SET MAGRY(0)="0^0^Access Error: "_MAGERR("DIERR",1,"TEXT",1)
QUIT
+13 ; Subfields of Specimen
SET SUBF=+$$GET1^DID(LRSF,.012,"","SPECIFIER")
+14 SET START=$ORDER(^DD(SUBF,1),-1)
SET J=START
+15 ;
+16 ; Extract subfields, sub-subfields
+17 ;
+18 FOR
SET J=$ORDER(^DD(SUBF,J))
if J'>0
QUIT
Begin DoDot:1
+19 SET SUBFJ(J)=+$$GET1^DID(SUBF,J_",","","SPECIFIER")
+20 SET SUBFK(J)=+$$GET1^DID(SUBFJ(J),"1,","","SPECIFIER")
+21 QUIT
End DoDot:1
+22 ;
+23 ; NIEN may be ordered incorrectly, set index
+24 ;
+25 SET NIEN=""
+26 FOR
SET NIEN=$ORDER(MAGOUT(SUBF,NIEN))
if NIEN=""
QUIT
Begin DoDot:1
+27 SET INDX($PIECE(NIEN,","))=""
End DoDot:1
+28 SET CT=1
SET N=""
+29 FOR
SET N=$ORDER(INDX(N))
if N=""
QUIT
Begin DoDot:1
+30 SET NIEN=N_","_IEN
+31 SET SPEC=MAGOUT(SUBF,NIEN,.01,"E")
+32 ; Record specimen
SET MAGRY(CT)=SPEC
+33 SET J=START
+34 FOR
SET J=$ORDER(^DD(SUBF,J))
if J'>0
QUIT
Begin DoDot:2
+35 ; Subnodes: Smear Prep/Block
KILL INDXJ
+36 SET NIENJ=""
+37 FOR
SET NIENJ=$ORDER(MAGOUT(SUBFJ(J),NIENJ))
if NIENJ=""
QUIT
Begin DoDot:3
+38 if $PIECE(NIENJ,",",2)=N
SET INDXJ($PIECE(NIENJ,",",1,2))=""
End DoDot:3
+39 ; Quit if no subnodes
if '$DATA(INDXJ)
QUIT
+40 SET NJ=""
+41 FOR
SET NJ=$ORDER(INDXJ(NJ))
if NJ=""
QUIT
Begin DoDot:3
+42 SET NIENJ=NJ_","_IEN
+43 SET SMEAR=MAGOUT(SUBFJ(J),NIENJ,.01,"E")
+44 ; Sub-subnodes: Stain/Procedure/Slide
KILL INDXJK
+45 SET NIENJK=""
+46 FOR
SET NIENJK=$ORDER(MAGOUT(SUBFK(J),NIENJK))
if NIENJK=""
QUIT
Begin DoDot:4
+47 if $PIECE(NIENJK,",",2,3)=NJ
SET INDXJK($PIECE(NIENJK,",",1,3))=""
End DoDot:4
+48 ; Quit if no sub-subnodes
if '$DATA(INDXJK)
QUIT
+49 SET NJK=""
+50 FOR
SET NJK=$ORDER(INDXJK(NJK))
if NJK=""
QUIT
Begin DoDot:4
+51 SET NIENJK=NJK_","_IEN
+52 SET SLIDE=MAGOUT(SUBFK(J),NIENJK,.01,"E")
+53 SET SLIDE=SLIDE_U_MAGOUT(SUBFK(J),NIENJK,.02,"E")
+54 SET SLIDE=SLIDE_U_$TRANSLATE($$FMTE^XLFDT(MAGOUT(SUBFK(J),NIENJK,.04,"I"),"5Z"),"@"," ")
+55 SET MAGRY(CT)=SPEC_U_SMEAR_U_SLIDE
+56 SET CT=CT+1
+57 QUIT
End DoDot:4
+58 QUIT
End DoDot:3
+59 QUIT
End DoDot:2
+60 ; If no slides for a specimen increase counter, output specimen only
+61 SET LAST=$ORDER(MAGRY(""),-1)
+62 if $PIECE(MAGRY(LAST),U,4)=""
SET CT=CT+1
+63 QUIT
End DoDot:1
+64 SET MAGRY(0)="1^"_LAST_"^Specimen^Smear Prep^Stain/Procedure^# of Slides^Last Stain Date/Time"
+65 ;
QUIT
+66 ;
