- 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
