- MAGDQR09 ;WOIFO/EDM,MLH,NST,BT,PMK - Imaging RPCs for Query/Retrieve ; Feb 15, 2022@10:26:14
- ;;3.0;IMAGING;**118,305**;Mar 19, 2002;Build 3
- ;; 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
- ; Overflows from MAGDQR03
- Q020000D(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;U Study Instance UID
- ; sensitive/employee?
- I SENSEMP D Q ; yes, scrub
- . S V(T)="1.2.840.113754.2.1.3.1.1.66."_$G(^TMP("MAG",$J,"DICOMQR","DUMMY SIUID"))
- . Q
- ; no
- S V(T)="" Q:'MAGIEN
- D ; retrieve from old or new DB?
- . N PARENT
- . I TYPE'="N" D Q
- . . N PARENT
- . . S PARENT=$P($G(^MAG(2005,MAGIEN,0)),"^",10)
- . . S:'PARENT PARENT=MAGIEN
- . . S V(T)=$P($G(^MAG(2005,PARENT,"PACS")),"^",1)
- . . Q
- . I TYPE="N" D Q
- . . S PARENT=$P($G(^MAGV(2005.64,MAGIEN,6)),"^",1) I 'PARENT Q
- . . S PARENT=$P($G(^MAGV(2005.63,PARENT,6)),"^",1) I 'PARENT Q
- . . S V(T)=$P($G(^MAGV(2005.62,PARENT,0)),"^",1)
- . . Q
- . Q
- Q
- ;
- Q020000E(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;U Series Instance UID
- ; sensitive/employee?
- I SENSEMP D Q ; yes, scrub
- . S V(T)="1.2.840.113754.2.1.3.1.1.1.66."_$G(^TMP("MAG",$J,"DICOMQR","DUMMY SIUID"))
- . Q
- ; no
- D ; retrieve from old or new DB?
- . N PARENT
- . I TYPE'="N" D Q
- . . I MAGIEN="" S V(T)="" Q
- . . S V(T)=$P($G(^MAG(2005,MAGIEN,"SERIESUID")),"^",1)
- . . Q
- . I TYPE="N" D Q
- . . S PARENT=$P($G(^MAGV(2005.64,MAGIEN,6)),"^",1) I 'PARENT Q
- . . S V(T)=$P($G(^MAGV(2005.63,PARENT,0)),"^",1)
- . . Q
- . Q
- Q
- ;
- Q0080061(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;O Modalities in Study
- ; sensitive/employee?
- I SENSEMP D Q ; yes, scrub
- . N I
- . S I=$O(REQ(T,""))
- . S V(T)="OT" I I,$G(REQ(T,I))]"" S V(T)=REQ(T,I)
- . Q
- ; no
- N ANY,I1,I2,LIST,MOD,P1,P2,R,TMP,PARENT,I,X
- I MAGIEN="" S V(T)="" Q
- ;
- S I1="" F S I1=$O(REQ(T,I1)) Q:I1="" D
- . S R=$TR(REQ(T,I1),"/","\")
- . F I2=1:1:$L(R,"\") S X=$P(R,"\",I2) S:X'="" LIST(X)=1
- . Q
- ;
- ; select based on old/new DB
- I TYPE="N" D NSTYMOD(MAGIEN,.MOD)
- I (TYPE="C")!(TYPE="R") D STYMOD(MAGIEN,.MOD)
- ;
- ; return only the requested Modalities
- S R="",ANY=0,X=""
- F S X=$O(MOD(X)) Q:X="" D
- . D ; filter out consult-related noise
- . . Q:$E(X,1,7)="CONSULT" Q:X="CON/PROC"
- . . S:R'="" R=R_"," S R=R_X
- . . Q
- . I $O(LIST(""))="" S ANY=1 Q
- . S I1="" F S I1=$O(LIST(I1)) Q:I1="" D Q:ANY
- . . S:$$MATCHD^MAGDQR03(X,"LIST(LOOP)","TMP(LOOP)") ANY=1
- . . Q
- . Q
- S V(T)=R
- I 'ANY,$D(LIST) S OK=0 ; no matches
- Q
- ;
- ;given MAGIEN, save all study's modalities (New DB) to MOD array
- NSTYMOD(MAGIEN,MOD) ;
- N SERREF,STYREF,D0,MODS,I,MODITEM
- S SERREF=$P($G(^MAGV(2005.64,MAGIEN,6)),"^",1) I 'SERREF Q
- S STYREF=$P($G(^MAGV(2005.63,SERREF,6)),"^",1) I 'STYREF Q
- S D0=0
- F S D0=$O(^MAGV(2005.63,"C",STYREF,D0)) Q:'D0 D
- . S MODS=$P($G(^MAGV(2005.63,D0,1)),"^",1)
- . F I=1:1:$L(MODS,"/") S MODITEM=$P(MODS,"/",I) S:$L(MODITEM) MOD(MODITEM)=""
- Q
- ;
- ;given MAGIEN, save all study's modalities (Old/legacy DB) to MOD array
- STYMOD(MAGIEN,MOD) ;
- N STUDYUID,X,R,P1,P2
- S STUDYUID=$P($G(^MAG(2005,MAGIEN,"PACS")),"^",1) Q:STUDYUID=""
- S MAGIEN=0
- F S MAGIEN=$O(^MAG(2005,"P",STUDYUID,MAGIEN)) Q:'MAGIEN D
- . S X=$P($G(^MAG(2005,MAGIEN,0)),"^",8)
- . S:$E(X,1,4)="RAD " X=$E(X,5,$L(X))
- . S:X'="" MOD(X)=""
- . S R="",P1=0
- . F S P1=$O(^MAG(2005,MAGIEN,1,P1)) Q:'P1 D
- . . S P2=+$G(^MAG(2005,MAGIEN,1,P1,0)) Q:'P2
- . . S X=$P($G(^MAG(2005,P2,0)),"^",8)
- . . S:$E(X,1,4)="RAD " X=$E(X,5,$L(X))
- . . S:X'="" MOD(X)=""
- . . Q
- . Q
- Q
- ;
- Q0201206(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;O Number of Study Related Series
- ; sensitive/employee?
- I $G(SENSEMP) D Q ; yes, scrub
- . N I S I=$O(REQ(T,"")) S:I V(T)=$S($G(REQ(T,I))]"":REQ(T,I),1:"")
- . Q
- ; no
- N N,S,UID
- S UID=$G(V("0020,000D")),N=0
- D:UID'="" ; select based on old/new type
- . I TYPE="N" D Q ; new P34 DB
- . . N STYIX,SERIX
- . . S STYIX=0
- . . F S STYIX=$O(^MAGV(2005.62,"B",UID,STYIX)) Q:STYIX="" D
- . . . I $$PROBLEM62^MAGDSTA8(STYIX) Q ; P305 PMK 12/06/2021
- . . . ; Q:$P($G(^MAGV(2005.62,STYIX,5)),"^",2)'="A" ; inaccessible status
- . . . S SERIX=0
- . . . F S SERIX=$O(^MAGV(2005.63,"C",STYIX,SERIX)) Q:'SERIX D
- . . . . I $$PROBLEM63^MAGDSTA8(SERIX) Q ; P305 PMK 12/06/2021
- . . . . ; S:$P($G(^MAGV(2005.63,SERIX,9)),"^",1)="A" N=N+1 ; accessible status
- . . . . S N=N+1
- . . . . Q
- . . . Q
- . . Q
- . I (TYPE="R")!(TYPE="C") D Q ; legacy DB
- . . S S="" F S S=$O(^MAG(2005,"P",UID,S)) Q:S="" S N=N+1
- . . Q
- . Q
- S V(T)=N
- S:'$$COMPARE^MAGDQR03(T,V(T)) OK=0
- Q
- ;
- Q0201208(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;O Number of Study Related Instances
- ; sensitive/employee?
- I $G(SENSEMP) D Q ; yes, scrub
- . N I S I=$O(REQ(T,"")) S:I V(T)=$S($G(REQ(T,I))]"":REQ(T,I),1:"")
- . Q
- ; no
- N N,P1,P2,S,UID
- S UID=$G(V("0020,000D")),N=0
- D:UID'="" ; select based on old / new type
- . I TYPE="N" D Q
- . . N STYIX,SERIX,SOPIX
- . . S STYIX=0
- . . F S STYIX=$O(^MAGV(2005.62,"B",UID,STYIX)) Q:STYIX="" D
- . . . I $$PROBLEM62^MAGDSTA8(STYIX) Q ; P305 PMK 12/06/2021
- . . . ; Q:$P($G(^MAGV(2005.62,STYIX,5)),"^",2)'="A" ; inaccessible status
- . . . S SERIX=0
- . . . F S SERIX=$O(^MAGV(2005.63,"C",STYIX,SERIX)) Q:'SERIX D
- . . . . I $$PROBLEM63^MAGDSTA8(SERIX) Q ; P305 PMK 12/06/2021
- . . . . ; Q:$P($G(^MAGV(2005.63,SERIX,9)),"^",1)'="A" ; inaccessible status
- . . . . S SOPIX=0
- . . . . F S SOPIX=$O(^MAGV(2005.64,"C",SERIX,SOPIX)) Q:'SOPIX D
- . . . . . I $$PROBLEM64^MAGDSTA8(SOPIX) Q ; P305 PMK 12/06/2021
- . . . . . ; S:$P($G(^MAGV(2005.64,SOPIX,11)),"^",1)="A" N=N+1 ; accessible status
- . . . . . S N=N+1
- . . . . . Q
- . . . . Q
- . . . Q
- . . Q
- . I (TYPE="R")!(TYPE="C") D Q
- . . S S="" F S S=$O(^MAG(2005,"P",UID,S)) Q:S="" D
- . . . S P1=0 F S P1=$O(^MAG(2005,S,1,P1)) Q:'P1 D
- . . . . S P2=+$G(^MAG(2005,S,1,P1,0)) Q:'P2
- . . . . S N=N+1
- . . . . Q
- . . . Q
- . . Q
- . Q
- S V(T)=N
- S:'$$COMPARE^MAGDQR03(T,V(T)) OK=0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDQR09 6998 printed Jan 18, 2025@03:02:09 Page 2
- MAGDQR09 ;WOIFO/EDM,MLH,NST,BT,PMK - Imaging RPCs for Query/Retrieve ; Feb 15, 2022@10:26:14
- +1 ;;3.0;IMAGING;**118,305**;Mar 19, 2002;Build 3
- +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 ; Overflows from MAGDQR03
- Q020000D(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;U Study Instance UID
- +1 ; sensitive/employee?
- +2 ; yes, scrub
- IF SENSEMP
- Begin DoDot:1
- +3 SET V(T)="1.2.840.113754.2.1.3.1.1.66."_$GET(^TMP("MAG",$JOB,"DICOMQR","DUMMY SIUID"))
- +4 QUIT
- End DoDot:1
- QUIT
- +5 ; no
- +6 SET V(T)=""
- if 'MAGIEN
- QUIT
- +7 ; retrieve from old or new DB?
- Begin DoDot:1
- +8 NEW PARENT
- +9 IF TYPE'="N"
- Begin DoDot:2
- +10 NEW PARENT
- +11 SET PARENT=$PIECE($GET(^MAG(2005,MAGIEN,0)),"^",10)
- +12 if 'PARENT
- SET PARENT=MAGIEN
- +13 SET V(T)=$PIECE($GET(^MAG(2005,PARENT,"PACS")),"^",1)
- +14 QUIT
- End DoDot:2
- QUIT
- +15 IF TYPE="N"
- Begin DoDot:2
- +16 SET PARENT=$PIECE($GET(^MAGV(2005.64,MAGIEN,6)),"^",1)
- IF 'PARENT
- QUIT
- +17 SET PARENT=$PIECE($GET(^MAGV(2005.63,PARENT,6)),"^",1)
- IF 'PARENT
- QUIT
- +18 SET V(T)=$PIECE($GET(^MAGV(2005.62,PARENT,0)),"^",1)
- +19 QUIT
- End DoDot:2
- QUIT
- +20 QUIT
- End DoDot:1
- +21 QUIT
- +22 ;
- Q020000E(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;U Series Instance UID
- +1 ; sensitive/employee?
- +2 ; yes, scrub
- IF SENSEMP
- Begin DoDot:1
- +3 SET V(T)="1.2.840.113754.2.1.3.1.1.1.66."_$GET(^TMP("MAG",$JOB,"DICOMQR","DUMMY SIUID"))
- +4 QUIT
- End DoDot:1
- QUIT
- +5 ; no
- +6 ; retrieve from old or new DB?
- Begin DoDot:1
- +7 NEW PARENT
- +8 IF TYPE'="N"
- Begin DoDot:2
- +9 IF MAGIEN=""
- SET V(T)=""
- QUIT
- +10 SET V(T)=$PIECE($GET(^MAG(2005,MAGIEN,"SERIESUID")),"^",1)
- +11 QUIT
- End DoDot:2
- QUIT
- +12 IF TYPE="N"
- Begin DoDot:2
- +13 SET PARENT=$PIECE($GET(^MAGV(2005.64,MAGIEN,6)),"^",1)
- IF 'PARENT
- QUIT
- +14 SET V(T)=$PIECE($GET(^MAGV(2005.63,PARENT,0)),"^",1)
- +15 QUIT
- End DoDot:2
- QUIT
- +16 QUIT
- End DoDot:1
- +17 QUIT
- +18 ;
- Q0080061(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;O Modalities in Study
- +1 ; sensitive/employee?
- +2 ; yes, scrub
- IF SENSEMP
- Begin DoDot:1
- +3 NEW I
- +4 SET I=$ORDER(REQ(T,""))
- +5 SET V(T)="OT"
- IF I
- IF $GET(REQ(T,I))]""
- SET V(T)=REQ(T,I)
- +6 QUIT
- End DoDot:1
- QUIT
- +7 ; no
- +8 NEW ANY,I1,I2,LIST,MOD,P1,P2,R,TMP,PARENT,I,X
- +9 IF MAGIEN=""
- SET V(T)=""
- QUIT
- +10 ;
- +11 SET I1=""
- FOR
- SET I1=$ORDER(REQ(T,I1))
- if I1=""
- QUIT
- Begin DoDot:1
- +12 SET R=$TRANSLATE(REQ(T,I1),"/","\")
- +13 FOR I2=1:1:$LENGTH(R,"\")
- SET X=$PIECE(R,"\",I2)
- if X'=""
- SET LIST(X)=1
- +14 QUIT
- End DoDot:1
- +15 ;
- +16 ; select based on old/new DB
- +17 IF TYPE="N"
- DO NSTYMOD(MAGIEN,.MOD)
- +18 IF (TYPE="C")!(TYPE="R")
- DO STYMOD(MAGIEN,.MOD)
- +19 ;
- +20 ; return only the requested Modalities
- +21 SET R=""
- SET ANY=0
- SET X=""
- +22 FOR
- SET X=$ORDER(MOD(X))
- if X=""
- QUIT
- Begin DoDot:1
- +23 ; filter out consult-related noise
- Begin DoDot:2
- +24 if $EXTRACT(X,1,7)="CONSULT"
- QUIT
- if X="CON/PROC"
- QUIT
- +25 if R'=""
- SET R=R_","
- SET R=R_X
- +26 QUIT
- End DoDot:2
- +27 IF $ORDER(LIST(""))=""
- SET ANY=1
- QUIT
- +28 SET I1=""
- FOR
- SET I1=$ORDER(LIST(I1))
- if I1=""
- QUIT
- Begin DoDot:2
- +29 if $$MATCHD^MAGDQR03(X,"LIST(LOOP)","TMP(LOOP)")
- SET ANY=1
- +30 QUIT
- End DoDot:2
- if ANY
- QUIT
- +31 QUIT
- End DoDot:1
- +32 SET V(T)=R
- +33 ; no matches
- IF 'ANY
- IF $DATA(LIST)
- SET OK=0
- +34 QUIT
- +35 ;
- +36 ;given MAGIEN, save all study's modalities (New DB) to MOD array
- NSTYMOD(MAGIEN,MOD) ;
- +1 NEW SERREF,STYREF,D0,MODS,I,MODITEM
- +2 SET SERREF=$PIECE($GET(^MAGV(2005.64,MAGIEN,6)),"^",1)
- IF 'SERREF
- QUIT
- +3 SET STYREF=$PIECE($GET(^MAGV(2005.63,SERREF,6)),"^",1)
- IF 'STYREF
- QUIT
- +4 SET D0=0
- +5 FOR
- SET D0=$ORDER(^MAGV(2005.63,"C",STYREF,D0))
- if 'D0
- QUIT
- Begin DoDot:1
- +6 SET MODS=$PIECE($GET(^MAGV(2005.63,D0,1)),"^",1)
- +7 FOR I=1:1:$LENGTH(MODS,"/")
- SET MODITEM=$PIECE(MODS,"/",I)
- if $LENGTH(MODITEM)
- SET MOD(MODITEM)=""
- End DoDot:1
- +8 QUIT
- +9 ;
- +10 ;given MAGIEN, save all study's modalities (Old/legacy DB) to MOD array
- STYMOD(MAGIEN,MOD) ;
- +1 NEW STUDYUID,X,R,P1,P2
- +2 SET STUDYUID=$PIECE($GET(^MAG(2005,MAGIEN,"PACS")),"^",1)
- if STUDYUID=""
- QUIT
- +3 SET MAGIEN=0
- +4 FOR
- SET MAGIEN=$ORDER(^MAG(2005,"P",STUDYUID,MAGIEN))
- if 'MAGIEN
- QUIT
- Begin DoDot:1
- +5 SET X=$PIECE($GET(^MAG(2005,MAGIEN,0)),"^",8)
- +6 if $EXTRACT(X,1,4)="RAD "
- SET X=$EXTRACT(X,5,$LENGTH(X))
- +7 if X'=""
- SET MOD(X)=""
- +8 SET R=""
- SET P1=0
- +9 FOR
- SET P1=$ORDER(^MAG(2005,MAGIEN,1,P1))
- if 'P1
- QUIT
- Begin DoDot:2
- +10 SET P2=+$GET(^MAG(2005,MAGIEN,1,P1,0))
- if 'P2
- QUIT
- +11 SET X=$PIECE($GET(^MAG(2005,P2,0)),"^",8)
- +12 if $EXTRACT(X,1,4)="RAD "
- SET X=$EXTRACT(X,5,$LENGTH(X))
- +13 if X'=""
- SET MOD(X)=""
- +14 QUIT
- End DoDot:2
- +15 QUIT
- End DoDot:1
- +16 QUIT
- +17 ;
- Q0201206(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;O Number of Study Related Series
- +1 ; sensitive/employee?
- +2 ; yes, scrub
- IF $GET(SENSEMP)
- Begin DoDot:1
- +3 NEW I
- SET I=$ORDER(REQ(T,""))
- if I
- SET V(T)=$SELECT($GET(REQ(T,I))]"":REQ(T,I),1:"")
- +4 QUIT
- End DoDot:1
- QUIT
- +5 ; no
- +6 NEW N,S,UID
- +7 SET UID=$GET(V("0020,000D"))
- SET N=0
- +8 ; select based on old/new type
- if UID'=""
- Begin DoDot:1
- +9 ; new P34 DB
- IF TYPE="N"
- Begin DoDot:2
- +10 NEW STYIX,SERIX
- +11 SET STYIX=0
- +12 FOR
- SET STYIX=$ORDER(^MAGV(2005.62,"B",UID,STYIX))
- if STYIX=""
- QUIT
- Begin DoDot:3
- +13 ; P305 PMK 12/06/2021
- IF $$PROBLEM62^MAGDSTA8(STYIX)
- QUIT
- +14 ; Q:$P($G(^MAGV(2005.62,STYIX,5)),"^",2)'="A" ; inaccessible status
- +15 SET SERIX=0
- +16 FOR
- SET SERIX=$ORDER(^MAGV(2005.63,"C",STYIX,SERIX))
- if 'SERIX
- QUIT
- Begin DoDot:4
- +17 ; P305 PMK 12/06/2021
- IF $$PROBLEM63^MAGDSTA8(SERIX)
- QUIT
- +18 ; S:$P($G(^MAGV(2005.63,SERIX,9)),"^",1)="A" N=N+1 ; accessible status
- +19 SET N=N+1
- +20 QUIT
- End DoDot:4
- +21 QUIT
- End DoDot:3
- +22 QUIT
- End DoDot:2
- QUIT
- +23 ; legacy DB
- IF (TYPE="R")!(TYPE="C")
- Begin DoDot:2
- +24 SET S=""
- FOR
- SET S=$ORDER(^MAG(2005,"P",UID,S))
- if S=""
- QUIT
- SET N=N+1
- +25 QUIT
- End DoDot:2
- QUIT
- +26 QUIT
- End DoDot:1
- +27 SET V(T)=N
- +28 if '$$COMPARE^MAGDQR03(T,V(T))
- SET OK=0
- +29 QUIT
- +30 ;
- Q0201208(TYPE,REQ,V,T,MAGDFN,MAGIEN,MAGRORD,MAGINTERP,SENSEMP,OK) ;O Number of Study Related Instances
- +1 ; sensitive/employee?
- +2 ; yes, scrub
- IF $GET(SENSEMP)
- Begin DoDot:1
- +3 NEW I
- SET I=$ORDER(REQ(T,""))
- if I
- SET V(T)=$SELECT($GET(REQ(T,I))]"":REQ(T,I),1:"")
- +4 QUIT
- End DoDot:1
- QUIT
- +5 ; no
- +6 NEW N,P1,P2,S,UID
- +7 SET UID=$GET(V("0020,000D"))
- SET N=0
- +8 ; select based on old / new type
- if UID'=""
- Begin DoDot:1
- +9 IF TYPE="N"
- Begin DoDot:2
- +10 NEW STYIX,SERIX,SOPIX
- +11 SET STYIX=0
- +12 FOR
- SET STYIX=$ORDER(^MAGV(2005.62,"B",UID,STYIX))
- if STYIX=""
- QUIT
- Begin DoDot:3
- +13 ; P305 PMK 12/06/2021
- IF $$PROBLEM62^MAGDSTA8(STYIX)
- QUIT
- +14 ; Q:$P($G(^MAGV(2005.62,STYIX,5)),"^",2)'="A" ; inaccessible status
- +15 SET SERIX=0
- +16 FOR
- SET SERIX=$ORDER(^MAGV(2005.63,"C",STYIX,SERIX))
- if 'SERIX
- QUIT
- Begin DoDot:4
- +17 ; P305 PMK 12/06/2021
- IF $$PROBLEM63^MAGDSTA8(SERIX)
- QUIT
- +18 ; Q:$P($G(^MAGV(2005.63,SERIX,9)),"^",1)'="A" ; inaccessible status
- +19 SET SOPIX=0
- +20 FOR
- SET SOPIX=$ORDER(^MAGV(2005.64,"C",SERIX,SOPIX))
- if 'SOPIX
- QUIT
- Begin DoDot:5
- +21 ; P305 PMK 12/06/2021
- IF $$PROBLEM64^MAGDSTA8(SOPIX)
- QUIT
- +22 ; S:$P($G(^MAGV(2005.64,SOPIX,11)),"^",1)="A" N=N+1 ; accessible status
- +23 SET N=N+1
- +24 QUIT
- End DoDot:5
- +25 QUIT
- End DoDot:4
- +26 QUIT
- End DoDot:3
- +27 QUIT
- End DoDot:2
- QUIT
- +28 IF (TYPE="R")!(TYPE="C")
- Begin DoDot:2
- +29 SET S=""
- FOR
- SET S=$ORDER(^MAG(2005,"P",UID,S))
- if S=""
- QUIT
- Begin DoDot:3
- +30 SET P1=0
- FOR
- SET P1=$ORDER(^MAG(2005,S,1,P1))
- if 'P1
- QUIT
- Begin DoDot:4
- +31 SET P2=+$GET(^MAG(2005,S,1,P1,0))
- if 'P2
- QUIT
- +32 SET N=N+1
- +33 QUIT
- End DoDot:4
- +34 QUIT
- End DoDot:3
- +35 QUIT
- End DoDot:2
- QUIT
- +36 QUIT
- End DoDot:1
- +37 SET V(T)=N
- +38 if '$$COMPARE^MAGDQR03(T,V(T))
- SET OK=0
- +39 QUIT