BZXLRSER ;IHS/PIMC/JLG - AZ HEALTH DEPT REPORT [ 10/09/2002 1:08 PM ]
;;1.0;Special local routine for reportable diseases
;This is designed to replace DWLRSER1
;It uses file 1966360 as the table of files to report
;It calls BZXLRSEP as the routine to do the actual printing
;
S DIR("A")="Enter start date"
S DIR(0)="D^:"_DT_":EPX"
D ^DIR
I $D(DIRUT) D Q
.K DIR,DIRUT,DTOUT,DUOUT
S BZXSDT=Y
S BZXVDT=Y-.5
GETEND S DIR("A")="Enter end date"
S DIR(0)="D^:"_DT_":EPX"
D ^DIR
I $D(DIRUT) D Q
.K DIR,DIRUT,DTOUT,DUOUT,BZXVDT
S BZXENDT=Y
I BZXENDT<BZXVDT D G GETEND
.W !,"End date cannot be before start date. Try again."
S %ZIS="Q"
D ^%ZIS
Q:POP
I $D(IO("Q")) D Q
.S ZTRTN="LP^BZXLRSER"
.S ZTSAVE("BZX*")=""
.S ZTDESC="Reportable diseases"
.D ^%ZTLOAD
.K ZTSAVE,ZTDESC,ZTRTN,IO("Q")
;
LP ;Start looping through tests
K ^TMP($J)
U IO
;BZXVDT is both the verification date and the order date
;In effect we only look at the verification date
F S BZXVDT=$O(^LRO(69,BZXVDT)) Q:'BZXVDT!(BZXVDT>BZXENDT) D
.S LOC=""
.F S LOC=$O(^LRO(69,BZXVDT,1,"AN",LOC)) Q:LOC="" D
..S LRDFN=""
..F S LRDFN=$O(^LRO(69,BZXVDT,1,"AN",LOC,LRDFN)) Q:'LRDFN D
...S LRIDT=9999999-BZXVDT-.5
...S X1=BZXVDT
...S X2=-545
...D C^%DTC
...S LRIDTLM=9999999-X
...F S LRIDT=$O(^LRO(69,BZXVDT,1,"AN",LOC,LRDFN,LRIDT)) Q:'LRIDT!(LRIDT>LRIDTLM) D
....Q:'$D(^LR(LRDFN,"CH",LRIDT,0))
....S X=$P(^LR(LRDFN,"CH",LRIDT,0),U,3)\1
....Q:X'=BZXVDT
....S D0=0
....F S D0=$O(^BZXRPTDS(D0)) Q:'D0 D
.....S BZXTPTR=$P(^BZXRPTDS(D0,0),U,1)
.....S BZXTYPE=$P(@(U_$P(^LAB(60,BZXTPTR,0),U,12)_"0)"),U,2)
.....S BZXDLOC=$P(^LAB(60,BZXTPTR,0),U,5)
.....Q:'$D(^LR(LRDFN,"CH",LRIDT,$P(BZXDLOC,";",2)))
.....S BZXRES=$P(^LR(LRDFN,"CH",LRIDT,$P(BZXDLOC,";",2)),U,1)
.....S BZXFLD=$P(^LAB(60,BZXTPTR,0),U,12)
.....S BZXRAWRS=BZXRES
.....S TRANS=$G(^BZXRPTDS(D0,2))
.....I $L(TRANS) D
......S Y=BZXRES
......K X
......X TRANS
......Q:'$D(X)
......S BZXRES=X
.....I $E(BZXTYPE,1)="N" D
......S COND=$P(^BZXRPTDS(D0,0),U,4)
......I COND="EQ" S COND="="
......S VALUE=$P(^BZXRPTDS(D0,0),U,3)
......I $E(BZXRES,1)=">" S BZXRES=$P(BZXRES,">",2)+1
......S BZXRES=+BZXRES
......I @(BZXRES_COND_VALUE) D STORE
.....E I BZXTYPE="S" D
......;What the values stand for in the set
......S BZXSTNFR=$P(@(U_BZXFLD_"0)"),U,3)
......F I=1:1 S Y=$P(BZXSTNFR,";",I) Q:Y="" D
.......I $P(Y,":",1)=BZXRAWRS S BZXRAWRS=$P(Y,":",2)
......S D1=0
......F S D1=$O(^BZXRPTDS(D0,1,D1)) Q:'D1 D
.......S VALUE=$P(^BZXRPTDS(D0,1,D1,0),U,1)
.......I BZXRES=VALUE D STORE
.....E I $E(BZXTYPE,1)="F" D
......S D1=0
......F S D1=$O(^BZXRPTDS(D0,4,D1)) Q:'D1 D
.......S COND=$P(^BZXRPTDS(D0,4,D1,0),U,2)
.......S COND=$S(COND="C":"[",1:"=")
.......S VALUE=$P(^BZXRPTDS(D0,4,D1,0),U,1)
.......I BZXRES'=+BZXRES S BZXRES=""""_BZXRES_""""
.......I @(BZXRES_COND_VALUE) D STORE
D ^BZXLRSEP
K ^TMP($J)
D ^%ZISC
Q
;
STORE ;Store data for printing
K BZXCOMM,BZXCMIN
S BZXFILE=$P(^LR(LRDFN,0),U,2)
S DFN=$P(^LR(LRDFN,0),U,3)
S PATNAM=$S(BZXFILE=2:$P(^DPT(DFN,0),U,1),BZXFILE=67:"*"_$P(^LRT(67,DFN,0),U,1),1:"UNK")
S IENS=DFN_","
S SEX=$$GET1^DIQ(BZXFILE,IENS,.02)
S DOB=$$GET1^DIQ(BZXFILE,IENS,.03)
Q:BZXFILE=67.3
I BZXFILE=67 D
.S ID=$P(^LRT(67,DFN,0),U,9)
.S (STREET,CITY,STATE,ZIP,PHONE,BZXCOMM,BZXCMIN)=""
E I BZXFILE=2 D
.S ID=$$HRN^AUPNPAT(DFN,DUZ(2))
.S Y=^DPT(DFN,.11)
.S STREET=$P(Y,U,1)
.S CITY=$P(Y,U,4)
.S ZIP=$P(Y,U,6)
.S IENS=DFN_","
.S STATE=$$GET1^DIQ(2,IENS,.115)
.S PHONE=$$GET1^DIQ(2,IENS,.131)
.S BZXCOMM=$$COMMRES^AUPNPAT(DFN,"E")
.S BZXCMIN=$$COMMRES^AUPNPAT(DFN,"I")
.I 'BZXCMIN D
..S BZXXCOMM=$P(^AUPNPAT(DFN,11),U,18)
..Q:BZXCOMM=""
..S BZXCMIN=$O(^AUTTCOM("B",BZXCOMM,""))
I BZXCMIN,$D(BZXGR),'$D(^BZXGRHR("B",BZXCMIN)) Q
I $D(BZXGR),'BZXCMIN Q
S ^TMP($J,D0,LRDFN,LRIDT)=PATNAM_U_ID_U_DOB_U_SEX_U_PHONE_U_STREET_U_CITY_U_STATE_U_ZIP_U_BZXCOMM_U_BZXRAWRS
Q
BZXLRSER ;IHS/PIMC/JLG - AZ HEALTH DEPT REPORT [ 10/09/2002 1:08 PM ]
+1 ;;1.0;Special local routine for reportable diseases
+2 ;This is designed to replace DWLRSER1
+3 ;It uses file 1966360 as the table of files to report
+4 ;It calls BZXLRSEP as the routine to do the actual printing
+5 ;
+6 SET DIR("A")="Enter start date"
+7 SET DIR(0)="D^:"_DT_":EPX"
+8 DO ^DIR
+9 IF $DATA(DIRUT)
Begin DoDot:1
+10 KILL DIR,DIRUT,DTOUT,DUOUT
End DoDot:1
QUIT
+11 SET BZXSDT=Y
+12 SET BZXVDT=Y-.5
GETEND SET DIR("A")="Enter end date"
+1 SET DIR(0)="D^:"_DT_":EPX"
+2 DO ^DIR
+3 IF $DATA(DIRUT)
Begin DoDot:1
+4 KILL DIR,DIRUT,DTOUT,DUOUT,BZXVDT
End DoDot:1
QUIT
+5 SET BZXENDT=Y
+6 IF BZXENDT<BZXVDT
Begin DoDot:1
+7 WRITE !,"End date cannot be before start date. Try again."
End DoDot:1
GOTO GETEND
+8 SET %ZIS="Q"
+9 DO ^%ZIS
+10 IF POP
QUIT
+11 IF $DATA(IO("Q"))
Begin DoDot:1
+12 SET ZTRTN="LP^BZXLRSER"
+13 SET ZTSAVE("BZX*")=""
+14 SET ZTDESC="Reportable diseases"
+15 DO ^%ZTLOAD
+16 KILL ZTSAVE,ZTDESC,ZTRTN,IO("Q")
End DoDot:1
QUIT
+17 ;
LP ;Start looping through tests
+1 KILL ^TMP($JOB)
+2 USE IO
+3 ;BZXVDT is both the verification date and the order date
+4 ;In effect we only look at the verification date
+5 FOR
SET BZXVDT=$ORDER(^LRO(69,BZXVDT))
IF 'BZXVDT!(BZXVDT>BZXENDT)
QUIT
Begin DoDot:1
+6 SET LOC=""
+7 FOR
SET LOC=$ORDER(^LRO(69,BZXVDT,1,"AN",LOC))
IF LOC=""
QUIT
Begin DoDot:2
+8 SET LRDFN=""
+9 FOR
SET LRDFN=$ORDER(^LRO(69,BZXVDT,1,"AN",LOC,LRDFN))
IF 'LRDFN
QUIT
Begin DoDot:3
+10 SET LRIDT=9999999-BZXVDT-.5
+11 SET X1=BZXVDT
+12 SET X2=-545
+13 DO C^%DTC
+14 SET LRIDTLM=9999999-X
+15 FOR
SET LRIDT=$ORDER(^LRO(69,BZXVDT,1,"AN",LOC,LRDFN,LRIDT))
IF 'LRIDT!(LRIDT>LRIDTLM)
QUIT
Begin DoDot:4
+16 IF '$DATA(^LR(LRDFN,"CH",LRIDT,0))
QUIT
+17 SET X=$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3)\1
+18 IF X'=BZXVDT
QUIT
+19 SET D0=0
+20 FOR
SET D0=$ORDER(^BZXRPTDS(D0))
IF 'D0
QUIT
Begin DoDot:5
+21 SET BZXTPTR=$PIECE(^BZXRPTDS(D0,0),U,1)
+22 SET BZXTYPE=$PIECE(@(U_$PIECE(^LAB(60,BZXTPTR,0),U,12)_"0)"),U,2)
+23 SET BZXDLOC=$PIECE(^LAB(60,BZXTPTR,0),U,5)
+24 IF '$DATA(^LR(LRDFN,"CH",LRIDT,$PIECE(BZXDLOC,";",2)))
QUIT
+25 SET BZXRES=$PIECE(^LR(LRDFN,"CH",LRIDT,$PIECE(BZXDLOC,";",2)),U,1)
+26 SET BZXFLD=$PIECE(^LAB(60,BZXTPTR,0),U,12)
+27 SET BZXRAWRS=BZXRES
+28 SET TRANS=$GET(^BZXRPTDS(D0,2))
+29 IF $LENGTH(TRANS)
Begin DoDot:6
+30 SET Y=BZXRES
+31 KILL X
+32 XECUTE TRANS
+33 IF '$DATA(X)
QUIT
+34 SET BZXRES=X
End DoDot:6
+35 IF $EXTRACT(BZXTYPE,1)="N"
Begin DoDot:6
+36 SET COND=$PIECE(^BZXRPTDS(D0,0),U,4)
+37 IF COND="EQ"
SET COND="="
+38 SET VALUE=$PIECE(^BZXRPTDS(D0,0),U,3)
+39 IF $EXTRACT(BZXRES,1)=">"
SET BZXRES=$PIECE(BZXRES,">",2)+1
+40 SET BZXRES=+BZXRES
+41 IF @(BZXRES_COND_VALUE)
DO STORE
End DoDot:6
+42 IF '$TEST
IF BZXTYPE="S"
Begin DoDot:6
+43 ;What the values stand for in the set
+44 SET BZXSTNFR=$PIECE(@(U_BZXFLD_"0)"),U,3)
+45 FOR I=1:1
SET Y=$PIECE(BZXSTNFR,";",I)
IF Y=""
QUIT
Begin DoDot:7
+46 IF $PIECE(Y,":",1)=BZXRAWRS
SET BZXRAWRS=$PIECE(Y,":",2)
End DoDot:7
+47 SET D1=0
+48 FOR
SET D1=$ORDER(^BZXRPTDS(D0,1,D1))
IF 'D1
QUIT
Begin DoDot:7
+49 SET VALUE=$PIECE(^BZXRPTDS(D0,1,D1,0),U,1)
+50 IF BZXRES=VALUE
DO STORE
End DoDot:7
End DoDot:6
+51 IF '$TEST
IF $EXTRACT(BZXTYPE,1)="F"
Begin DoDot:6
+52 SET D1=0
+53 FOR
SET D1=$ORDER(^BZXRPTDS(D0,4,D1))
IF 'D1
QUIT
Begin DoDot:7
+54 SET COND=$PIECE(^BZXRPTDS(D0,4,D1,0),U,2)
+55 SET COND=$SELECT(COND="C":"[",1:"=")
+56 SET VALUE=$PIECE(^BZXRPTDS(D0,4,D1,0),U,1)
+57 IF BZXRES'=+BZXRES
SET BZXRES=""""_BZXRES_""""
+58 IF @(BZXRES_COND_VALUE)
DO STORE
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+59 DO ^BZXLRSEP
+60 KILL ^TMP($JOB)
+61 DO ^%ZISC
+62 QUIT
+63 ;
STORE ;Store data for printing
+1 KILL BZXCOMM,BZXCMIN
+2 SET BZXFILE=$PIECE(^LR(LRDFN,0),U,2)
+3 SET DFN=$PIECE(^LR(LRDFN,0),U,3)
+4 SET PATNAM=$SELECT(BZXFILE=2:$PIECE(^DPT(DFN,0),U,1),BZXFILE=67:"*"_$PIECE(^LRT(67,DFN,0),U,1),1:"UNK")
+5 SET IENS=DFN_","
+6 SET SEX=$$GET1^DIQ(BZXFILE,IENS,.02)
+7 SET DOB=$$GET1^DIQ(BZXFILE,IENS,.03)
+8 IF BZXFILE=67.3
QUIT
+9 IF BZXFILE=67
Begin DoDot:1
+10 SET ID=$PIECE(^LRT(67,DFN,0),U,9)
+11 SET (STREET,CITY,STATE,ZIP,PHONE,BZXCOMM,BZXCMIN)=""
End DoDot:1
+12 IF '$TEST
IF BZXFILE=2
Begin DoDot:1
+13 SET ID=$$HRN^AUPNPAT(DFN,DUZ(2))
+14 SET Y=^DPT(DFN,.11)
+15 SET STREET=$PIECE(Y,U,1)
+16 SET CITY=$PIECE(Y,U,4)
+17 SET ZIP=$PIECE(Y,U,6)
+18 SET IENS=DFN_","
+19 SET STATE=$$GET1^DIQ(2,IENS,.115)
+20 SET PHONE=$$GET1^DIQ(2,IENS,.131)
+21 SET BZXCOMM=$$COMMRES^AUPNPAT(DFN,"E")
+22 SET BZXCMIN=$$COMMRES^AUPNPAT(DFN,"I")
+23 IF 'BZXCMIN
Begin DoDot:2
+24 SET BZXXCOMM=$PIECE(^AUPNPAT(DFN,11),U,18)
+25 IF BZXCOMM=""
QUIT
+26 SET BZXCMIN=$ORDER(^AUTTCOM("B",BZXCOMM,""))
End DoDot:2
End DoDot:1
+27 IF BZXCMIN
IF $DATA(BZXGR)
IF '$DATA(^BZXGRHR("B",BZXCMIN))
QUIT
+28 IF $DATA(BZXGR)
IF 'BZXCMIN
QUIT
+29 SET ^TMP($JOB,D0,LRDFN,LRIDT)=PATNAM_U_ID_U_DOB_U_SEX_U_PHONE_U_STREET_U_CITY_U_STATE_U_ZIP_U_BZXCOMM_U_BZXRAWRS
+30 QUIT
