MAGQE3 ;WOIFO/RMP - Support for MAG Enterprise ; 25 Jun 2012 4:20 PM
;;3.0;IMAGING;**27,29,30,20,46,135**;Mar 19, 2002;Build 5238;Jul 17, 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
;
COUNT(SDATE,EDATE,INST,AI,IQ,DUP,TIOP,TGPP,TIEDP,GRPPRNT,IMAGE,DELETED) ;
N CLIN,CONSENTS,CPTR,D0,DAT,DICOM,DOC,DOCGRP,DOCUMENT,ED0,I,IMPORT
N NAME,OTHER,PCE,PROC,SD0,TRK,ZNODE,CNODE
S SD0=$$SDATE^MAGQE1(SDATE,"F")
S ED0=$$SDATE^MAGQE1(EDATE,"R")
S D0="" F S D0=$O(^MAG(2005.02,"B","DOCUMENT",D0)) Q:D0="" D
. S:$G(^MAG(2005.02,D0,4))["TIF" DOC(D0)=""
. Q
S (CONSENTS,GRPPRNT,IMAGE,DELETED,DOCGRP,DOCUMENT,DUP,TIOP,TGPP,TIEDP)=0
S IQ="0^0^0"
S CPTR=$O(^MAG(2005.83,"B","CONSENT",""))
S D0=SD0 F S D0=$O(^MAG(2005,D0)) Q:'D0 Q:D0'<ED0 D
. S CNODE=$G(^MAG(2005,D0,100))
. S PCE=$P(CNODE,"^",3) Q:((PCE'=INST)&(AI'[("^"_PCE_"^")))
. S ZNODE=$G(^MAG(2005,D0,0))
. I $P(ZNODE,"^",2)="" S TGPP=TGPP+1 ;TOTAL FILE WIDE by Place
. E D
. . S TIOP=TIOP+1
. . S:($P(ZNODE,U,11)="") $P(IQ,U,1)=$P(IQ,U,1)+1
. . S:($P(ZNODE,U,11)="0") $P(IQ,U,2)=$P(IQ,U,2)+1
. . S:($P(ZNODE,U,11)="1") $P(IQ,U,3)=$P(IQ,U,3)+1
. . Q
. S X=$P($G(^MAG(2005,D0,2)),"^",1)\1 Q:'X Q:X<SDATE Q:X>EDATE
. S:$P(ZNODE,U,12) DUP=DUP+1
. S PCE=$P(CNODE,"^",5),TRK="" I PCE'="" D
. . S TRK=$P($G(^MAG(2006.04,$P(CNODE,U,4),0)),U)
. . S TRK=$S(TRK'="":TRK,1:"?") Q
. I $P(ZNODE,"^",2)="" D Q
. . S GRPPRNT=GRPPRNT+1
. . S PCE=$P(ZNODE,"^",8) S:PCE="" PCE="NIL"
. . S:$D(^MAG(2005,D0,"PACS")) DICOM(PCE,0)=$G(DICOM(PCE,0))+1
. . S PCE=$P(ZNODE,"^",6) I PCE,$D(DOC(PCE)) S DOCGRP=DOCGRP+1
. . S:TRK'="" IMPORT(TRK,0)=$G(IMPORT(TRK,0))+1
. . Q
. S:TRK'="" IMPORT(TRK)=$G(IMPORT(TRK))+1
. I CPTR,$P($G(^MAG(2005,D0,40)),"^",3)=CPTR S CONSENTS=CONSENTS+1
. E S PCE=$$UPPER^MAGQE4($P($G(^MAG(2005,D0,2)),"^",4)) S:PCE["CONSENT" OTHER(PCE)=$G(OTHER(PCE))+1
. S IMAGE=IMAGE+1
. S PCE=$P(ZNODE,"^",6) I PCE,$D(DOC(PCE)) S DOCUMENT=DOCUMENT+1
. S PCE=$P(ZNODE,"^",7) S:PCE="" PCE="NIL"
. S ^TMP($J,"MAGQ","ACQPAT",PCE)=""
. S ^TMP($J,"MAGQ","ALLPAT",PCE)=""
. S PCE=$P(ZNODE,"^",8) S:PCE="" PCE="NIL"
. I $D(^MAG(2005,D0,"PACS")) S DICOM(PCE)=$G(DICOM(PCE))+1
. E S CLIN(PCE)=$G(CLIN(PCE))+1
. Q
S NAME="" F S NAME=$O(DICOM(NAME)) Q:NAME="" D
. D:$E(NAME,1,4)="RAD "
. . Q:'$D(DICOM(NAME,0))
. . S I=$E(NAME,5,$L(NAME)) Q:I=""
. . Q:$D(DICOM(I,0))
. . S DICOM(I,0)=DICOM(NAME,0) K DICOM(NAME,0) Q
. S PROC=$O(^RAMIS(73.1,"B",NAME,"")) Q:'PROC
. S $P(DICOM(NAME),"^",2)=$P($G(^RAMIS(73.1,PROC,0)),"^",2) Q
S D0=SD0 F S D0=$O(^MAG(2005.1,D0)) Q:'D0 Q:D0'<ED0 D
. S PCE=$P($G(^MAG(2005.1,D0,100)),"^",3) Q:((PCE'=INST)&(AI'[("^"_PCE_"^")))
. S TIEDP=TIEDP+1
. S X=$P($G(^MAG(2005.1,D0,2)),"^",1)\1 Q:'X Q:X<SDATE Q:X>EDATE
. S DELETED=DELETED+1 Q
S I="" F S I=$O(DICOM(I)) Q:I="" D
. S X=" DICOM CAPTURE: "_I_"^"_$G(DICOM(I))
. S:$G(DICOM(I,0)) $P(X,"^",4)=DICOM(I,0)
. D MSG^MAGQE2(X) Q
S I="" F S I=$O(IMPORT(I)) Q:I="" D
. S X=" IMPORT API: "_I_"^"_IMPORT(I)
. S:$G(IMPORT(I,0)) X=X_"^"_IMPORT(I,0)
. D MSG^MAGQE2(X) Q
D LLOAD^MAGQE5(.CLIN,"CLIN CAPTURE:")
D MSG^MAGQE2("CONSENT FORMS: "_CONSENTS)
D LLOAD^MAGQE5(.OTHER,"OTHER CONSENTS:")
D MSG^MAGQE2("Document Images (TIF): "_DOCUMENT)
D MSG^MAGQE2("Document Groups (TIF): "_DOCGRP)
Q
;
ACT(D0,DIS,CAP,VD,VI,RES) ;
N ACT,AN,AN2,D1,IMG
S D1=0 F S D1=$O(^MAG(2006.82,D0,"ACT",D1)) Q:'D1 D
. S AN=^MAG(2006.82,D0,"ACT",D1,0)
. S ACT="^"_$P(AN,"^",1)_"^",AN2=+$P(AN,"^",2)
. Q:"^LOGON^LOGOFF^PAT^"[ACT
. I "^SC_BAD^SCR_OK^"[ACT D Q
. . S AN=$P(AN,"^",10,14) Q:AN=""
. . S RES(ACT,AN)=$G(RES(ACT,AN))+1 Q
. I "^CAP^IMG^"[ACT D Q
. . S IMG=+$P(AN,"^",3) Q:'IMG Q:$P($G(^MAG(2005,IMG,0)),"^",2)=""
. . I ACT="^CAP^" S CAP=CAP+1 Q
. . S DIS=DIS+1,^TMP($J,"MAGQ","DISPAT",AN2)="",^TMP($J,"MAGQ","ALLPAT",AN2)=""
. . Q
. I "^VR-VW^"[ACT D VRAD(.VD,AN) S ^TMP($J,"MAGQ","DISPAT",AN2)="",^TMP($J,"MAGQ","ALLPAT",AN2)="" Q
. I "^VR-INT^"[ACT D VRAD(.VI,AN) S ^TMP($J,"MAGQ","DISPAT",AN2)="",^TMP($J,"MAGQ","ALLPAT",AN2)="" Q
. Q
Q
;
VRAD(ARR,AN) ;
;ARR=STUDIES^IMAGES^PATIENTS^User Type(Rad/Non-Rad)^Remotes(Remote/Local)^Modalities
N P,X
S $P(ARR,"^",1)=$P($G(ARR),"^",1)+1 ; Studies
S $P(ARR,"^",2)=$P($G(ARR),"^",2)+$P(AN,"^",6) ; Images
S $P(ARR,"^",3)=$P($G(ARR),"^",3)+$P(AN,"^",7) ; Patients
S P=$P(ARR,"^",4)
I +$P(AN,"^",8)=1 S $P(P,"/",1)=$P(P,"/",1)+1
E S $P(P,"/",2)=$P(P,"/",2)+1
S $P(ARR,"^",4)=P ; User Type
S P=$P(ARR,"^",5)
I +$P(AN,"^",9)=1 S $P(P,"/",1)=$P(P,"/",1)+1
E S $P(P,"/",2)=$P(P,"/",2)+1
S $P(ARR,"^",5)=P ; Remotes
S P=$P(AN,"^",4) S:P="" P="unknown"
S ARR(P)=$G(ARR(P))+1
S (P,X)="" F S P=$O(ARR(P)) Q:P="" S X=X_"/"_P_"="_ARR(P)
S $P(ARR,"^",6)=X ; Modalities
Q
;
GPACHX() ; Get Package File Install History of Imaging
N I,LCNT,MSG,PKG,PKT,PV
S LCNT=0
F PKG="IMAGING","MAGJ RADIOLOGY" D
. N J,K,L,PKNAM,VERS
. S J=$$FIND1^DIC(9.4,",","MX",PKG) Q:'J
. I PKG="MAGJ RADIOLOGY" D Q
. . N TAR
. . D LIST^DIC(9.49,","_J_",","@;.01;2;3","","","","","","","","TAR","MSG")
. . Q:$D(MSG("DIERR"))
. . S L=0 F S L=$O(TAR("DILIST","ID",L)) Q:'L D
. . . S LCNT=LCNT+1
. . . S PV(LCNT)=PKG_"^P"_$P(TAR("DILIST","ID",L,".01"),"^",1)
. . . S PV(LCNT)=PV(LCNT)_"^"_$P(TAR("DILIST","ID",L,"2"),"^",1)
. . . S PV(LCNT)=PV(LCNT)_"^"_$P(TAR("DILIST","ID",L,"3"),"^",1) Q
. . Q
. K PKT D LIST^DIC(9.49,","_J_",",.01,"","*","","","B","","","PKT","MSG")
. S VERS="" F S VERS=$O(PKT("DILIST",2,VERS)) Q:VERS="" S K=PKT("DILIST",2,VERS) D
. . K MSG
. . D LIST^DIC(9.4901,","_K_","_J_",","@;.01;.02;.03","","","","","","","","TAR","MSG")
. . Q:$D(MSG("DIERR"))
. . S L=0 F S L=$O(TAR("DILIST","ID",L)) Q:'L D
. . . S LCNT=LCNT+1
. . . S PV(LCNT)=PKG_"^"_VERS_"P"_$P(TAR("DILIST","ID",L,".01"),"^",1)
. . . S PV(LCNT)=PV(LCNT)_"^"_$P(TAR("DILIST","ID",L,".02"),"^",1)
. . . S PV(LCNT)=PV(LCNT)_"^"_$P(TAR("DILIST","ID",L,".03"),"^",1) Q
. . Q
. Q
S I="" F S I=$O(PV(I)) Q:I="" D
. D MSG^MAGQE2("IMAGING PACKAGE INSTALLATION HX: "_I_"^"_PV(I)) Q
Q
;
ADCNT(SDATE,EDATE,INST,AI) ;
; SAC = Scanned, Administrative Closure SMC = Scanned, Manual Closure UMC = Unscanned, Manual Closure
N ARRY,D0,D1,DATE,DATES,DOC,HLOC,SAC,SCR,SMC,STAT,STATA,STATC,TITLE,TIUDA,UMC
S STATA="^",D0=0 F S D0=$O(^TIU(8925.6,"B","AMENDED",D0)) Q:'D0 D
. S STATA=STATA_D0_"^" Q
S STATC="^",D0=0 F S D0=$O(^TIU(8925.6,"B","COMPLETED",D0)) Q:'D0 D
. S STATC=STATC_D0_"^" Q
S DOC="ADVANCE DIRECTIVE"
S D0=0 F S D0=$O(^TIU(8925.1,"B",DOC,D0)) Q:'D0 D
. Q:$P($G(^TIU(8925.1,D0,0)),"^",4)'="DC"
. S D1=0 F S D1=$O(^TIU(8925.1,D0,10,"B",D1)) Q:'D1 D
. . S TITLE=$P($G(^TIU(8925.1,+D1,0)),"^",1) S:TITLE="" TITLE=" "
. . S ARRY(TITLE,D1)="" Q
. Q
S SCR="",(SAC,SMC,UMC)=0
S TITLE="" F S TITLE=$O(ARRY(TITLE)) Q:TITLE="" D
. S D1="" F S D1=$O(ARRY(TITLE,D1)) Q:D1="" D
. . S TIUDA=0 F S TIUDA=$O(^TIU(8925,"B",D1,TIUDA)) Q:'TIUDA D
. . . N MSG,TARGET
. . . S SCR="" ; INSTITUTION screen for consolidation sites only.
. . . D GETS^DIQ(8925,TIUDA,".05;1205;1501;1507;1603;1606;1613","IE","TARGET","MSG")
. . . Q:$D(MSG("DIERR"))
. . . I $$CONSOLID^MAGQE5() D Q:SCR
. . . . S HLOC=TARGET(8925,TIUDA_",",1205,"I") ; INSTITUTION screen - dependent upon TIU*1*113
. . . . I HLOC="" S SCR=1
. . . . E I (($P($G(^SC(HLOC,0)),"^",4)'=INST)&(AI'[("^"_$P($G(^SC(HLOC,0)),"^",4)_"^"))) S SCR=1
. . . . Q
. . . S STAT="^"_TARGET(8925,TIUDA_",",.05,"I")_"^"
. . . Q:STATA_STATC'[STAT
. . . I TARGET(8925,TIUDA_",",1613,"I")="S" D Q
. . . . Q:TARGET(8925,TIUDA_",",1606,"I")<SDATE
. . . . Q:$P(TARGET(8925,TIUDA_",",1606,"I"),".")>EDATE
. . . . S SAC=SAC+1,SAC(TITLE)=$G(SAC(TITLE))+1 Q
. . . I STATC[STAT D Q
. . . . S DATE=TARGET(8925,TIUDA_",",1507,"I")
. . . . S DATE=$S(DATE?1.N:DATE,1:+TARGET(8925,TIUDA_",",1501,"I"))
. . . . Q:DATE<SDATE
. . . . Q:$P(DATE,".")>EDATE
. . . . I $$SCAN(TIUDA) S SMC=SMC+1,SMC(TITLE)=$G(SMC(TITLE))+1 Q
. . . . S UMC=UMC+1,UMC(TITLE)=$G(UMC(TITLE))+1 Q
. . . I STATA[STAT D Q
. . . . Q:TARGET(8925,TIUDA_",",1603,"I")<SDATE
. . . . Q:$P(TARGET(8925,TIUDA_",",1603,"I"),".")>EDATE
. . . . I $$SCAN(TIUDA) S SMC=SMC+1,SMC(TITLE)=$G(SMC(TITLE))+1 Q
. . . . S UMC=UMC+1,UMC(TITLE)=$G(UMC(TITLE))+1 Q
. . . Q
. . Q
. Q
D MSG^MAGQE2(DOC_" SCANNED ADMINISTRATIVE CLOSURE: "_SAC)
S TITLE="" F S TITLE=$O(SAC(TITLE)) Q:TITLE="" D
. D MSG^MAGQE2(DOC_" - SAC - "_TITLE_": "_SAC(TITLE)) Q
D MSG^MAGQE2(DOC_" UNSCANNED MANUAL CLOSURE: "_UMC)
S TITLE="" F S TITLE=$O(UMC(TITLE)) Q:TITLE="" D
. D MSG^MAGQE2(DOC_" - UMC - "_TITLE_": "_UMC(TITLE)) Q
D MSG^MAGQE2(DOC_" SCANNED MANUAL CLOSURE: "_SMC)
S TITLE="" F S TITLE=$O(SMC(TITLE)) Q:TITLE="" D
. D MSG^MAGQE2(DOC_" - SMC - "_TITLE_": "_SMC(TITLE)) Q
Q
;
SCAN(IEN) ;
N LINK
S LINK=$O(^TIU(8925.91,"B",IEN,"")) Q:'LINK 0
Q $S($P($G(^TIU(8925.1,LINK,0)),"^",2)?1.N:0,1:1)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGQE3 10016 printed Sep 23, 2025@19:44:20 Page 2
MAGQE3 ;WOIFO/RMP - Support for MAG Enterprise ; 25 Jun 2012 4:20 PM
+1 ;;3.0;IMAGING;**27,29,30,20,46,135**;Mar 19, 2002;Build 5238;Jul 17, 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 ;
COUNT(SDATE,EDATE,INST,AI,IQ,DUP,TIOP,TGPP,TIEDP,GRPPRNT,IMAGE,DELETED) ;
+1 NEW CLIN,CONSENTS,CPTR,D0,DAT,DICOM,DOC,DOCGRP,DOCUMENT,ED0,I,IMPORT
+2 NEW NAME,OTHER,PCE,PROC,SD0,TRK,ZNODE,CNODE
+3 SET SD0=$$SDATE^MAGQE1(SDATE,"F")
+4 SET ED0=$$SDATE^MAGQE1(EDATE,"R")
+5 SET D0=""
FOR
SET D0=$ORDER(^MAG(2005.02,"B","DOCUMENT",D0))
if D0=""
QUIT
Begin DoDot:1
+6 if $GET(^MAG(2005.02,D0,4))["TIF"
SET DOC(D0)=""
+7 QUIT
End DoDot:1
+8 SET (CONSENTS,GRPPRNT,IMAGE,DELETED,DOCGRP,DOCUMENT,DUP,TIOP,TGPP,TIEDP)=0
+9 SET IQ="0^0^0"
+10 SET CPTR=$ORDER(^MAG(2005.83,"B","CONSENT",""))
+11 SET D0=SD0
FOR
SET D0=$ORDER(^MAG(2005,D0))
if 'D0
QUIT
if D0'<ED0
QUIT
Begin DoDot:1
+12 SET CNODE=$GET(^MAG(2005,D0,100))
+13 SET PCE=$PIECE(CNODE,"^",3)
if ((PCE'=INST)&(AI'[("^"_PCE_"^")))
QUIT
+14 SET ZNODE=$GET(^MAG(2005,D0,0))
+15 ;TOTAL FILE WIDE by Place
IF $PIECE(ZNODE,"^",2)=""
SET TGPP=TGPP+1
+16 IF '$TEST
Begin DoDot:2
+17 SET TIOP=TIOP+1
+18 if ($PIECE(ZNODE,U,11)="")
SET $PIECE(IQ,U,1)=$PIECE(IQ,U,1)+1
+19 if ($PIECE(ZNODE,U,11)="0")
SET $PIECE(IQ,U,2)=$PIECE(IQ,U,2)+1
+20 if ($PIECE(ZNODE,U,11)="1")
SET $PIECE(IQ,U,3)=$PIECE(IQ,U,3)+1
+21 QUIT
End DoDot:2
+22 SET X=$PIECE($GET(^MAG(2005,D0,2)),"^",1)\1
if 'X
QUIT
if X<SDATE
QUIT
if X>EDATE
QUIT
+23 if $PIECE(ZNODE,U,12)
SET DUP=DUP+1
+24 SET PCE=$PIECE(CNODE,"^",5)
SET TRK=""
IF PCE'=""
Begin DoDot:2
+25 SET TRK=$PIECE($GET(^MAG(2006.04,$PIECE(CNODE,U,4),0)),U)
+26 SET TRK=$SELECT(TRK'="":TRK,1:"?")
QUIT
End DoDot:2
+27 IF $PIECE(ZNODE,"^",2)=""
Begin DoDot:2
+28 SET GRPPRNT=GRPPRNT+1
+29 SET PCE=$PIECE(ZNODE,"^",8)
if PCE=""
SET PCE="NIL"
+30 if $DATA(^MAG(2005,D0,"PACS"))
SET DICOM(PCE,0)=$GET(DICOM(PCE,0))+1
+31 SET PCE=$PIECE(ZNODE,"^",6)
IF PCE
IF $DATA(DOC(PCE))
SET DOCGRP=DOCGRP+1
+32 if TRK'=""
SET IMPORT(TRK,0)=$GET(IMPORT(TRK,0))+1
+33 QUIT
End DoDot:2
QUIT
+34 if TRK'=""
SET IMPORT(TRK)=$GET(IMPORT(TRK))+1
+35 IF CPTR
IF $PIECE($GET(^MAG(2005,D0,40)),"^",3)=CPTR
SET CONSENTS=CONSENTS+1
+36 IF '$TEST
SET PCE=$$UPPER^MAGQE4($PIECE($GET(^MAG(2005,D0,2)),"^",4))
if PCE["CONSENT"
SET OTHER(PCE)=$GET(OTHER(PCE))+1
+37 SET IMAGE=IMAGE+1
+38 SET PCE=$PIECE(ZNODE,"^",6)
IF PCE
IF $DATA(DOC(PCE))
SET DOCUMENT=DOCUMENT+1
+39 SET PCE=$PIECE(ZNODE,"^",7)
if PCE=""
SET PCE="NIL"
+40 SET ^TMP($JOB,"MAGQ","ACQPAT",PCE)=""
+41 SET ^TMP($JOB,"MAGQ","ALLPAT",PCE)=""
+42 SET PCE=$PIECE(ZNODE,"^",8)
if PCE=""
SET PCE="NIL"
+43 IF $DATA(^MAG(2005,D0,"PACS"))
SET DICOM(PCE)=$GET(DICOM(PCE))+1
+44 IF '$TEST
SET CLIN(PCE)=$GET(CLIN(PCE))+1
+45 QUIT
End DoDot:1
+46 SET NAME=""
FOR
SET NAME=$ORDER(DICOM(NAME))
if NAME=""
QUIT
Begin DoDot:1
+47 if $EXTRACT(NAME,1,4)="RAD "
Begin DoDot:2
+48 if '$DATA(DICOM(NAME,0))
QUIT
+49 SET I=$EXTRACT(NAME,5,$LENGTH(NAME))
if I=""
QUIT
+50 if $DATA(DICOM(I,0))
QUIT
+51 SET DICOM(I,0)=DICOM(NAME,0)
KILL DICOM(NAME,0)
QUIT
End DoDot:2
+52 SET PROC=$ORDER(^RAMIS(73.1,"B",NAME,""))
if 'PROC
QUIT
+53 SET $PIECE(DICOM(NAME),"^",2)=$PIECE($GET(^RAMIS(73.1,PROC,0)),"^",2)
QUIT
End DoDot:1
+54 SET D0=SD0
FOR
SET D0=$ORDER(^MAG(2005.1,D0))
if 'D0
QUIT
if D0'<ED0
QUIT
Begin DoDot:1
+55 SET PCE=$PIECE($GET(^MAG(2005.1,D0,100)),"^",3)
if ((PCE'=INST)&(AI'[("^"_PCE_"^")))
QUIT
+56 SET TIEDP=TIEDP+1
+57 SET X=$PIECE($GET(^MAG(2005.1,D0,2)),"^",1)\1
if 'X
QUIT
if X<SDATE
QUIT
if X>EDATE
QUIT
+58 SET DELETED=DELETED+1
QUIT
End DoDot:1
+59 SET I=""
FOR
SET I=$ORDER(DICOM(I))
if I=""
QUIT
Begin DoDot:1
+60 SET X=" DICOM CAPTURE: "_I_"^"_$GET(DICOM(I))
+61 if $GET(DICOM(I,0))
SET $PIECE(X,"^",4)=DICOM(I,0)
+62 DO MSG^MAGQE2(X)
QUIT
End DoDot:1
+63 SET I=""
FOR
SET I=$ORDER(IMPORT(I))
if I=""
QUIT
Begin DoDot:1
+64 SET X=" IMPORT API: "_I_"^"_IMPORT(I)
+65 if $GET(IMPORT(I,0))
SET X=X_"^"_IMPORT(I,0)
+66 DO MSG^MAGQE2(X)
QUIT
End DoDot:1
+67 DO LLOAD^MAGQE5(.CLIN,"CLIN CAPTURE:")
+68 DO MSG^MAGQE2("CONSENT FORMS: "_CONSENTS)
+69 DO LLOAD^MAGQE5(.OTHER,"OTHER CONSENTS:")
+70 DO MSG^MAGQE2("Document Images (TIF): "_DOCUMENT)
+71 DO MSG^MAGQE2("Document Groups (TIF): "_DOCGRP)
+72 QUIT
+73 ;
ACT(D0,DIS,CAP,VD,VI,RES) ;
+1 NEW ACT,AN,AN2,D1,IMG
+2 SET D1=0
FOR
SET D1=$ORDER(^MAG(2006.82,D0,"ACT",D1))
if 'D1
QUIT
Begin DoDot:1
+3 SET AN=^MAG(2006.82,D0,"ACT",D1,0)
+4 SET ACT="^"_$PIECE(AN,"^",1)_"^"
SET AN2=+$PIECE(AN,"^",2)
+5 if "^LOGON^LOGOFF^PAT^"[ACT
QUIT
+6 IF "^SC_BAD^SCR_OK^"[ACT
Begin DoDot:2
+7 SET AN=$PIECE(AN,"^",10,14)
if AN=""
QUIT
+8 SET RES(ACT,AN)=$GET(RES(ACT,AN))+1
QUIT
End DoDot:2
QUIT
+9 IF "^CAP^IMG^"[ACT
Begin DoDot:2
+10 SET IMG=+$PIECE(AN,"^",3)
if 'IMG
QUIT
if $PIECE($GET(^MAG(2005,IMG,0)),"^",2)=""
QUIT
+11 IF ACT="^CAP^"
SET CAP=CAP+1
QUIT
+12 SET DIS=DIS+1
SET ^TMP($JOB,"MAGQ","DISPAT",AN2)=""
SET ^TMP($JOB,"MAGQ","ALLPAT",AN2)=""
+13 QUIT
End DoDot:2
QUIT
+14 IF "^VR-VW^"[ACT
DO VRAD(.VD,AN)
SET ^TMP($JOB,"MAGQ","DISPAT",AN2)=""
SET ^TMP($JOB,"MAGQ","ALLPAT",AN2)=""
QUIT
+15 IF "^VR-INT^"[ACT
DO VRAD(.VI,AN)
SET ^TMP($JOB,"MAGQ","DISPAT",AN2)=""
SET ^TMP($JOB,"MAGQ","ALLPAT",AN2)=""
QUIT
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
VRAD(ARR,AN) ;
+1 ;ARR=STUDIES^IMAGES^PATIENTS^User Type(Rad/Non-Rad)^Remotes(Remote/Local)^Modalities
+2 NEW P,X
+3 ; Studies
SET $PIECE(ARR,"^",1)=$PIECE($GET(ARR),"^",1)+1
+4 ; Images
SET $PIECE(ARR,"^",2)=$PIECE($GET(ARR),"^",2)+$PIECE(AN,"^",6)
+5 ; Patients
SET $PIECE(ARR,"^",3)=$PIECE($GET(ARR),"^",3)+$PIECE(AN,"^",7)
+6 SET P=$PIECE(ARR,"^",4)
+7 IF +$PIECE(AN,"^",8)=1
SET $PIECE(P,"/",1)=$PIECE(P,"/",1)+1
+8 IF '$TEST
SET $PIECE(P,"/",2)=$PIECE(P,"/",2)+1
+9 ; User Type
SET $PIECE(ARR,"^",4)=P
+10 SET P=$PIECE(ARR,"^",5)
+11 IF +$PIECE(AN,"^",9)=1
SET $PIECE(P,"/",1)=$PIECE(P,"/",1)+1
+12 IF '$TEST
SET $PIECE(P,"/",2)=$PIECE(P,"/",2)+1
+13 ; Remotes
SET $PIECE(ARR,"^",5)=P
+14 SET P=$PIECE(AN,"^",4)
if P=""
SET P="unknown"
+15 SET ARR(P)=$GET(ARR(P))+1
+16 SET (P,X)=""
FOR
SET P=$ORDER(ARR(P))
if P=""
QUIT
SET X=X_"/"_P_"="_ARR(P)
+17 ; Modalities
SET $PIECE(ARR,"^",6)=X
+18 QUIT
+19 ;
GPACHX() ; Get Package File Install History of Imaging
+1 NEW I,LCNT,MSG,PKG,PKT,PV
+2 SET LCNT=0
+3 FOR PKG="IMAGING","MAGJ RADIOLOGY"
Begin DoDot:1
+4 NEW J,K,L,PKNAM,VERS
+5 SET J=$$FIND1^DIC(9.4,",","MX",PKG)
if 'J
QUIT
+6 IF PKG="MAGJ RADIOLOGY"
Begin DoDot:2
+7 NEW TAR
+8 DO LIST^DIC(9.49,","_J_",","@;.01;2;3","","","","","","","","TAR","MSG")
+9 if $DATA(MSG("DIERR"))
QUIT
+10 SET L=0
FOR
SET L=$ORDER(TAR("DILIST","ID",L))
if 'L
QUIT
Begin DoDot:3
+11 SET LCNT=LCNT+1
+12 SET PV(LCNT)=PKG_"^P"_$PIECE(TAR("DILIST","ID",L,".01"),"^",1)
+13 SET PV(LCNT)=PV(LCNT)_"^"_$PIECE(TAR("DILIST","ID",L,"2"),"^",1)
+14 SET PV(LCNT)=PV(LCNT)_"^"_$PIECE(TAR("DILIST","ID",L,"3"),"^",1)
QUIT
End DoDot:3
+15 QUIT
End DoDot:2
QUIT
+16 KILL PKT
DO LIST^DIC(9.49,","_J_",",.01,"","*","","","B","","","PKT","MSG")
+17 SET VERS=""
FOR
SET VERS=$ORDER(PKT("DILIST",2,VERS))
if VERS=""
QUIT
SET K=PKT("DILIST",2,VERS)
Begin DoDot:2
+18 KILL MSG
+19 DO LIST^DIC(9.4901,","_K_","_J_",","@;.01;.02;.03","","","","","","","","TAR","MSG")
+20 if $DATA(MSG("DIERR"))
QUIT
+21 SET L=0
FOR
SET L=$ORDER(TAR("DILIST","ID",L))
if 'L
QUIT
Begin DoDot:3
+22 SET LCNT=LCNT+1
+23 SET PV(LCNT)=PKG_"^"_VERS_"P"_$PIECE(TAR("DILIST","ID",L,".01"),"^",1)
+24 SET PV(LCNT)=PV(LCNT)_"^"_$PIECE(TAR("DILIST","ID",L,".02"),"^",1)
+25 SET PV(LCNT)=PV(LCNT)_"^"_$PIECE(TAR("DILIST","ID",L,".03"),"^",1)
QUIT
End DoDot:3
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 SET I=""
FOR
SET I=$ORDER(PV(I))
if I=""
QUIT
Begin DoDot:1
+29 DO MSG^MAGQE2("IMAGING PACKAGE INSTALLATION HX: "_I_"^"_PV(I))
QUIT
End DoDot:1
+30 QUIT
+31 ;
ADCNT(SDATE,EDATE,INST,AI) ;
+1 ; SAC = Scanned, Administrative Closure SMC = Scanned, Manual Closure UMC = Unscanned, Manual Closure
+2 NEW ARRY,D0,D1,DATE,DATES,DOC,HLOC,SAC,SCR,SMC,STAT,STATA,STATC,TITLE,TIUDA,UMC
+3 SET STATA="^"
SET D0=0
FOR
SET D0=$ORDER(^TIU(8925.6,"B","AMENDED",D0))
if 'D0
QUIT
Begin DoDot:1
+4 SET STATA=STATA_D0_"^"
QUIT
End DoDot:1
+5 SET STATC="^"
SET D0=0
FOR
SET D0=$ORDER(^TIU(8925.6,"B","COMPLETED",D0))
if 'D0
QUIT
Begin DoDot:1
+6 SET STATC=STATC_D0_"^"
QUIT
End DoDot:1
+7 SET DOC="ADVANCE DIRECTIVE"
+8 SET D0=0
FOR
SET D0=$ORDER(^TIU(8925.1,"B",DOC,D0))
if 'D0
QUIT
Begin DoDot:1
+9 if $PIECE($GET(^TIU(8925.1,D0,0)),"^",4)'="DC"
QUIT
+10 SET D1=0
FOR
SET D1=$ORDER(^TIU(8925.1,D0,10,"B",D1))
if 'D1
QUIT
Begin DoDot:2
+11 SET TITLE=$PIECE($GET(^TIU(8925.1,+D1,0)),"^",1)
if TITLE=""
SET TITLE=" "
+12 SET ARRY(TITLE,D1)=""
QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET SCR=""
SET (SAC,SMC,UMC)=0
+15 SET TITLE=""
FOR
SET TITLE=$ORDER(ARRY(TITLE))
if TITLE=""
QUIT
Begin DoDot:1
+16 SET D1=""
FOR
SET D1=$ORDER(ARRY(TITLE,D1))
if D1=""
QUIT
Begin DoDot:2
+17 SET TIUDA=0
FOR
SET TIUDA=$ORDER(^TIU(8925,"B",D1,TIUDA))
if 'TIUDA
QUIT
Begin DoDot:3
+18 NEW MSG,TARGET
+19 ; INSTITUTION screen for consolidation sites only.
SET SCR=""
+20 DO GETS^DIQ(8925,TIUDA,".05;1205;1501;1507;1603;1606;1613","IE","TARGET","MSG")
+21 if $DATA(MSG("DIERR"))
QUIT
+22 IF $$CONSOLID^MAGQE5()
Begin DoDot:4
+23 ; INSTITUTION screen - dependent upon TIU*1*113
SET HLOC=TARGET(8925,TIUDA_",",1205,"I")
+24 IF HLOC=""
SET SCR=1
+25 IF '$TEST
IF (($PIECE($GET(^SC(HLOC,0)),"^",4)'=INST)&(AI'[("^"_$PIECE($GET(^SC(HLOC,0)),"^",4)_"^")))
SET SCR=1
+26 QUIT
End DoDot:4
if SCR
QUIT
+27 SET STAT="^"_TARGET(8925,TIUDA_",",.05,"I")_"^"
+28 if STATA_STATC'[STAT
QUIT
+29 IF TARGET(8925,TIUDA_",",1613,"I")="S"
Begin DoDot:4
+30 if TARGET(8925,TIUDA_",",1606,"I")<SDATE
QUIT
+31 if $PIECE(TARGET(8925,TIUDA_",",1606,"I"),".")>EDATE
QUIT
+32 SET SAC=SAC+1
SET SAC(TITLE)=$GET(SAC(TITLE))+1
QUIT
End DoDot:4
QUIT
+33 IF STATC[STAT
Begin DoDot:4
+34 SET DATE=TARGET(8925,TIUDA_",",1507,"I")
+35 SET DATE=$SELECT(DATE?1.N:DATE,1:+TARGET(8925,TIUDA_",",1501,"I"))
+36 if DATE<SDATE
QUIT
+37 if $PIECE(DATE,".")>EDATE
QUIT
+38 IF $$SCAN(TIUDA)
SET SMC=SMC+1
SET SMC(TITLE)=$GET(SMC(TITLE))+1
QUIT
+39 SET UMC=UMC+1
SET UMC(TITLE)=$GET(UMC(TITLE))+1
QUIT
End DoDot:4
QUIT
+40 IF STATA[STAT
Begin DoDot:4
+41 if TARGET(8925,TIUDA_",",1603,"I")<SDATE
QUIT
+42 if $PIECE(TARGET(8925,TIUDA_",",1603,"I"),".")>EDATE
QUIT
+43 IF $$SCAN(TIUDA)
SET SMC=SMC+1
SET SMC(TITLE)=$GET(SMC(TITLE))+1
QUIT
+44 SET UMC=UMC+1
SET UMC(TITLE)=$GET(UMC(TITLE))+1
QUIT
End DoDot:4
QUIT
+45 QUIT
End DoDot:3
+46 QUIT
End DoDot:2
+47 QUIT
End DoDot:1
+48 DO MSG^MAGQE2(DOC_" SCANNED ADMINISTRATIVE CLOSURE: "_SAC)
+49 SET TITLE=""
FOR
SET TITLE=$ORDER(SAC(TITLE))
if TITLE=""
QUIT
Begin DoDot:1
+50 DO MSG^MAGQE2(DOC_" - SAC - "_TITLE_": "_SAC(TITLE))
QUIT
End DoDot:1
+51 DO MSG^MAGQE2(DOC_" UNSCANNED MANUAL CLOSURE: "_UMC)
+52 SET TITLE=""
FOR
SET TITLE=$ORDER(UMC(TITLE))
if TITLE=""
QUIT
Begin DoDot:1
+53 DO MSG^MAGQE2(DOC_" - UMC - "_TITLE_": "_UMC(TITLE))
QUIT
End DoDot:1
+54 DO MSG^MAGQE2(DOC_" SCANNED MANUAL CLOSURE: "_SMC)
+55 SET TITLE=""
FOR
SET TITLE=$ORDER(SMC(TITLE))
if TITLE=""
QUIT
Begin DoDot:1
+56 DO MSG^MAGQE2(DOC_" - SMC - "_TITLE_": "_SMC(TITLE))
QUIT
End DoDot:1
+57 QUIT
+58 ;
SCAN(IEN) ;
+1 NEW LINK
+2 SET LINK=$ORDER(^TIU(8925.91,"B",IEN,""))
if 'LINK
QUIT 0
+3 QUIT $SELECT($PIECE($GET(^TIU(8925.1,LINK,0)),"^",2)?1.N:0,1:1)
+4 ;
