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

BSDX42.m

Go to the documentation of this file. 
  1. BSDX42 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
  1.  ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
  1.  ;
  1. ZIS ;
  1.  S Y=DFN
  1.  I $D(DIRUT) D EXIT Q
  1.  S APCHOPT=Y
  1.  S XBRP="PRINT^BSDX42",XBRC="",XBRX="EXIT^BSDX42",XBNS="APCH;DFN"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1.  ;
  1. WISDW(DFN,SDATE,EMSG) ;PEP; print Wellness handout
  1.  ; .EMSG = returned error message if error
  1.  ;
  1.  I +DFN=0 Q
  1.  ;
  1.  NEW DGPGM,VAR,VAR1,DEV,POP
  1.  S SDX="ALL",ORDER="",SDREP=0,SDSTART="",DIV=$$DIV^BSDU
  1.  ;
  1.  S DGPGM="PRINT^BSDX42"
  1.  S DEV=".11"   ;default printer fields
  1.  S BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)
  1.  I BDGDEV="" K BDGDEV S EMSG="PCC Health Summary could not be printed: no default "_$S(BSDMODE="CR":"chart request",1:"walk in")_" printer defined in the IHS SCHEDULING PARAMETERS table." Q
  1.  S IOP=BDGDEV D ^%ZIS I POP D END^SDROUT1 Q
  1.  D PRINT
  1.  Q
  1.  ;
  1. EXIT ;
  1.  D EN^XBVK("APCH")
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. PRINT ;
  1. OUTPUT ;
  1.  U IO
  1.  S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
  1.  K ^TMP("APCH",$J)
  1.  D EP(DFN) ;gather up data
  1. W ;write out array
  1.  ;W:$D(IOF) @IOF
  1.  K APCHQUIT
  1.  W !,"********** Patient Wellness Handout ********** ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********"
  1.  S APCHX=0 F  S APCHX=$O(^TMP($J,"APCHPWH",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT))  D
  1.  .I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)
  1.  .W !,^TMP($J,"APCHPWH",APCHX)
  1.  .Q
  1.  I $D(APCHQUIT) S APCHSQIT=1
  1.  D EOJ
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. EOJ ;
  1.  ;
  1.  K ^TMP("APCHPHS",$J)
  1.  K ^TMP($J,"APCHPWH")
  1.  D EN^XBVK("APCH")
  1.  D EN^XBVK("APCD")
  1.  K BIDLLID,BIDLLPRO,BIDLLRUN,BIRESULT,BISITE
  1.  K AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
  1.  K N,%,T,F,X,Y,B,C,E,F,H,J,L,N,P,T,W,ST,ST0
  1.  Q
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF
  1.  W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!!
  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. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. EP(APCHSDFN) ;PEP - PASS DFN get back array of patient care summary
  1.  ;at this point you are stuck with ^TMP("APCHPHS",$J,"PMH"
  1.  ;CHANGE TO GO TO NEW PWH 
  1.  S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))
  1.  D EP1(APCHSDFN,APCHPWHT)
  1.  Q
  1. EP1(APCHSDFN,APCHPWHT,APCHPRTH) ;PEP - PASS DFN get back array of patient wellness handout
  1.  ;handout returned in ^TMP("APCHPHS",$J,"APCHPWH"
  1.  ;APCHPWHT - ien of the PWH type
  1.  ;APCHPRTH - 1 if you don't want the header line printed
  1.  K ^TMP($J,"APCHPWH")
  1.  S ^TMP($J,"APCHPWH",0)=0
  1.  I '$G(APCHPWHT) S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))
  1.  I '$G(APCHPWHT) Q
  1.  D SETARRAY
  1.  Q
  1. SETARRAY ;set up array containing pwh
  1.  ;all handouts get this demographic section
  1.  NEW X,APCHPRV,APCHSO,APCHSCMP,APCHSCMI
  1.  I '$G(APCHPRTH) S X="My Wellness Handout",$E(X,40)="Report Date:  "_$$FMTE^XLFDT(DT) D S(X)
  1.  S X="********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********" D S(X)
  1.  ;S X=$P($P(^DPT(APCHSDFN,0),U),",",2)_" "_$P($P(^DPT(APCHSDFN,0),U),",")_"   HRN:  "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U)) D S(X,1)
  1.  S X=$P(^DPT(APCHSDFN,0),U)_"   HRN:  "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U)) D S(X,1)
  1.  S X=$$VAL^XBDIQ1(2,APCHSDFN,.111)
  1.  S $E(X,50)=$$VAL^XBDIQ1(9999999.06,DUZ(2),.15)_$S($$VAL^XBDIQ1(9999999.06,DUZ(2),.15)]"":", ",1:" ")_$S($P($G(^AUTTLOC(DUZ(2),0)),U,14):$P(^DIC(5,$$VALI^XBDIQ1(9999999.06,DUZ(2),.16),0),U,2),1:"")_"  "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.17) D S(X)
  1.  S X=$$VAL^XBDIQ1(2,APCHSDFN,.114)_$S($$VAL^XBDIQ1(2,APCHSDFN,.114)]"":",  ",1:" ")_$$VAL^XBDIQ1(2,APCHSDFN,.115)_"   "_$$VAL^XBDIQ1(2,APCHSDFN,.116)
  1.  S APCHPRV=$$DPCP(APCHSDFN)
  1.  I APCHPRV D
  1.  .S $E(X,50)=$P(^VA(200,APCHPRV,0),U) D S(X)
  1.  I 'APCHPRV D S(X)
  1.  S X=$$VAL^XBDIQ1(2,APCHSDFN,.131),$E(X,50)=$P(^AUTTLOC(DUZ(2),0),U,11) D S(X)  ;put provider phone at 50
  1.  ;I $G(APCDVSIT)]"",$D(^AUPNVSIT("AC",APCHSDFN,APCDVSIT)) S APCHPROV=$$PRIMPROV^APCLV(APCDVSIT)
  1.  ;S X="Hello "_$S($$SEX^AUPNPAT(APCHSDFN)="M":"Mr. ",1:"Ms. ")_$E($P($P(^DPT(APCHSDFN,0),U),","))_$$LOW^XLFSTR($E($P($P(^DPT(APCHSDFN,0),U),","),2,99))_"," D S(X,1)
  1.  S X="Thank you for choosing "_$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U))_"." D S(X,1)
  1.  S X="This handout is a new way for you and your doctor to look at your health." D S(X)
  1.  ;now process each component assigned to this type
  1.  ;
  1. COMPS ;
  1.  I $$AGE^AUPNPAT(APCHSDFN)<18 D S("This handout is designed for patients 18 years of age and older.",2) Q
  1.  S APCHSORD=0 F  S APCHSORD=$O(^APCHPWHT(APCHPWHT,1,APCHSORD)) Q:APCHSORD'=+APCHSORD  D
  1.  .S APCHSCMP=$P(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,2)
  1.  .Q:'APCHSCMP
  1.  .Q:'$D(^APCHPWHC(APCHSCMP,0))
  1.  .S APCHSCMI=$P(^APCHPWHC(APCHSCMP,0),U,2)
  1.  .D @($P(APCHSCMI,";",1)_U_$P(APCHSCMI,";",2))
  1.  S X="******** END CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" ********" D S(X,2)
  1.  ;
  1. DPCP(P) ;EP
  1.  NEW R
  1.  D ALLDP^BDPAPI(P,"DESIGNATED PRIMARY PROVIDER",.R)
  1.  I $D(R("DESIGNATED PRIMARY PROVIDER")) Q $P(R("DESIGNATED PRIMARY PROVIDER"),U,2)
  1.  S R=$P(^AUPNPAT(P,0),U,14) I R Q R
  1.  S R=""
  1.  Q R
  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 %=$P(^TMP($J,"APCHPWH",0),U)+1,$P(^TMP($J,"APCHPWH",0),U)=%
  1.  S ^TMP($J,"APCHPWH",%)=X
  1.  Q
  1.  ;
  1. WISD(DFN,SDATE,BSDMODE,BSDDEV,BSDNHS,EMSG) ;PEP; print routing slip for walkin/same day appt
  1.  ; .EMSG = returned error message if error
  1.  ;
  1.  I +DFN=0 Q
  1.  ;***** END 10/21/04
  1.  ;
  1.  NEW DGPGM,VAR,VAR1,DEV,POP
  1.  S SDX="ALL",ORDER="",SDREP=0,SDSTART="",DIV=$$DIV^BSDU
  1.  ;
  1.  ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 adde BSDNHS to variable list
  1.  ;S VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE"
  1.  ;S VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE"
  1.  S VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE^BSDNHS"
  1.  S VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE;BSDNHS"
  1.  ;end of these PATCH 1003 changes
  1.  ;
  1.  S DGPGM="SINGLE^BSDROUT"
  1.  I $G(BSDDEV)]"" D ZIS^BDGF("F","SINGLE^BSDROUT","ROUTING SLIP",VAR1,BSDDEV) Q
  1.  S DEV=$S($G(BSDMODE)="CR":".05",1:".11")   ;default printer fields
  1.  S BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)
  1.  I BDGDEV="" K BDGDEV S EMSG="Routing Slip could not be printed: no default "_$S(BSDMODE="CR":"chart request",1:"walk in")_" printer defined in the IHS SCHEDULING PARAMETERS table." Q
  1.  S IOP=BDGDEV D ^%ZIS I POP D END^SDROUT1 Q
  1.  D SINGLE
  1.  Q
  1.  ;
  1. ONE ;EP; called by SDROUT to print one patient's routing slip
  1.  S DFN=+$$READ^BDGF("PO^2:EQM","Select PATIENT") I DFN<1 D END^SDROUT Q
  1.  D WISD(DFN,DT,"")
  1.  Q
  1.  ;
  1. SINGLE ;EP; queued entry point for single routing slips
  1.  ; called by WISD subroutine
  1.  U IO K ^TMP("SDRS",$J)
  1.  NEW BSDT,CLN,IEN,BSDMOD2
  1.  ;
  1.  ; find all appts for patient
  1.  I BSDMODE="CR" S BSDMOD2="CR",BSDMODE=""
  1.  S BSDT=SDATE\1
  1.  F  S BSDT=$O(^DPT(DFN,"S",BSDT)) Q:'BSDT  Q:(BSDT\1>SDATE)  D
  1.  . S CLN=+$G(^DPT(DFN,"S",BSDT,0)) Q:'CLN   ;clinic ien
  1.  . S IEN=0 F  S IEN=$O(^SC(CLN,"S",BSDT,1,IEN)) Q:'IEN  Q:$P($G(^SC(CLN,"S",BSDT,1,IEN,0)),U)=DFN
  1.  . Q:'IEN                                   ;appt ien in ^sc
  1.  . D FIND^BSDROUT0(CLN,BSDT,IEN,ORDER,BSDMODE)
  1.  I $D(BSDMOD2) S BSDMODE=BSDMOD2
  1.  ;
  1.  ; find all chart requests for patient
  1.  S CLN=0 F  S CLN=$O(^SC("AIHSCR",DFN,CLN)) Q:'CLN  D
  1.  . S BSDT=(SDATE\1)-.0001
  1.  . F  S BSDT=$O(^SC("AIHSCR",DFN,CLN,BSDT)) Q:'BSDT  D
  1.  .. D CRSET^BSDROUT2(CLN,BSDT,DFN,ORDER)
  1.  ;
  1.  K ^TMP("BSDX42",$J)
  1.  MERGE ^TMP("BSDX42",$J)=^TMP("SDRS",$J)
  1.  ; if no future appts, set something so RS will print
  1.  I '$D(^TMP("BSDX42",$J)) S ^TMP("BSDX42",$J,$$GET1^DIQ(2,DFN,.01),$$TERM(DFN),DFN)=""
  1.  ;
  1.  D PRINT^BSDROUT1(ORDER,SDATE)
  1.  Q
  1. TERM(PAT) ; returns chart # in terminal digit format
  1.  NEW N,T
  1.  S N=$$HRCN^BDGF2(PAT,$G(DUZ(2)))         ;chart #
  1.  S T=$$HRCNT^BDGF2(N)                     ;terminal digit format
  1.  I $$GET1^DIQ(9009020.2,+$$DIV^BSDU,.18)="NO" D
  1.  . S T=$$HRCND^BDGF2(N)                   ;use chart # per site param
  1.  Q T