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

BCHVD.m

Go to the documentation of this file. 
  1. BCHVD ; IHS/CMI/LAB - BROWSE VISITS ; 
  1.  ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1.  ;
  1.  ;
  1. START ;
  1.  NEW BCHX,BCHY,BCHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
  1.  NEW D,R
  1.  K BCHV
  1.  W:$D(IOF) @IOF
  1.  W $$CTR("Browse CHR Visits",80)
  1. PAT ;
  1.  S DFN=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Patient Selected." Q
  1.  S DFN=+Y
  1.  S Y=DFN D ^AUPNPAT
  1. WHICH ;
  1.  S BCHQUIT=0
  1.  S BCHW=""
  1.  S DIR(0)="S^L:Patient's Last Visit;N:Patient's Last N Visits;D:Visits in a Date Range;A:All of this Patient's Visits"
  1.  S DIR("A")="Browse which subset of visits for "_$P(^DPT(DFN,0),U),DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  S BCHW=Y
  1.  D @BCHW Q:BCHQUIT
  1.  ;
  1. BROWSE ;
  1.  K ^TMP("BCHVD",$J)
  1.  D GATHER
  1.  D EN^VALM("BCH BROWSE VISITS")
  1.  K ^TMP("BCHVD",$J)
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1. END ;
  1.  K BCHP,BCHQUIT,BCHW
  1.  Q
  1.  ;
  1. EP(DFN) ;EP to list for one patient
  1.  NEW BCHX,BCHY,BCHR0,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
  1.  D FULL^VALM1
  1.  NEW D,R
  1.  K BCHV
  1.  I '$G(DFN) D PAT Q
  1.  W:$D(IOF) @IOF
  1.  W $$CTR("Browse CHR Visits",80)
  1.  S Y=DFN D ^AUPNPAT
  1.  D WHICH
  1.  Q
  1. L ;get patients last visit
  1.  ;BCHV array
  1.  I '$D(^BCHR("AE",DFN)) W !!,"No visits on file for this patient.",! S BCHQUIT=1 Q
  1.  S D=$O(^BCHR("AE",DFN,"")),R=$O(^BCHR("AE",DFN,D,""))
  1.  I R S BCHV(D,R)=""
  1.  Q
  1. N ;patients last N visits
  1.  S N=""
  1.  S DIR(0)="N^1:99:0",DIR("A")="How many visits should be displayed",DIR("B")="5" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S BCHQUIT=1 Q
  1.  S N=Y
  1.  S (C,D)=0 F  S D=$O(^BCHR("AE",DFN,D)) Q:D'=+D!(C=N)  S V=0 F  S V=$O(^BCHR("AE",DFN,D,V)) Q:V'=+V!(C=N)  S C=C+1,BCHV(D,V)=""
  1.  Q
  1. A ;all visits
  1.  S D=0,V=0
  1.  F  S D=$O(^BCHR("AE",DFN,D)) Q:D'=+D  S V=0 F  S V=$O(^BCHR("AE",DFN,D,V)) Q:V'=+V  S BCHV(D,V)=""
  1.  Q
  1. D ;date range
  1.  K BCHED,BCHBD
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date of Visit"
  1.  D ^DIR S:Y<1 BCHQUIT=1 Q:Y<1  S BCHBD=Y
  1.  K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Date of Visit"
  1.  D ^DIR S:Y<1 BCHQUIT=1 Q:Y<1  S BCHED=Y
  1.  ;
  1.  I BCHED<BCHBD D  G D
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  S E=9999999-BCHBD,D=9999999-BCHED-1_".99" F  S D=$O(^BCHR("AE",DFN,D)) Q:D'=+D!($P(D,".")>E)  S V=0 F  S V=$O(^BCHR("AE",DFN,D,V)) Q:V'=+V  S BCHV(D,V)=""
  1.  Q
  1. PRINT ;EP - called from xbdbque
  1.  S BCHQUIT=0
  1.  ;gather up all visit records in ^TMP("BCHVD",$J
  1.  D GATHER
  1.  D PRINT1
  1.  K ^TMP("BCHVD",$J)
  1.  Q
  1.  ;
  1. PRINT1 ;
  1.  W:$D(IOF) @IOF
  1.  NEW BCHX
  1.  S BCHX=0 F  S BCHX=$O(^TMP("BCHVD",$J,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT)  D
  1.  .I $Y>(IOSL-5) D FF Q:BCHQUIT
  1.  .W !,^TMP("BCHVD",$J,BCHX,0)
  1.  .Q
  1.  Q
  1. GATHER ;
  1.  K ^TMP("BCHVD",$J)
  1.  NEW BCHX,BCHI,BCHJ,BCHY,BCHZ,BCHC,BCHD
  1.  S BCHC=0
  1.  S X="Patient Name: "_$P(^DPT(DFN,0),U),$E(X,45)="DOB: "_$$FMTE^XLFDT($P(^DPT(DFN,0),U,3)) D S(X)
  1.  S X="HRN: "_$$HRN^AUPNPAT(DFN,DUZ(2)) D S(X)
  1.  S X=$TR($J("",80)," ","*") D S(X)
  1.  S BCHV=0,BCHD=0
  1.  F  S BCHD=$O(BCHV(BCHD)) Q:BCHD'=+BCHD  S BCHV=0 F  S BCHV=$O(BCHV(BCHD,BCHV)) Q:BCHV'=+BCHV  D
  1.  .S BCHR0=^BCHR(BCHV,0)
  1.  .S X="Visit Date: "_$$FMTE^XLFDT($P(BCHR0,U)),$E(X,45)="Provider: "_$$PPNAME^BCHUTIL(BCHV) D S(X,1)
  1.  .S X="Program: "_$$VAL^XBDIQ1(90002,BCHV,.02) D S(X)
  1.  .S X="Activity Location: "_$$VAL^XBDIQ1(90002,BCHV,.06),$E(X,45)="Travel Time: "_$$VAL^XBDIQ1(90002,BCHV,.11) D S(X)
  1.  .;I $P(BCHR0,U,7)]""!($P(BCHR0,U,8)]"") S X="Referred BY: "_$$VAL^XBDIQ1(90002,BCHV,.07),$E(X,45)="Referred TO: "_$$VAL^XBDIQ1(90002,BCHV,.08) D S(X)
  1.  .;table both and print 1,2,3,etc
  1.  .NEW BCHREFB,BCHREFT,C
  1.  .S X=0,C=0 F  S X=$O(^BCHR(BCHV,41,X)) Q:X'=+X  S C=C+1,BCHREFB(C)=$P(^BCHTREF($P(^BCHR(BCHV,41,X,0),U),0),U,1)
  1.  .S X=0,C=0 F  S X=$O(^BCHR(BCHV,42,X)) Q:X'=+X  S C=C+1,BCHREFT(C)=$P(^BCHTREF($P(^BCHR(BCHV,42,X,0),U),0),U,1)
  1.  .S X="",$E(X)="Referred to CHR by: ",$E(X,45)="Referred by CHR to: " D S(X)
  1.  .F X=1:1:20 I $D(BCHREFB(X))!($D(BCHREFT(X))) D
  1.  ..S Y="",$E(Y,5)=$G(BCHREFB(X)),$E(Y,48)=$G(BCHREFT(X)) D S(Y)
  1.  .I $P(BCHR0,U,13)]""!($P(BCHR0,U,14)]"") S X="LMP: "_$$VAL^XBDIQ1(90002,BCHV,.13),$E(X,45)="Fam Plan Method: "_$$VAL^XBDIQ1(90002,BCHV,.14) D S(X)
  1.  .F BCHF=1201:1:1210 S BCH1=+$E(BCHF,3,4) I $P($G(^BCHR(BCHV,12)),U,BCH1)]"" S X=$P(^DD(90002,BCHF,0),U,1)_": "_$$VAL^XBDIQ1(90002,BCHV,BCHF) D S(X)
  1.  .F BCHF=1301:1:1308 S BCH1=+$E(BCHF,3,4) I $P($G(^BCHR(BCHV,13)),U,BCH1)]"" S X=$P(^DD(90002,BCHF,0),U,1)_": "_$$VAL^XBDIQ1(90002,BCHV,BCHF) D S(X)
  1.  .S X="POV's:" D S(X)
  1.  .S BCHP=0 F  S BCHP=$O(^BCHRPROB("AD",BCHV,BCHP)) Q:BCHP'=+BCHP  D
  1.  ..S X="",$E(X,3)=$$VAL^XBDIQ1(90002.01,BCHP,.01),$E(X,30)=$E($$VAL^XBDIQ1(90002.01,BCHP,.06),1,65) D S(X)
  1.  ..S X="",$E(X,3)=$$VAL^XBDIQ1(90002.01,BCHP,.04),$E(X,30)=$$VAL^XBDIQ1(90002.01,BCHP,.05) D S(X)
  1.  ..Q
  1.  .;SUB/OBJ
  1.  .S X="",$E(X,3)="SUBJECTIVE:  " D S(X,1)
  1.  .S BCHX=0 F  S BCHX=$O(^BCHR(BCHV,51,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT)  D
  1.  ..S X="",$E(X,3)=^BCHR(BCHV,51,BCHX,0) D S(X)
  1.  ..Q
  1.  .S X="",$E(X,3)="OBJECTIVE:  " D S(X,1)
  1.  .S BCHX=0 F  S BCHX=$O(^BCHR(BCHV,61,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT)  D
  1.  ..S X="",$E(X,3)=^BCHR(BCHV,61,BCHX,0) D S(X)
  1.  ..Q
  1.  .S X="",$E(X,3)="PLAN:  " D S(X,1)
  1.  .S BCHX=0 F  S BCHX=$O(^BCHR(BCHV,71,BCHX)) Q:BCHX'=+BCHX!(BCHQUIT)  D
  1.  ..S X="",$E(X,3)=^BCHR(BCHV,71,BCHX,0) D S(X)
  1.  ..Q
  1.  .S X=$TR($J("",80)," ","*") D S(X)
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. FF ;EP
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT=1 Q
  1.  I $E(IOST)'="C" Q:'$P(BCHR0,U,8)  W !!,$TR($J(" ",79)," ","*"),!,$P(^DPT($P(BCHR0,U,8),0),U),?32,"HRN: " D
  1.  .S H=$P($G(^AUPNPAT($P(BCHR0,U,8),41,DUZ(2),0)),U,2)
  1.  .W H,?46,"DOB: ",$$FMTE^XLFDT($P(^DPT($P(BCHR0,U,8),0),U,3),"2D"),?59,"SSN: ","XXX-XX-"_$E($P(^DPT($P(BCHR0,U,8),0),U,9),6,9),!
  1.  W:$D(IOF) @IOF
  1.  Q
  1. HDR ; -- header code
  1.  Q
  1.  ;
  1. S(Y,F,C,T) ;EP - set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  NEW X
  1.  ;blank lines
  1.  F F=1:1:F S X="" D S1
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  D S1
  1.  Q
  1. S1 ;
  1.  S BCHC=BCHC+1
  1.  S ^TMP("BCHVD",$J,BCHC,0)=X
  1.  Q
  1. INIT ; -- init variables and list array
  1.  S VALMCNT=$O(^TMP("BCHVD",$J,""),-1)
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q