MAGCRPT ;WOIFO/EdM ; Report on inconsistencies ; [ 11/01/2001 11:27 ]
;;3.0;IMAGING;;Mar 01, 2002
;; +---------------------------------------------------------------+
;; | 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
;
RPT(TYPE) ; This entry is called from the VistA Menu Option handler
; The value of TYPE is equal to either
; "QA" -- report for Quality Assurance (option MAG_IC_RPT_QA)
; "CO" -- report for Central Office (option MAG_IC_RPT_CO)
;
N OK,POP,X,Y,STOP,TODAY,STATUS,NUMBER,ERRTYPE,I,II,VA,VADM
S NUMBER=$O(^XTMP("MAGCHK",""))
I +NUMBER,$P(^XTMP("MAGCHK",NUMBER,0),"^",1)'?.N1".".N S NUMBER=0
; Previous scans had the 1st piece as the scan status instead of the purge date for XTMP
S OUT=0
I +NUMBER D
. S STATUS=$P($G(^XTMP("MAGCHK",NUMBER,0)),"^",4)
. D NOW^%DTC S TODAY=%
. S START=$P($G(^XTMP("MAGCHK",NUMBER,0)),"^",5)
. S STOP=$P($G(^XTMP("MAGCHK",NUMBER,0)),"^",6)
I +NUMBER I STATUS'="COMPLETE" D
. S Y=$P(^XTMP("MAGCHK",NUMBER,0),"^",5) X ^DD("DD")
. N DIR
. S OK=1
. W !!,"Scanning appears to be active. It was started on: "_Y
. S DIR(0)="Y",DIR("B")="Y"
. S DIR("A")="Do you want to start it again?"
. D ^DIR S:'Y OK=0
. I 'OK W !,"Note: Report will be partial and not the complete report."
. I OK S NUMBER=0
. I Y["^" S OUT=1
. Q
I +OUT Q
;check to see if scan is over 2 weeks old
I +NUMBER I STATUS="COMPLETE" S X1=TODAY,X2=STOP D ^%DTC I X>14 D
. S DAYS=+X
. N DIR
. S OK=1
. S DIR(0)="Y",DIR("B")="Y"
. S DIR("A",1)="The database scanner has not run in "_+X_" days"
. S DIR("A")="Do you want to start a new scan? "
. D ^DIR S:'Y OK=0
. I 'OK W !,"Note: You will get an old report."
. I OK S NUMBER=0
. I Y["^" S OUT=1
. Q
I +OUT Q
S OK=0 F D Q:POP>0 Q:OK
. D ^%ZIS Q:POP>0
. I IOM<132 W !!,"Report is formatted for 132 columns",!,"Try again" Q
. S OK=1
. I $E(IOST,1,1)'="P" D Q:'OK
. . N DIR
. . S DIR(0)="Y"
. . S DIR("A")="This is not a printer. Is this OK",DIR("B")="YES"
. . D ^DIR S:'Y OK=0
. . Q
. I $D(IO("Q")) D Q
. . S ZTRTN="WORK^MAGICRPT"
. . S ZTIO=ION_";132"
. . S ZTDESC="Imaging Integrity Check Report"
. . S ZTSAVE("TYPE")=TYPE
. . D ^%ZTLOAD,HOME^%ZIS
. . I '$D(ZTSK) S OK=0 W !!,$C(7),"Request canceled.",! Q
. . W !!,"Request queued." S OK=-1
. . Q
. Q
Q:OK<1 Q:POP>0
W !!,"Report being produced on ",IOST,!!
U IO D WORK D ^%ZISC,HOME^%ZIS
Q
;
WORK N D0,ERR,H1,H2,I,LIN,N,PAG,PT,SQI,X
K ^TMP("MAGMAIL",$J)
S ^TMP("MAGMAIL",$J,1,0)="Image^DFN-1^Name-1^SS4-1^SS4-2^DFN-2^DFN-2^Package^D0/D1^Message"
D:'NUMBER RPT^MAGGSQI(.SQI,1E11) S NUMBER=$O(^XTMP("MAGCHK",""))
S H1=$P(^XTMP("MAGCHK",NUMBER,0),"^",5) S X=H1 D H^%DTC S H1=%H_","_%T
S H2=$P(^XTMP("MAGCHK",NUMBER,0),"^",6) S X=H2 D H^%DTC S H2=%H_","_%T
S PAG=0
S PT(3.9)="^XMB(3.9,PD0|MailMan||2|^XMB(3.9,PD0,2005,"
S PT(63)="^LR(PD0,GF,PD1|Aut (M)|AY|1|^LR(PD0,GF,PD1,2005,"
S PT(63.02)="^LR(PD0,GF,PD1|El-Micr|EM|1|^LR(PD0,GF,PD1,2005,"
S PT(63.08)="^LR(PD0,GF,PD1|SrgPath|SP|1|^LR(PD0,GF,PD1,2005,"
S PT(63.09)="^LR(PD0,GF,PD1|Cytol|CY|1|^LR(PD0,GF,PD1,2005,"
S PT(63.2)="^LR(PD0,GF,PD1|Aut (G)|AU|1|^LR(PD0,GF,PD1,2005,"
S PT(74)="^RARPT(PD0|Rad||2|^RARPT(PD0,2005,"
S PT(130)="^SRF(PD0|Surgery||1|^SRF(PD0,2005,"
S PT(691)="^MCAR(691,PD0|Echo||2|^MCAR(691,PD0,2005,"
S PT(691.1)="^MCAR(691.1,PD0|Cath||2|^MCAR(691.1,PD0,2005,"
S PT(691.5)="^MCAR(691.5,PD0|ECG||2|^MCAR(691.5,PD0,2005,"
S PT(694)="^MCAR(694,PD0|Hema||2|^MCAR(694,PD0,2005,"
S PT(699)="^MCAR(699,PD0|Endo||2|^MCAR(699,PD0,2005,"
S PT(699.5)="^MCAR(699.5,PD0|Med||2|^MCAR(699.5,PD0,2005,"
;S PT(8925)="^TIU(8925,PD0|TIU||2|^TIU(8925.91,""ADI"",PD0,"
S PT(8925)="^TIU(8925,PD0|TIU||2|^TIU(8925.91,""ADI"",PD0,"
S ERR="" F S ERR=$O(^XTMP("MAGCHK",NUMBER,"B",ERR)) Q:ERR="" D
. I TYPE="CO" S X=1 D Q:X
. . S:ERR="Patient pointer mismatch between Image Group and Image" X=0
. . S:ERR="Image and associated report have different patient pointers" X=0
. . S:ERR="Associated report does not point back to Image" X=0
. . Q
. S ERRTYPE(ERR)=0 I ERR="Images only point to Patient." K ERRTYPE(ERR) Q
. D HDR(ERR)
. S N=0
. S D0="" F S D0=$O(^XTMP("MAGCHK",NUMBER,"B",ERR,D0)) Q:D0="" D
. . N ASITE,DFN,IDFN,IPN,ISS4,PD0,PD1,PDFN,PF,PK,PPN,PSS4,X0,X2
. . S N=N+1
. . S ASITE=$P($G(^MAG(2005,D0,100)),"^",3)
. . S X0=$G(^MAG(2005,D0,0))
. . S X2=$G(^MAG(2005,D0,2))
. . S IDFN=$P(X0,"^",7) S:'IDFN IDFN="-?-"
. . S PF=$P(X2,"^",6),PD0=$P(X2,"^",7),PD1=$P(X2,"^",10)
. . S X=$G(PT(+PF),"|Unknown")
. . S PK=$P(X,"|",2)
. . ;S DFN=IDFN D DEM^VADPT S IPN=VADM(1),ISS4=$E(IPN,1)_$G(VA("BID"))
. . S XX=+$$PTLKP(IDFN,.IPN,.ISS4)
. . S (PPN,PDFN,PSS4)=""
. . D:ERR="Image and associated report have different patient pointers"
. . . N GF,GP,GR,GR0,GT,P0,T
. . . Q:PK="Unknown"
. . . S GR=$P(PT(PF),"|",1),GR0=GR_",0)"
. . . S GP=$P(PT(PF),"|",4)
. . . S P0=$G(@GR0,"^not defined"),PDFN=$P(P0,"^",GP)
. . . I PF\1=63 S PDFN=PD0
. . . I 'PDFN,IPN=PDFN S PDFN=IDFN
. . . Q:IDFN=PDFN
. . . S XX=+$$PTLKP(PDFN,.PPN,.PSS4)
. . . ;S DFN=PDFN D DEM^VADPT S PPN=VADM(1),PSS4=$E(PPN,1)_$G(VA("BID"))
. . . Q
. . D:ERR="Patient pointer mismatch between Image Group and Image"
. . . N G0,P0
. . . S P0=$P(X0,"^",10)
. . . S X0=$G(^MAG(2005,D0,0))
. . . S X2=$G(^MAG(2005,D0,2))
. . . S PDFN=$P(X0,"^",7) D:IDFN=PDFN
. . . . S G0=0 F S G0=$O(^MAG(2005,P0,1,G0)) Q:'G0 D Q:'G0
. . . . . S X0=$G(^MAG(2005,+$P($G(^MAG(2005,P0,1,G0,0)),"^",1),0))
. . . . . S PDFN=$P(X0,"^",7) S:PDFN'=IDFN G0=0
. . . . . Q
. . . . Q
. . . Q:PDFN=IDFN
. . . S XX=+$$PTLKP(PDFN,.PPN,.PSS4)
. . . ;S DFN=PDFN D DEM^VADPT S PPN=VADM(1),PSS4=$E(PPN,1)_$G(VA("BID"))
. . . Q
. . S LIN=LIN+1 D:LIN>IOSL HDR(ERR)
. . S X=PD0 S:PD1 X=X_"/"_PD1
. . I TYPE="CO",PK'="Rad" Q
. . Q:ERR="Images only point to Patient."
. . S ERRTYPE(ERR)=$G(ERRTYPE(ERR))+1
. . W !,$J(D0,7)," ",$$L(IPN,31)," ",$$L(PPN,31)," "
. . W $$L(ISS4,5)," ",$$L(PSS4,5)," "
. . W $J(IDFN,8)," ",$J(PDFN,8)," ",$$L(PK,8)," ",$J(X,5)," ",$J(ASITE,5)
. . S I=$O(^TMP("MAGMAIL",$J," "),-1)+1
. . S ^TMP("MAGMAIL",$J,I,0)=D0_"^"_IPN_"^"_PPN_"^"_ISS4_"^"_PSS4_"^"_IDFN_"^"_PDFN_"^"_PK_"^"_X_"^"_ERR_"^"_ASITE
. . Q
. Q
;
D PN
W !,"S u m m a r y"
;S X=$G(SQI(0)) W !!,+X," ",$P(X,"^",2),!!
S X=$P($G(^XTMP("MAGCHK",NUMBER,0)),"^",8) W !!,X," entries scanned."
S II=$O(^TMP("MAGMAIL",$J," "),-1)+1
S ^TMP("MAGMAIL",$J,II,0)=+X_" entries scanned."
S I="" F S I=$O(ERRTYPE(I)) Q:I="" D
. W !,$J($G(ERRTYPE(I)),7)," occurrence" W:+$G(ERRTYPE(I))'=1 "s" W " of ",I
. S II=$O(^TMP("MAGMAIL",$J," "),-1)+1
. S ^TMP("MAGMAIL",$J,II,0)=$G(ERRTYPE(I))_" occurrence"_$S($G(ERRTYPE(I))'=1:"s",1:"")_" of "_I
. Q
I +H1 D
. S X=$P(H2,",",1)-$P(H1,",",1)*86400+$P(H2,",",2)-$P(H1,",",2)
. W !!,"Database scan took "
. S HRS=X\3600 I +HRS S HRS=+HRS_$S(HRS>1:" hours ",1:" hour ") W HRS
. S MIN=X\60#60 I +MIN S MIN=+MIN_$S(MIN>1:" minutes ",1:" minute ") W MIN
. S SEC=X#60 I +SEC S SEC=+SEC_$S(SEC>1:" seconds ",1:" second ") W SEC
. S II=$O(^TMP("MAGMAIL",$J," "),-1)+1
. S ^TMP("MAGMAIL",$J,II,0)="Database scan took "_HRS_" "_MIN_" "_SEC
. Q
N XMY,XMTEXT,XMSUB
S XMY("G.MAG SERVER")=""
S XMTEXT="^TMP(""MAGMAIL"","_$J_","
S XMSUB="Imaging Integrity Check ("_TYPE_")"
;
I TYPE="CO" I $P(^XTMP("MAGCHK",NUMBER,0),"^",7)="" D
. D ^XMD
. S $P(^XTMP("MAGCHK",NUMBER,0),"^",7)="MAILED"
. Q
;
I TYPE="QA" I $P(^XTMP("MAGCHK",NUMBER,0),"^",9)="" D
. D ^XMD
. S $P(^XTMP("MAGCHK",NUMBER,0),"^",9)="MAILED"
. Q
K ^TMP("MAGMAIL",$J)
Q
;
L(X,N) Q $E(X_$J("",N),1,N)
;
PTLKP(DFN,IPN,ISS4) ;
S IPN="Unknown"
S ISS4="Unk"
I DFN="" Q "0^NO_DFN"
D DEM^VADPT
S:'VAERR IPN=VADM(1),ISS4=$E(IPN,1)_$G(VA("BID"))
I 'VAERR Q "1^SUCCESS"
Q "0^FAILED"
;
PN N X
S PAG=PAG+1,X="Page "_PAG,LIN=6
W:PAG'=1 @IOF
W DT#100," "
W $P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",DT\100#100)
W " ",DT\10000+1700,?(IOM-$L(X)),X
Q
;
HDR(ERR) ;
D PN
S HEADING=$S(TYPE="CO":"**** Report on Inconsistencies Caused by Global Moves ****",1:"**** Report of All Image-Related Inconsistencies Detected ****")
W !?(IOM-$L(HEADING)\2),HEADING
W !?(IOM-$L(ERR)\2),ERR,!
W !,"Image Patient Name Patient Name SSN4 SSN4 DFN DFN Package"
W !,"Number (First one found) (Other one found) (fst) (oth) (fst) (oth) Package IEN SITE"
W !,"======= =============================== =============================== ===== ===== ======== ======== ======= ======= ====="
W !
Q
;
QA ; Report for QA
D RPT("QA")
Q
;
CO ; Report for CO
D RPT("CO")
Q
;
TEST S IOSL=55,IOM=132,IO=$P,TYPE="QA" D WORK
Q
;
DOCU ;
;^XTMP("MAGCHK",$J,0)=PURGE DATE^CREATE DATE^DESCRIPTION^STATUS^SCAN START^SCAN STOP^C0 MAILED^#SCANNED^QA MAILED
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGCRPT 9933 printed Sep 23, 2025@19:35:47 Page 2
MAGCRPT ;WOIFO/EdM ; Report on inconsistencies ; [ 11/01/2001 11:27 ]
+1 ;;3.0;IMAGING;;Mar 01, 2002
+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
+18 ;
RPT(TYPE) ; This entry is called from the VistA Menu Option handler
+1 ; The value of TYPE is equal to either
+2 ; "QA" -- report for Quality Assurance (option MAG_IC_RPT_QA)
+3 ; "CO" -- report for Central Office (option MAG_IC_RPT_CO)
+4 ;
+5 NEW OK,POP,X,Y,STOP,TODAY,STATUS,NUMBER,ERRTYPE,I,II,VA,VADM
+6 SET NUMBER=$ORDER(^XTMP("MAGCHK",""))
+7 IF +NUMBER
IF $PIECE(^XTMP("MAGCHK",NUMBER,0),"^",1)'?.N1".".N
SET NUMBER=0
+8 ; Previous scans had the 1st piece as the scan status instead of the purge date for XTMP
+9 SET OUT=0
+10 IF +NUMBER
Begin DoDot:1
+11 SET STATUS=$PIECE($GET(^XTMP("MAGCHK",NUMBER,0)),"^",4)
+12 DO NOW^%DTC
SET TODAY=%
+13 SET START=$PIECE($GET(^XTMP("MAGCHK",NUMBER,0)),"^",5)
+14 SET STOP=$PIECE($GET(^XTMP("MAGCHK",NUMBER,0)),"^",6)
End DoDot:1
+15 IF +NUMBER
IF STATUS'="COMPLETE"
Begin DoDot:1
+16 SET Y=$PIECE(^XTMP("MAGCHK",NUMBER,0),"^",5)
XECUTE ^DD("DD")
+17 NEW DIR
+18 SET OK=1
+19 WRITE !!,"Scanning appears to be active. It was started on: "_Y
+20 SET DIR(0)="Y"
SET DIR("B")="Y"
+21 SET DIR("A")="Do you want to start it again?"
+22 DO ^DIR
if 'Y
SET OK=0
+23 IF 'OK
WRITE !,"Note: Report will be partial and not the complete report."
+24 IF OK
SET NUMBER=0
+25 IF Y["^"
SET OUT=1
+26 QUIT
End DoDot:1
+27 IF +OUT
QUIT
+28 ;check to see if scan is over 2 weeks old
+29 IF +NUMBER
IF STATUS="COMPLETE"
SET X1=TODAY
SET X2=STOP
DO ^%DTC
IF X>14
Begin DoDot:1
+30 SET DAYS=+X
+31 NEW DIR
+32 SET OK=1
+33 SET DIR(0)="Y"
SET DIR("B")="Y"
+34 SET DIR("A",1)="The database scanner has not run in "_+X_" days"
+35 SET DIR("A")="Do you want to start a new scan? "
+36 DO ^DIR
if 'Y
SET OK=0
+37 IF 'OK
WRITE !,"Note: You will get an old report."
+38 IF OK
SET NUMBER=0
+39 IF Y["^"
SET OUT=1
+40 QUIT
End DoDot:1
+41 IF +OUT
QUIT
+42 SET OK=0
FOR
Begin DoDot:1
+43 DO ^%ZIS
if POP>0
QUIT
+44 IF IOM<132
WRITE !!,"Report is formatted for 132 columns",!,"Try again"
QUIT
+45 SET OK=1
+46 IF $EXTRACT(IOST,1,1)'="P"
Begin DoDot:2
+47 NEW DIR
+48 SET DIR(0)="Y"
+49 SET DIR("A")="This is not a printer. Is this OK"
SET DIR("B")="YES"
+50 DO ^DIR
if 'Y
SET OK=0
+51 QUIT
End DoDot:2
if 'OK
QUIT
+52 IF $DATA(IO("Q"))
Begin DoDot:2
+53 SET ZTRTN="WORK^MAGICRPT"
+54 SET ZTIO=ION_";132"
+55 SET ZTDESC="Imaging Integrity Check Report"
+56 SET ZTSAVE("TYPE")=TYPE
+57 DO ^%ZTLOAD
DO HOME^%ZIS
+58 IF '$DATA(ZTSK)
SET OK=0
WRITE !!,$CHAR(7),"Request canceled.",!
QUIT
+59 WRITE !!,"Request queued."
SET OK=-1
+60 QUIT
End DoDot:2
QUIT
+61 QUIT
End DoDot:1
if POP>0
QUIT
if OK
QUIT
+62 if OK<1
QUIT
if POP>0
QUIT
+63 WRITE !!,"Report being produced on ",IOST,!!
+64 USE IO
DO WORK
DO ^%ZISC
DO HOME^%ZIS
+65 QUIT
+66 ;
WORK NEW D0,ERR,H1,H2,I,LIN,N,PAG,PT,SQI,X
+1 KILL ^TMP("MAGMAIL",$JOB)
+2 SET ^TMP("MAGMAIL",$JOB,1,0)="Image^DFN-1^Name-1^SS4-1^SS4-2^DFN-2^DFN-2^Package^D0/D1^Message"
+3 if 'NUMBER
DO RPT^MAGGSQI(.SQI,1E11)
SET NUMBER=$ORDER(^XTMP("MAGCHK",""))
+4 SET H1=$PIECE(^XTMP("MAGCHK",NUMBER,0),"^",5)
SET X=H1
DO H^%DTC
SET H1=%H_","_%T
+5 SET H2=$PIECE(^XTMP("MAGCHK",NUMBER,0),"^",6)
SET X=H2
DO H^%DTC
SET H2=%H_","_%T
+6 SET PAG=0
+7 SET PT(3.9)="^XMB(3.9,PD0|MailMan||2|^XMB(3.9,PD0,2005,"
+8 SET PT(63)="^LR(PD0,GF,PD1|Aut (M)|AY|1|^LR(PD0,GF,PD1,2005,"
+9 SET PT(63.02)="^LR(PD0,GF,PD1|El-Micr|EM|1|^LR(PD0,GF,PD1,2005,"
+10 SET PT(63.08)="^LR(PD0,GF,PD1|SrgPath|SP|1|^LR(PD0,GF,PD1,2005,"
+11 SET PT(63.09)="^LR(PD0,GF,PD1|Cytol|CY|1|^LR(PD0,GF,PD1,2005,"
+12 SET PT(63.2)="^LR(PD0,GF,PD1|Aut (G)|AU|1|^LR(PD0,GF,PD1,2005,"
+13 SET PT(74)="^RARPT(PD0|Rad||2|^RARPT(PD0,2005,"
+14 SET PT(130)="^SRF(PD0|Surgery||1|^SRF(PD0,2005,"
+15 SET PT(691)="^MCAR(691,PD0|Echo||2|^MCAR(691,PD0,2005,"
+16 SET PT(691.1)="^MCAR(691.1,PD0|Cath||2|^MCAR(691.1,PD0,2005,"
+17 SET PT(691.5)="^MCAR(691.5,PD0|ECG||2|^MCAR(691.5,PD0,2005,"
+18 SET PT(694)="^MCAR(694,PD0|Hema||2|^MCAR(694,PD0,2005,"
+19 SET PT(699)="^MCAR(699,PD0|Endo||2|^MCAR(699,PD0,2005,"
+20 SET PT(699.5)="^MCAR(699.5,PD0|Med||2|^MCAR(699.5,PD0,2005,"
+21 ;S PT(8925)="^TIU(8925,PD0|TIU||2|^TIU(8925.91,""ADI"",PD0,"
+22 SET PT(8925)="^TIU(8925,PD0|TIU||2|^TIU(8925.91,""ADI"",PD0,"
+23 SET ERR=""
FOR
SET ERR=$ORDER(^XTMP("MAGCHK",NUMBER,"B",ERR))
if ERR=""
QUIT
Begin DoDot:1
+24 IF TYPE="CO"
SET X=1
Begin DoDot:2
+25 if ERR="Patient pointer mismatch between Image Group and Image"
SET X=0
+26 if ERR="Image and associated report have different patient pointers"
SET X=0
+27 if ERR="Associated report does not point back to Image"
SET X=0
+28 QUIT
End DoDot:2
if X
QUIT
+29 SET ERRTYPE(ERR)=0
IF ERR="Images only point to Patient."
KILL ERRTYPE(ERR)
QUIT
+30 DO HDR(ERR)
+31 SET N=0
+32 SET D0=""
FOR
SET D0=$ORDER(^XTMP("MAGCHK",NUMBER,"B",ERR,D0))
if D0=""
QUIT
Begin DoDot:2
+33 NEW ASITE,DFN,IDFN,IPN,ISS4,PD0,PD1,PDFN,PF,PK,PPN,PSS4,X0,X2
+34 SET N=N+1
+35 SET ASITE=$PIECE($GET(^MAG(2005,D0,100)),"^",3)
+36 SET X0=$GET(^MAG(2005,D0,0))
+37 SET X2=$GET(^MAG(2005,D0,2))
+38 SET IDFN=$PIECE(X0,"^",7)
if 'IDFN
SET IDFN="-?-"
+39 SET PF=$PIECE(X2,"^",6)
SET PD0=$PIECE(X2,"^",7)
SET PD1=$PIECE(X2,"^",10)
+40 SET X=$GET(PT(+PF),"|Unknown")
+41 SET PK=$PIECE(X,"|",2)
+42 ;S DFN=IDFN D DEM^VADPT S IPN=VADM(1),ISS4=$E(IPN,1)_$G(VA("BID"))
+43 SET XX=+$$PTLKP(IDFN,.IPN,.ISS4)
+44 SET (PPN,PDFN,PSS4)=""
+45 if ERR="Image and associated report have different patient pointers"
Begin DoDot:3
+46 NEW GF,GP,GR,GR0,GT,P0,T
+47 if PK="Unknown"
QUIT
+48 SET GR=$PIECE(PT(PF),"|",1)
SET GR0=GR_",0)"
+49 SET GP=$PIECE(PT(PF),"|",4)
+50 SET P0=$GET(@GR0,"^not defined")
SET PDFN=$PIECE(P0,"^",GP)
+51 IF PF\1=63
SET PDFN=PD0
+52 IF 'PDFN
IF IPN=PDFN
SET PDFN=IDFN
+53 if IDFN=PDFN
QUIT
+54 SET XX=+$$PTLKP(PDFN,.PPN,.PSS4)
+55 ;S DFN=PDFN D DEM^VADPT S PPN=VADM(1),PSS4=$E(PPN,1)_$G(VA("BID"))
+56 QUIT
End DoDot:3
+57 if ERR="Patient pointer mismatch between Image Group and Image"
Begin DoDot:3
+58 NEW G0,P0
+59 SET P0=$PIECE(X0,"^",10)
+60 SET X0=$GET(^MAG(2005,D0,0))
+61 SET X2=$GET(^MAG(2005,D0,2))
+62 SET PDFN=$PIECE(X0,"^",7)
if IDFN=PDFN
Begin DoDot:4
+63 SET G0=0
FOR
SET G0=$ORDER(^MAG(2005,P0,1,G0))
if 'G0
QUIT
Begin DoDot:5
+64 SET X0=$GET(^MAG(2005,+$PIECE($GET(^MAG(2005,P0,1,G0,0)),"^",1),0))
+65 SET PDFN=$PIECE(X0,"^",7)
if PDFN'=IDFN
SET G0=0
+66 QUIT
End DoDot:5
if 'G0
QUIT
+67 QUIT
End DoDot:4
+68 if PDFN=IDFN
QUIT
+69 SET XX=+$$PTLKP(PDFN,.PPN,.PSS4)
+70 ;S DFN=PDFN D DEM^VADPT S PPN=VADM(1),PSS4=$E(PPN,1)_$G(VA("BID"))
+71 QUIT
End DoDot:3
+72 SET LIN=LIN+1
if LIN>IOSL
DO HDR(ERR)
+73 SET X=PD0
if PD1
SET X=X_"/"_PD1
+74 IF TYPE="CO"
IF PK'="Rad"
QUIT
+75 if ERR="Images only point to Patient."
QUIT
+76 SET ERRTYPE(ERR)=$GET(ERRTYPE(ERR))+1
+77 WRITE !,$JUSTIFY(D0,7)," ",$$L(IPN,31)," ",$$L(PPN,31)," "
+78 WRITE $$L(ISS4,5)," ",$$L(PSS4,5)," "
+79 WRITE $JUSTIFY(IDFN,8)," ",$JUSTIFY(PDFN,8)," ",$$L(PK,8)," ",$JUSTIFY(X,5)," ",$JUSTIFY(ASITE,5)
+80 SET I=$ORDER(^TMP("MAGMAIL",$JOB," "),-1)+1
+81 SET ^TMP("MAGMAIL",$JOB,I,0)=D0_"^"_IPN_"^"_PPN_"^"_ISS4_"^"_PSS4_"^"_IDFN_"^"_PDFN_"^"_PK_"^"_X_"^"_ERR_"^"_ASITE
+82 QUIT
End DoDot:2
+83 QUIT
End DoDot:1
+84 ;
+85 DO PN
+86 WRITE !,"S u m m a r y"
+87 ;S X=$G(SQI(0)) W !!,+X," ",$P(X,"^",2),!!
+88 SET X=$PIECE($GET(^XTMP("MAGCHK",NUMBER,0)),"^",8)
WRITE !!,X," entries scanned."
+89 SET II=$ORDER(^TMP("MAGMAIL",$JOB," "),-1)+1
+90 SET ^TMP("MAGMAIL",$JOB,II,0)=+X_" entries scanned."
+91 SET I=""
FOR
SET I=$ORDER(ERRTYPE(I))
if I=""
QUIT
Begin DoDot:1
+92 WRITE !,$JUSTIFY($GET(ERRTYPE(I)),7)," occurrence"
if +$GET(ERRTYPE(I))'=1
WRITE "s"
WRITE " of ",I
+93 SET II=$ORDER(^TMP("MAGMAIL",$JOB," "),-1)+1
+94 SET ^TMP("MAGMAIL",$JOB,II,0)=$GET(ERRTYPE(I))_" occurrence"_$SELECT($GET(ERRTYPE(I))'=1:"s",1:"")_" of "_I
+95 QUIT
End DoDot:1
+96 IF +H1
Begin DoDot:1
+97 SET X=$PIECE(H2,",",1)-$PIECE(H1,",",1)*86400+$PIECE(H2,",",2)-$PIECE(H1,",",2)
+98 WRITE !!,"Database scan took "
+99 SET HRS=X\3600
IF +HRS
SET HRS=+HRS_$SELECT(HRS>1:" hours ",1:" hour ")
WRITE HRS
+100 SET MIN=X\60#60
IF +MIN
SET MIN=+MIN_$SELECT(MIN>1:" minutes ",1:" minute ")
WRITE MIN
+101 SET SEC=X#60
IF +SEC
SET SEC=+SEC_$SELECT(SEC>1:" seconds ",1:" second ")
WRITE SEC
+102 SET II=$ORDER(^TMP("MAGMAIL",$JOB," "),-1)+1
+103 SET ^TMP("MAGMAIL",$JOB,II,0)="Database scan took "_HRS_" "_MIN_" "_SEC
+104 QUIT
End DoDot:1
+105 NEW XMY,XMTEXT,XMSUB
+106 SET XMY("G.MAG SERVER")=""
+107 SET XMTEXT="^TMP(""MAGMAIL"","_$JOB_","
+108 SET XMSUB="Imaging Integrity Check ("_TYPE_")"
+109 ;
+110 IF TYPE="CO"
IF $PIECE(^XTMP("MAGCHK",NUMBER,0),"^",7)=""
Begin DoDot:1
+111 DO ^XMD
+112 SET $PIECE(^XTMP("MAGCHK",NUMBER,0),"^",7)="MAILED"
+113 QUIT
End DoDot:1
+114 ;
+115 IF TYPE="QA"
IF $PIECE(^XTMP("MAGCHK",NUMBER,0),"^",9)=""
Begin DoDot:1
+116 DO ^XMD
+117 SET $PIECE(^XTMP("MAGCHK",NUMBER,0),"^",9)="MAILED"
+118 QUIT
End DoDot:1
+119 KILL ^TMP("MAGMAIL",$JOB)
+120 QUIT
+121 ;
L(X,N) QUIT $EXTRACT(X_$JUSTIFY("",N),1,N)
+1 ;
PTLKP(DFN,IPN,ISS4) ;
+1 SET IPN="Unknown"
+2 SET ISS4="Unk"
+3 IF DFN=""
QUIT "0^NO_DFN"
+4 DO DEM^VADPT
+5 if 'VAERR
SET IPN=VADM(1)
SET ISS4=$EXTRACT(IPN,1)_$GET(VA("BID"))
+6 IF 'VAERR
QUIT "1^SUCCESS"
+7 QUIT "0^FAILED"
+8 ;
PN NEW X
+1 SET PAG=PAG+1
SET X="Page "_PAG
SET LIN=6
+2 if PAG'=1
WRITE @IOF
+3 WRITE DT#100," "
+4 WRITE $PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",DT\100#100)
+5 WRITE " ",DT\10000+1700,?(IOM-$LENGTH(X)),X
+6 QUIT
+7 ;
HDR(ERR) ;
+1 DO PN
+2 SET HEADING=$SELECT(TYPE="CO":"**** Report on Inconsistencies Caused by Global Moves ****",1:"**** Report of All Image-Related Inconsistencies Detected ****")
+3 WRITE !?(IOM-$LENGTH(HEADING)\2),HEADING
+4 WRITE !?(IOM-$LENGTH(ERR)\2),ERR,!
+5 WRITE !,"Image Patient Name Patient Name SSN4 SSN4 DFN DFN Package"
+6 WRITE !,"Number (First one found) (Other one found) (fst) (oth) (fst) (oth) Package IEN SITE"
+7 WRITE !,"======= =============================== =============================== ===== ===== ======== ======== ======= ======= ====="
+8 WRITE !
+9 QUIT
+10 ;
QA ; Report for QA
+1 DO RPT("QA")
+2 QUIT
+3 ;
CO ; Report for CO
+1 DO RPT("CO")
+2 QUIT
+3 ;
TEST SET IOSL=55
SET IOM=132
SET IO=$PRINCIPAL
SET TYPE="QA"
DO WORK
+1 QUIT
+2 ;
DOCU ;
+1 ;^XTMP("MAGCHK",$J,0)=PURGE DATE^CREATE DATE^DESCRIPTION^STATUS^SCAN START^SCAN STOP^C0 MAILED^#SCANNED^QA MAILED
+2 QUIT
