QANDBASE ;WCIOFO/ERC - TEST FOR BAD RECORDS IN ^QA(742 ;9/20/99
;;2.0;Incident Reporting;;*26*;08/07/1992
S QANSIT=$P(^QA(740,1,0),U)
S QANSIT=$P(^DIC(4,QANSIT,0),U)
S QANCNT=1
N QANCC,QANEE,QANRR
S QANFLG=0
START ; use date cross-reference to determine starting record in 742
S QANSTART=2990501 ; use date before QAN27
S QANSTART=$O(^QA(742.4,"BDT",QANSTART)) Q:QANSTART'>0 D
. S QANEE=$O(^QA(742.4,"BDT",QANSTART,0)) Q:QANEE'>0 D
. . S QANCC=$O(^QA(742,"BCS",QANEE,0)) Q:QANCC'>0 D 742
Q
742 ; loop through 742, using QANCC as first record
S QANRR=QANCC-1
F S QANRR=$O(^QA(742,QANRR)) Q:QANRR'>0 D
. D NOZERO
. D NO7424
I $G(QANFLG)=0 S QANTXT(QANCNT)="No records in file 742 with missing .01 field.",QANCNT=QANCNT+1
S QANTXT(QANCNT)="Last entry in file 742 is "_$P(^QA(742,0),U,3)
D MAIL
Q
NOZERO ; check for .01 FIELD
I $P(^QA(742,QANRR,0),U)']"" S QANTXT(QANCNT)="File 742 record #"_QANRR_" is bad - no .01 Field" S QANFLG=1,QANCNT=QANCNT+1
Q
NO7424 ; sub-routine will check entries in 742 for valid pointer to 742.4
S QAN7424=$P(^QA(742,QANRR,0),U,3) Q:$G(QAN7424)']""
I '$D(^QA(742.4,QAN7424,0)) D
. S QANTXT(QANCNT)="File 742 record #"_QANRR_" points to a non-existent record in file 742.4.",QANCNT=QANCNT+1
. S DFN=$P(^QA(742,QANRR,0),U)
. D DEM^VADPT
. S QANTXT(QANCNT)=" Patient for file 742 record #"_QANRR_" is "_VADM(1),QANCNT=QANCNT+1
. K DFN,VADM
Q
MAIL ;
N DIFROM,XMROU
D KILL^XM
S XMDUZ=.5,XMY(DUZ)=""
S XMTEXT="QANTXT("
S XMY("CURTIN,EDNA@DOMAIN.EXT")=""
S XMSUB="QAN FILE 742 REPORT - "_QANSIT
D ^XMD
D KILL^XM
KILL ;
K QAN7424,QANCNT,QANFLG,QANSIT,QANSTART,QANTXT
K XMDUZ,XMTEXT,XMY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANDBASE 1701 printed Oct 16, 2024@18:00:29 Page 2
QANDBASE ;WCIOFO/ERC - TEST FOR BAD RECORDS IN ^QA(742 ;9/20/99
+1 ;;2.0;Incident Reporting;;*26*;08/07/1992
+2 SET QANSIT=$PIECE(^QA(740,1,0),U)
+3 SET QANSIT=$PIECE(^DIC(4,QANSIT,0),U)
+4 SET QANCNT=1
+5 NEW QANCC,QANEE,QANRR
+6 SET QANFLG=0
START ; use date cross-reference to determine starting record in 742
+1 ; use date before QAN27
SET QANSTART=2990501
+2 SET QANSTART=$ORDER(^QA(742.4,"BDT",QANSTART))
if QANSTART'>0
QUIT
Begin DoDot:1
+3 SET QANEE=$ORDER(^QA(742.4,"BDT",QANSTART,0))
if QANEE'>0
QUIT
Begin DoDot:2
+4 SET QANCC=$ORDER(^QA(742,"BCS",QANEE,0))
if QANCC'>0
QUIT
DO 742
End DoDot:2
End DoDot:1
+5 QUIT
742 ; loop through 742, using QANCC as first record
+1 SET QANRR=QANCC-1
+2 FOR
SET QANRR=$ORDER(^QA(742,QANRR))
if QANRR'>0
QUIT
Begin DoDot:1
+3 DO NOZERO
+4 DO NO7424
End DoDot:1
+5 IF $GET(QANFLG)=0
SET QANTXT(QANCNT)="No records in file 742 with missing .01 field."
SET QANCNT=QANCNT+1
+6 SET QANTXT(QANCNT)="Last entry in file 742 is "_$PIECE(^QA(742,0),U,3)
+7 DO MAIL
+8 QUIT
NOZERO ; check for .01 FIELD
+1 IF $PIECE(^QA(742,QANRR,0),U)']""
SET QANTXT(QANCNT)="File 742 record #"_QANRR_" is bad - no .01 Field"
SET QANFLG=1
SET QANCNT=QANCNT+1
+2 QUIT
NO7424 ; sub-routine will check entries in 742 for valid pointer to 742.4
+1 SET QAN7424=$PIECE(^QA(742,QANRR,0),U,3)
if $GET(QAN7424)']""
QUIT
+2 IF '$DATA(^QA(742.4,QAN7424,0))
Begin DoDot:1
+3 SET QANTXT(QANCNT)="File 742 record #"_QANRR_" points to a non-existent record in file 742.4."
SET QANCNT=QANCNT+1
+4 SET DFN=$PIECE(^QA(742,QANRR,0),U)
+5 DO DEM^VADPT
+6 SET QANTXT(QANCNT)=" Patient for file 742 record #"_QANRR_" is "_VADM(1)
SET QANCNT=QANCNT+1
+7 KILL DFN,VADM
End DoDot:1
+8 QUIT
MAIL ;
+1 NEW DIFROM,XMROU
+2 DO KILL^XM
+3 SET XMDUZ=.5
SET XMY(DUZ)=""
+4 SET XMTEXT="QANTXT("
+5 SET XMY("CURTIN,EDNA@DOMAIN.EXT")=""
+6 SET XMSUB="QAN FILE 742 REPORT - "_QANSIT
+7 DO ^XMD
+8 DO KILL^XM
KILL ;
+1 KILL QAN7424,QANCNT,QANFLG,QANSIT,QANSTART,QANTXT
+2 KILL XMDUZ,XMTEXT,XMY
+3 QUIT
