Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BZXMIHDR

BZXMIHDR.m

Go to the documentation of this file. 
  1. BZXMIHDR ;IHS/PIMC/JLG- HEALTH DEPARTMENT REPORT ; 12/2/03
  1.  ;;5.1;LAB;;04/11/91 11:06
  1.  ;;;IHS/PIMC/JLG  - 12/2/03  Restructuring and revision without commenting at each place.
  1.  ;SLC/CJS,BA- HEALTH DEPARTMENT REPORT ;2/19/91 
  1.  ;MODIFIED BY WALZ
  1.  ;;;IHS/PIMC/vjm - 7/24/01 added INTROTXT sub-rtn
  1.  ;
  1.  Q:$D(BZX("QUIT"))    ; var will be set if '^' out of the Gila River
  1.  ;                    ; intro text DIR response - option:  BZXX DWMIHDR1
  1.  K ^UTILITY("MI",$J)
  1.  ;
  1.  ; start - vjm 4/14/2000 - setting subscript variable
  1.  S BZXSBSCR="MI"
  1.  ; end - vjm 4/14/2000
  1.  ;
  1.  I '$D(DT) W !,"VARIABLE DT NOT DEFINED ABORTING" Q
  1.  ;Begin modified code IHS/PIMC/JLG  12/6/00
  1. BEGIN S LREND=0,LREDT="T-1"
  1.  D ^LRWU3
  1.  I 'LREND D
  1.  .S ZTRTN="DQ^BZXMIHDR"
  1.  .S ZTSAVE("BZX*")=""
  1.  .D IO^LRWU
  1.  ;End modified code  12/6/00
  1. END K %DT,A,AGE,D0,DA,DFN,DIC,DL,DOB,DR,DX,I,LRACC,LRBUG,LROCCU,LRDFN,LRDPF,LRDT,LREDT,LREND,LRHC,LRIDT,LRMARST,DWSAMP,LRPHONE,LRRACE,LRSAMP,LRSDT,LRSPEC,LRWRD,POP,PNM,S,SEX,SSN,HRCN,X,Y,Z0,DWLOC  ;IHS/ANMC/CLS 10/03/92 HRCN
  1.  K DWPROV,DWPROVN,DWCOLDT,PEDT,PSDT,DWCITY,DWSTR,DWSTATE,DWPROV,DWBUG,DWCMPLDT,DWCOL,DWCPL,DWSTATN,DWZIP,FOOTFLG,II,III,LI,PG,PGM,PLG,PP,RACC,RPNM,J
  1.  ;
  1.  ; start - vjm 4/14/2000 - killing BZX variables
  1.  K BZXCOMM,BZX,BZXSBSCR
  1.  ; end - vjm 4/14/2000
  1.  ;
  1.  K:$D(ZTSK) ^%ZTSK(ZTSK),ZTSK D ^%ZISC
  1.  Q
  1. DQ K ^UTILITY("MI",$J) 
  1.  S FOOTFLG=0,PEDT=$E(LREDT,4,5)_"/"_$E(LREDT,6,7)_"/"_$E(LREDT,2,3),PSDT=$E(LRSDT,4,5)_"/"_$E(LRSDT,6,7)_"/"_$E(LRSDT,2,3)
  1.  D:$D(ZTSK) KILL^%ZTLOAD K ZTSK U IO
  1.  S LRDT=LREDT-.0001 F I=0:0 S LRDT=$O(^LR("AD",LRDT)) Q:LRDT<1!(LRDT>LRSDT)  D DATE Q:LREND
  1.  D PREPORT
  1.  Q
  1. DATE ;S DR=.11 
  1.  S LRBUG=0 F I=0:0 S LRBUG=$O(^LR("AD",LRDT,LRBUG)) Q:LRBUG<1  D LIST Q:LREND
  1.  Q
  1. LIST ;
  1.  S LRACC="" F I=0:0 S LRACC=$O(^LR("AD",LRDT,LRBUG,LRACC)) Q:LRACC=""  S LRDFN=^(LRACC) D SPEC,PAT,SETNODE 
  1.  Q
  1. SPEC S (LRIDT,LRSPEC,LRSAMP)=0 F I=0:0 S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1  D  Q:LRSPEC
  1.  .I $D(^LR(LRDFN,"MI",LRIDT,0)),$E(LRACC,1,$L(LRACC)-1)=$P(^LR(LRDFN,"MI",LRIDT,0),U,6) D
  1.  ..S LRSPEC=+$P(^LR(LRDFN,"MI",LRIDT,0),U,5),LRSAMP=+$P(^(0),U,11),DWPROVN=+$P(^(0),U,7),DWCOLDT=+$P(^(0),U,1) 
  1.  ..S DWCMPLDT=$S($D(^LR(LRDFN,"MI",LRIDT,1)):+$P(^(1),U,1),$D(^(11)):+$P(^(11),U,1),$D(^(5)):+$P(^(5),U,1),$D(^(8)):+$P(^(8),U,1),$D(^(16)):+$P(^(16),U,1),1:"")
  1.  ..S DWLOC=$P(^LR(LRDFN,"MI",LRIDT,0),U,8)
  1.  S DWPROV="" S:DWPROVN>0&($D(^VA(200,DWPROVN,0))) DWPROV=$P(^VA(200,DWPROVN,0),U,1)
  1.  S DWSAMP="" I LRSAMP,$D(^LAB(62,LRSAMP,0)) S DWSAMP=$P(^(0),U)
  1.  Q
  1. PAT S LRDPF=$P(^LR(LRDFN,0),U,2) Q:LRDPF=67.1  ;quit if research entry from file 67.1
  1.  ;
  1.  ; start - vjm 5/11/2000
  1.  S DFN=$P(^LR(LRDFN,0),U,3)   
  1.  I LRDPF=2 D BZXGR^BZXLRGR                 ;To print all communities, only defined for file 2
  1.  S DIC=^DIC(+LRDPF,0,"GL")
  1.  D PT^LRX
  1.  ; end - vjm 5/11/2000
  1.  ;
  1.  S X=DIC_DFN_",.13)"
  1.  S LRPHONE=$S($D(@X):$P(^(.13),U),1:""),LRRACE=$P(DIC_DFN_",0)",U,6),LRMARST=$P(^(0),U,5),LROCCU=$P(^(0),U,7)
  1.  S (DWSTR,DWCITY,DWSTATN,DWZIP,DWSTATE)=""
  1.  ;Begin mods to fix missing state  IHS/PIMC/JLG  12/1/03
  1.  ;I $D(^DPT(DFN,.11)) S DWSTR=$P(^DPT(DFN,.11),"^",1),DWCITY=$P(^(.11),"^",4),DWSTATN=+$P(^(.11),"^",5),DWZIP=$P(^(.11),"^",6),DWSTATE=$P(^DIC(5,DWSTATN,0),"^",1)
  1.  I $D(^DPT(DFN,.11)) D
  1.  .S DWSTR=$P(^DPT(DFN,.11),"^",1),DWCITY=$P(^(.11),"^",4),DWSTATN=+$P(^(.11),"^",5),DWZIP=$P(^(.11),"^",6)
  1.  .I DWSTATN S DWSTATE=$P(^DIC(5,DWSTATN,0),"^",1)
  1.  .E  S DWSTATE="No state"
  1.  ;End changes
  1.  Q
  1. SETNODE ;
  1.  ; start - vjm 5/11/2000 adding comm to the ^UTILITY temp gbl
  1.  D MICOMM^BZXLRGR         ;IHS/PIMC/JLG  12/6/00
  1.  Q                        ;IHS/PIMC/JLG  12/6/00
  1.  ; end - vjm 5/11/2000
  1.  
  1.  ;
  1. PREPORT ;
  1.  ; start - vjm 5/17/2000 - do Do block if no data to report
  1.  I '$D(^UTILITY("MI",$J)) D  Q
  1.  .  S PG=1
  1.  .  D RHEAD
  1.  .  K PG
  1.  .  W !?35,"**** NO DATA TO REPORT **** "
  1.  .  W @IOF
  1.  .  Q
  1.  ; end - vjm 5/17/2000
  1.  ;
  1.  S PG=1,DWBUG="" F I=0:0 S DWBUG=$O(^UTILITY("MI",$J,DWBUG))  Q:DWBUG=""  D RLOOP1
  1.  D FOOTER W @IOF
  1.  K ^UTILITY("MI",$J)
  1.  Q
  1. RLOOP1 D:FOOTFLG=1 FOOTER
  1.  W @IOF D RHEAD  ;W !,"Reporting Organism: "_DWBUG,!
  1.  S RPNM="" F II=0:0 S RPNM=$O(^UTILITY("MI",$J,DWBUG,RPNM))  Q:RPNM=""  D RLOOP2
  1.  Q
  1. RLOOP2 S RACC="" F III=0:0 S RACC=$O(^UTILITY("MI",$J,DWBUG,RPNM,RACC))  Q:RACC=""  D PRTIT
  1.  Q
  1. PRTIT ; print patient data
  1.  W !!,$E(RPNM,1,28) ;NAME
  1.  W ?30,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",6) ;HRN
  1.  W ?40,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",7) ;DOB
  1.  W ?54,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",8) ;SEX
  1.  W ?58,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",4) ;ACCN
  1.  W ?70,$E($P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",1),1,12) ;SPEC
  1.  S DWCOL=$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",3) W ?84,$E(DWCOL,4,5)_"/"_$E(DWCOL,6,7)_"/"_$E(DWCOL,2,3) ;COL DT
  1.  S DWCPL=$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",5) W ?94,$E(DWCPL,4,5)_"/"_$E(DWCPL,6,7)_"/"_$E(DWCPL,2,3) ;CPL DT
  1.  W ?106,$E($P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",2),1,25) ;PROV
  1.  W !,?5,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",9) ;PHONE
  1.  W ?30,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",10) ;STREET
  1.  W ?64,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",11) ;CITY
  1.  W ?84,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",12) ;STATE
  1.  W ?98,$P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",13) ;ZIP
  1.  W ?106,$E($P(^UTILITY("MI",$J,DWBUG,RPNM,RACC),"^",14),1,25) ;LOC
  1.  ;
  1.  ; start - vjm 5/15/2000 - adding comm to these write statements
  1.  D COMM^BZXLRGR    ;IHS/PIMC/JLG   12/6/00
  1.  ; end - vjm
  1.  ;
  1.  I $Y>50 D FOOTER W @IOF D RHEAD
  1.  Q
  1. RHEAD W "AZ HEALTH DEPARTMENT REPORT",?51,"Phoenix Indian Medical Center",!,?46,"4212 N. 16th St., Phoenix, AZ  85016",!,"From "_PEDT_" to "_PSDT,?53,"****** CONFIDENTIAL ******",?98,"Printed: "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),?120,"Page: "_PG,!
  1.  W !,"Name",?30,"ID#",?40,"DOB",?54,"Sex",?58,"Lab #",?70,"Sample",?84,"Col Dt",?94,"Cpl Dt",?106,"Provider",!,?5,"Phone #",?30,"Address",?106,"Location"
  1.  ;
  1.  ; start - vjm 5/15/2000
  1.  ;Modified to print current community on all reports
  1.  W !?5,"Current Community"               ;IHS/PIMC/JLG  12/6/00
  1.  ; end - vjm
  1.  ;
  1.  W ! F LI=0:1:IOM-1 W ?LI,"-"
  1.  W ! S PG=PG+1,FOOTFLG=1
  1.  W !,"Reporting Organism: "_DWBUG,!
  1.  Q
  1.  W "________________________________________            _______________"
  1.  W !,"   Medical Technologist                                   Date"
  1.  Q
  1.  ;
  1.  ;====================================================================
  1. INTROTXT ; introduction text of this Local Health Department [Gila River] report
  1.  ;
  1.  W !!!
  1.  W "This report prints Arizona Health Department organisms which have",!
  1.  W "been identified during the date interval selected.  The report",!
  1.  W "is for patients residing only in selected Gila River communities.",!!
  1.  W "NOTE:  This report requires a COMPRESSED (132 characters/line) printer!",!!
  1.  K DIRUT
  1.  S DIR(0)="E",DIR("A")="Press <Return> to continue or '^' to quit"
  1.  D ^DIR K DIR,DA
  1.  S:$D(DIRUT) BZX("QUIT")=1
  1.  Q:$D(BZX("QUIT"))
  1.  W:$D(IOF) @IOF
  1.  Q
  1.  ;
  1.  ;
  1. BZXGR ; processing for Gila River Community pts
  1.  ; ^BZXGRHD --> BZX DWMIHDR1 GILA RIVER HLTH RPT COMMUNITIES file
  1.  ;
  1.  S BZX("COMM IEN")=0
  1.  S BZX("COMM IEN")=$$COMMRES^AUPNPAT(DFN,"I")
  1.  ;
  1.  ; do this IF the ptr value for CURRENT COMMUNITY does not exist
  1.  I '+BZX("COMM IEN") D
  1.  .  S BZX("COMM NAME")=$P(^AUPNPAT(DFN,11),U,18)
  1.  .  S BZX("COMM IEN")=$O(^AUTTCOM("B",BZX("COMM NAME"),0))
  1.  .  Q
  1.  ;
  1.  ; get IEN of the local BZX gila river community list
  1.  S BZX("IEN")=$O(^BZXGRHR("B",BZX("COMM IEN"),0))
  1.  ;
  1.  I '+BZX("IEN") D BZXKVARS Q      ; QUIT if no entry in local file
  1.  S BZXCOMM=$$COMMRES^AUPNPAT(DFN,"E")
  1.  D BZXKVARS
  1.  Q
  1. BZXKVARS ; clean up the BZX vars
  1.  K BZX
  1.  Q
  1.  ; end of routine