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

BWDIAG.m

Go to the documentation of this file. 
  1. BWDIAG ;IHS/ANMC/MWR - PRINTOUT OF BW DIAGNOSIS FILE;15-Feb-2003 21:50;PLS
  1.  ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  CALLED BY OPTION: "BW PRINT RES/DIAG FILE" TO PRINT THE
  1.  ;;  RESULTS/DIAGNOSIS TABLE FILE.
  1.  ;
  1.  D SETUP
  1.  D TITLE^BWUTL5("LISTING OF RESULTS/DIAGNOSIS FILE")
  1.  D DEVICE Q:BWPOP
  1.  D SORT
  1.  D DISPLAY
  1.  ;
  1. EXIT ;EP
  1.  D KILLALL^BWUTL8
  1.  Q
  1.  ;
  1. SETUP ;EP
  1.  D SETVARS^BWUTL5 S BWPOP=0
  1.  S BWLINE="-" F I=1:1:79 S BWLINE=BWLINE_"-"
  1.  Q
  1.  ;
  1. DEVICE ;EP
  1.  ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
  1.  S ZTRTN="DEQUEUE^BWDIAG"
  1.  F BWSV="BWLINE","BWTITLE" D
  1.  .I $D(BWSV) S ZTSAVE(BWSV)=""
  1.  D ZIS^BWUTL2(.BWPOP,1)
  1.  Q
  1.  ;
  1. SORT ;EP
  1.  ;---> SORT BY RESULT/DIAGNOSIS.  STORED IN ^TMP("BW",$J,1
  1.  N N,X,Y K ^TMP("BW",$J)
  1.  S N=0
  1.  F  S N=$O(^BWDIAG("B",N)) Q:N=""  D
  1.  .S M=$O(^BWDIAG("B",N,0))
  1.  .S Y=^BWDIAG(M,0),BWDIAG=N
  1.  .F I=3:1:19 I $P(Y,U,I) D
  1.  ..S BWPN=$E($P(^BWPN($P(Y,U,I),0),U),1,30)
  1.  ..S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
  1.  ..S BWPRIO=$P(Y,U,2)
  1.  ..S X=BWDIAG_U_BWPRIO_U_BWNORM_U_BWPN
  1.  ..S ^TMP("BW",$J,1,BWDIAG,BWPN,1)=X
  1.  .I $P(Y,U,20) D
  1.  ..S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
  1.  ..S BWPRIO=$P(Y,U,2),BWPN="ALL PROCEDURES"
  1.  ..S X=BWDIAG_U_BWPRIO_U_BWNORM_U_BWPN
  1.  ..S ^TMP("BW",$J,1,BWDIAG,BWPN,1)=X
  1.  ;
  1.  ;---> SORT BY PROCEDURE TYPE.  STORED IN ^TMP("BW",$J,2
  1.  S N=0
  1.  F  S N=$O(^BWDIAG("P",N)) Q:N=""  D
  1.  .S M=0
  1.  .F  S M=$O(^BWDIAG("P",N,M)) Q:M=""  D
  1.  ..S Y=^BWDIAG(M,0)
  1.  ..S BWPN=$P(^BWPN(N,0),U),BWDIAG=$P(Y,U)
  1.  ..S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
  1.  ..S BWPRIO=$P(Y,U,2)
  1.  ..S X=BWPN_U_BWDIAG_U_BWPRIO_U_BWNORM
  1.  ..S ^TMP("BW",$J,2,BWPN,BWPRIO,BWDIAG)=X
  1.  ;
  1.  ;---> ASSOCIATED WITH ALL PROCEDURES
  1.  S N=0
  1.  F  S N=$O(^BWDIAG(N)) Q:'N  D
  1.  .S Y=^BWDIAG(N,0)
  1.  .Q:'$P(Y,U,20)
  1.  .S BWDIAG=$P(Y,U),BWPRIO=$P(Y,U,2)
  1.  .S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
  1.  .S M=0
  1.  .F  S M=$O(^BWPN(M)) Q:'M  D
  1.  ..S BWPN=$P(^BWPN(M,0),U)
  1.  ..Q:$P(^BWPN(M,0),U,12)
  1.  ..S X=BWPN_U_BWDIAG_U_BWPRIO_U_BWNORM
  1.  ..S ^TMP("BW",$J,2,BWPN,BWPRIO,BWDIAG)=X
  1.  ;
  1.  ;---> SORT BY PRIORITY.  STORED IN ^TMP("BW",$J,3
  1.  S N=0
  1.  F  S N=$O(^BWDIAG("B",N)) Q:N=""  D
  1.  .S M=$O(^BWDIAG("B",N,0))
  1.  .S Y=^BWDIAG(M,0),BWDIAG=N,BWPRIO=$P(Y,U,2)
  1.  .S X=$P(Y,U,21),BWNORM=$S(X=0:"NORMAL",X=2:"NO RES",1:"ABNORM")
  1.  .S X=BWDIAG_U_BWPRIO_U_BWNORM
  1.  .S ^TMP("BW",$J,3,BWPRIO,BWDIAG,1)=X
  1.  ;
  1.  ;---> COPY TO TMP IN A SINGLE SUBSCRIPT.
  1.  F BWS=1,2,3 S BWSS=BWS_BWS D COPYGBL
  1.  Q
  1.  ;
  1. DISPLAY ;EP
  1.  U IO
  1.  S BWTITLE1="*  WOMEN'S HEALTH: LISTING OF RESULTS/DIAGNOSIS FILE  *"
  1.  D CENTERT^BWUTL5(.BWTITLE1)
  1.  S BWCRT=$S($E(IOST)="C":1,1:0),(BWPAGE,BWPOP)=0
  1.  F BWI=22,33,11 D @("DISPLY"_BWI) Q:BWPOP
  1.  W:'BWCRT @IOF
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. DISPLY11 ;EP
  1.  ;---> LIST BY RESULT/DIAGNOSIS
  1.  ;Q
  1.  S BWTITLE2=" * BY DIAGNOSIS *" D CENTERT^BWUTL5(.BWTITLE2)
  1.  S BWSUB="W !?3,""RESULT/DIAGNOSIS"",?31,""PRIORITY"",?42,""NORMAL"","
  1.  S BWSUB=BWSUB_"?50,""ASSOCIATED PROCEDURES"""
  1.  N Z S (BWPOP,N,Z)=0
  1.  W:BWCRT @IOF D HEADER
  1.  F  S N=$O(^TMP("BW",$J,BWI,N)) Q:'N!(BWPOP)  D
  1.  .I $Y+8>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP  D HEADER
  1.  .S Y=^TMP("BW",$J,BWI,N) W !
  1.  .I $P(Y,U)'=Z W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?42,$P(Y,U,3)
  1.  .W ?50,$P(Y,U,4)
  1.  .S Z=$P(Y,U)
  1.  I BWCRT&('BWPOP) W !! D DIRZ^BWUTL3
  1.  Q
  1.  ;
  1. DISPLY22 ;EP
  1.  ;---> LIST BY RESULT/DIAGNOSIS
  1.  S BWTITLE2=" * BY PROCEDURE *" D CENTERT^BWUTL5(.BWTITLE2)
  1.  S BWSUB="W !?3,""PROCEDURE"",?35,""RESULT/DIAGNOSIS"""
  1.  S BWSUB=BWSUB_",?62,""PRIORITY"",?72,""NORMAL"""
  1.  N Z S (BWPOP,N,Z)=0
  1.  W:BWCRT @IOF D HEADER
  1.  F  S N=$O(^TMP("BW",$J,BWI,N)) Q:'N!(BWPOP)  D
  1.  .I $Y+6>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP  D HEADER
  1.  .S Y=^TMP("BW",$J,BWI,N) W !
  1.  .I $P(Y,U)'=Z W !?3,$P(Y,U)
  1.  .W ?35,$P(Y,U,2),?68,$J($P(Y,U,3),2),?72,$P(Y,U,4)
  1.  .S Z=$P(Y,U)
  1.  I BWCRT&('BWPOP) W !! D DIRZ^BWUTL3
  1.  Q
  1.  ;
  1. DISPLY33 ;EP
  1.  ;---> LIST BY RESULT/DIAGNOSIS
  1.  S BWTITLE2=" * BY PRIORITY *" D CENTERT^BWUTL5(.BWTITLE2)
  1.  S BWSUB="W !?3,""RESULT/DIAGNOSIS"",?32,""PRIORITY"",?44,""NORMAL"""
  1.  N Z S (BWPOP,N,Z)=0
  1.  W:BWCRT @IOF D HEADER
  1.  F  S N=$O(^TMP("BW",$J,BWI,N)) Q:'N!(BWPOP)  D
  1.  .I $Y+6>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP  D HEADER
  1.  .S Y=^TMP("BW",$J,BWI,N)
  1.  .W !?3,$P(Y,U),?37,$J($P(Y,U,2),2),?44,$P(Y,U,3)
  1.  .S Z=$P(Y,U)
  1.  I BWCRT&('BWPOP) W !! D DIRZ^BWUTL3
  1.  Q
  1.  ;
  1.  ;
  1.  W:BWPAGE @IOF S BWPAGE=BWPAGE+1,Z=0
  1.  W BWTITLE1,?70,"PAGE ",BWPAGE,!,BWTITLE2
  1.  W !,BWLINE X BWSUB W !,BWLINE
  1.  Q
  1.  ;
  1. COPYGBL ;EP
  1.  ;---> COPY ^TMP("BW",$J,BWS TO ^TMP("BW",$J,BWSS TO MAKE IT FLAT.
  1.  N I,M,N,P,Q
  1.  S N=0,I=0
  1.  F  S N=$O(^TMP("BW",$J,BWS,N)) Q:N=""  D
  1.  .S M=0
  1.  .F  S M=$O(^TMP("BW",$J,BWS,N,M)) Q:M=""  D
  1.  ..S P=0
  1.  ..F  S P=$O(^TMP("BW",$J,BWS,N,M,P)) Q:P=""  D
  1.  ...S I=I+1,^TMP("BW",$J,BWSS,I)=^TMP("BW",$J,BWS,N,M,P)
  1.  Q
  1.  ;
  1. DEQUEUE ;EP
  1.  ;---> CALLED BY TASKMAN
  1.  D SETVARS^BWUTL5,SORT,DISPLAY,EXIT
  1.  Q