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

BDGPV.m

Go to the documentation of this file. 
  1. BDGPV ; IHS/ANMC/LJF - PROVIDER INQUIRY ; 
  1.  ;;5.3;PIMS;;APR 26, 2002
  1.  ;
  1.  NEW BDGPV,BDGPVN,DEF,SCR,BDGSRT
  1.  S DEF=$S($D(^XUSEC("PROVIDER",DUZ)):$$GET1^DIQ(200,DUZ,.01),1:"")
  1.  S SCR="I $D(^XUSEC(""PROVIDER"",+Y))"         ;screen for provider key
  1.  S BDGPV=$$READ^BDGF("PO^200:EMQZ","Select PROVIDER NAME",DEF,"",SCR)
  1.  Q:BDGPV<1  S BDGPVN=$P(BDGPV,U,2),BDGPV=+BDGPV
  1.  ;
  1.  S BDGSRT=$$READ^BDGF("SAO^W:WARD;S:SERVICE","Inpatients sorted by Ward or Service: ","WARD") Q:BDGSRT=U
  1.  I $$BROWSE^BDGF="B" D EN Q
  1.  D ZIS^BDGF("PQ","START^BDGPV","PROVIDER'S INPATIENTS","BDGPV;BDGPVN;BDGSRT")
  1.  Q
  1.  ;
  1. START ;EP; entry when printing to paper
  1.  S BDGPRT=1 D INIT,PRINT Q
  1.  ;
  1. EN ;EP; -- main entry point for BDG PROVIDER INQUIRY
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG PROVIDER INQUIRY")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$$SP(10)_"** "_$$CONF^BDGF_" **"
  1.  S VALMHDR(2)=$$SP(75-$L(BDGPVN)\2)_BDGPVN      ;provider name
  1.  S VALMSG=$$SP(7)_"Attending/Admitting/Primary Care"
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  I '$G(BDGPRT) D MSG^BDGF("Please wait while I compile the list...",1,0)
  1.  NEW BDGCNT
  1.  K ^TMP("BDGPV",$J),^TMP("BDGPV1",$J)
  1.  S VALMCNT=0    ;line count
  1.  S BDGCNT=1     ;patient count for choosing patient entry
  1.  D INPT,SCHADM,DAYSUR,SCHDS,APPTS,SCHVST
  1.  I '$D(^TMP("BDGPV",$J)) S ^TMP("BDGPV",$J,1,0)="NO PATIENTS FOUND",VALMCNT=1
  1.  K ^TMP("BDGPV1",$J)
  1.  Q
  1.  ;
  1. INPT ; find all inpatients for this provider
  1.  NEW BDGCA,DFN,SRT,X,BDGX,LINE,CAT,SRT,NAME
  1.  ;  loop thru ACA xref in ^DPT for current admissions
  1.  S BDGCA=0 F  S BDGCA=$O(^DPT("ACA",BDGCA)) Q:'BDGCA  D
  1.  . S DFN=0 F  S DFN=$O(^DPT("ACA",BDGCA,DFN)) Q:'DFN  D
  1.  .. ;
  1.  .. ; set admissions into array sorted by category and ward/srv sort
  1.  .. S SRT=$S(BDGSRT="W":$G(^DPT(DFN,.1)),1:$$GET1^DIQ(2,DFN,.103))
  1.  .. I SRT="" S SRT="??"
  1.  .. ;
  1.  .. ; category 1: prov is prim inpt prov or attending
  1.  .. I $G(^DPT(DFN,.1041))=BDGPV D  Q
  1.  ... S ^TMP("BDGPV1",$J,1,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
  1.  .. ;
  1.  .. ; category 2: prov is admitting only
  1.  .. I $$ADMPRV^BDGF1(BDGCA,DFN,"ADM")=BDGPVN D  Q
  1.  ... S ^TMP("BDGPV1",$J,2,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
  1.  .. ;
  1.  .. ; category 3: prov is PCP only
  1.  .. K BDGX S BDGX="BDGX" D PCP^BSDU1(DFN,.BDGX)
  1.  .. I $P(BDGX(1),"/",3)=BDGPV  D
  1.  ... S ^TMP("BDGPV1",$J,3,SRT,$$GET1^DIQ(2,DFN,.01),DFN)=BDGCA
  1.  ;
  1.  ; now take sorted list and put into display array
  1.  S CAT=0 F  S CAT=$O(^TMP("BDGPV1",$J,CAT)) Q:'CAT  D
  1.  . ;
  1.  . ; put category subtitle into display array
  1.  . S LINE=$S(CAT=1:"Attending Provider:",CAT=2:"Admitting Provider:",1:"Primary Care Provider")
  1.  . D SET($G(IORVON)_LINE_$G(IORVOFF),.VALMCNT,BDGCNT,"")
  1.  . ;
  1.  . S SRT=0 F  S SRT=$O(^TMP("BDGPV1",$J,CAT,SRT)) Q:SRT=""  D
  1.  .. ;
  1.  .. ; put sort item subtitle into display array
  1.  .. S LINE="For "_SRT_$S(BDGSRT="W":" Ward",1:" Service")
  1.  .. D SET($$SP(3)_$G(IOUON)_LINE_$G(IOUOFF),.VALMCNT,BDGCNT,"")
  1.  .. ;
  1.  .. S NAME=0 F  S NAME=$O(^TMP("BDGPV1",$J,CAT,SRT,NAME)) D:NAME="" SET("",.VALMCNT,BDGCNT,"") Q:NAME=""  D
  1.  ... S DFN=0 F  S DFN=$O(^TMP("BDGPV1",$J,CAT,SRT,NAME,DFN)) Q:'DFN  D
  1.  .... S BDGCA=^TMP("BDGPV1",$J,CAT,SRT,NAME,DFN)   ;corresp adm ien
  1.  .... ;
  1.  .... ; build lines and put into display array
  1.  .... S LINE=$J(BDGCNT,2)_") "_$E(NAME,1,18)
  1.  .... S LINE=$$PAD(LINE,24)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)
  1.  .... S LINE=$$PAD(LINE,33)_$S(BDGSRT="W":$$SRV,1:$$WRD)      ;wrd/srv
  1.  .... S LINE=$$PAD(LINE,41)_$G(^DPT(DFN,.101))                ;room-bed 
  1.  .... S LINE=$$PAD(LINE,50)_$P($$GET1^DIQ(405,BDGCA,.01),"@")  ;admit dt
  1.  .... S LINE=$$PAD(LINE,64)_$$GET1^DIQ(405,BDGCA,.1)          ;dx
  1.  .... D SET(LINE,.VALMCNT,BDGCNT,"IP"_U_DFN_U_BDGCA)
  1.  .... ;
  1.  .... S LINE=$$PAD($$SP(5)_$$CWAD^BDGF2(DFN),17)              ;cwad
  1.  .... S LINE=LINE_$E($$GET1^DIQ(2,DFN,.1041),1,15)_"/"        ;attend
  1.  .... S LINE=LINE_$E($$ADMPRV^BDGF1(BDGCA,DFN,"ADM"),1,15)_"/"   ;admtg
  1.  .... K BDGX S BDGX="BDGX" D PCP^BSDU1(DFN,.BDGX)
  1.  .... S LINE=LINE_$E($P($G(BDGX(1)),"/"),1,15)              ;pcp
  1.  .... D SET(LINE,.VALMCNT,BDGCNT,"IP"_U_DFN_U_BDGCA)
  1.  .... ;
  1.  .... ; increment patient selection number
  1.  .... S BDGCNT=BDGCNT+1
  1.  Q
  1.  ;
  1. SCHADM ; find scheduled admissions for next week for provider
  1.  ;D SCHED^BDGPV1("IP")
  1.  Q
  1.  ;
  1. DAYSUR ; find all day surgery patients for this provider
  1.  I $T(PRVSUR^BSRPEP)]"" D  Q
  1.  . NEW BDGRR,X,DATE,IEN,BDGI
  1.  . K ^TMP("BDGPV1",$J)
  1.  . S BDGRR="^TMP(""BDGPV1"",$J)"
  1.  . D PRVSUR^BSRPEP(BDGPV,DT,.BDGRR)    ;get list from surgery
  1.  . I '$D(^TMP("BDGPV1",$J)) Q
  1.  . ;
  1.  . D SET("Today's Surgeries:",.VALMCNT,BDGCNT,"")
  1.  . ;
  1.  . I $D(^TMP("BDGPV1",$J)) D
  1.  .. S DATE=0 F  S DATE=$O(^TMP("BDGPV1",$J,DATE)) Q:'DATE  D
  1.  ... S IEN=0 F  S IEN=$O(^TMP("BDGPV1",$J,DATE,IEN)) Q:'IEN  D
  1.  .... F BDGI=1:1 Q:'$D(^TMP("BDGPV1",$J,DATE,IEN,BDGI))  D
  1.  ..... S X=$S(BDGI=1:$J(BDGCNT,2)_") ",1:$$SP(4))
  1.  ..... S X=X_^TMP("BDGPV1",$J,DATE,IEN,BDGI)
  1.  ..... D SET(X,.VALMCNT,BDGCNT,"SR"_U_IEN)
  1.  .... S BDGCNT=BDGCNT+1
  1.  . K ^TMP("BDGPV1",$J)
  1.  ;
  1.  ;
  1.  ; look for day surgeries scheduled for today
  1.  NEW BDGDT,BDGEND,DFN,IENS,LINE,BDGFRST
  1.  S BDGDT=DT-.0001,BDGEND=DT+.24,BDGFRST=1
  1.  F  S BDGDT=$O(^ADGDS("AA",BDGDT)) Q:'BDGDT  Q:BDGDT>BDGEND  D
  1.  . S DFN=0 F  S DFN=$O(^ADGDS("AA",BDGDT,DFN)) Q:'DFN  D
  1.  .. S BDGDS=0 F  S BDGDS=$O(^ADGDS("AA",BDGDT,DFN,BDGDS)) Q:'BDGDS  D
  1.  ... ;
  1.  ... ; if first on list, display subheading
  1.  ... I BDGFRST D SET($G(IORVON)_"Today's Day Surgeries:"_$G(IORVOFF),.VALMCNT,BDGCNT,"") S BDGFRST=0
  1.  ... ;
  1.  ... ; put today's surgeries into display array
  1.  ... S IENS=DFN_","_BDGDS
  1.  ... S LINE=$J(BDGCNT,2)_") "_$P($$GET1^DIQ(9009012.01,IENS,.01),".",2)
  1.  ... S LINE=$$PAD(LINE,12)_$E($$GET1^DIQ(2,DFN,.01),1,18)   ;pat name
  1.  ... S LINE=$$PAD(LINE,32)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)   ;chart #
  1.  ... S LINE=$$PAD(LINE,40)_$$GET1^DIQ(9009012.01,IENS,1)    ;procedure
  1.  ... D SET(LINE,.VALMCNT,BDGCNT,"DS"_U_DFN_U_BDGDS)
  1.  ... ;
  1.  ... ; build status line with released date/time or other status
  1.  ... S STATUS="",X=$$GET1^DIQ(9009012.01,IENS,7) I X]"" D
  1.  .... S STATUS="Released at "_X
  1.  .... I $$GET1^DIQ(9009012.01,IENS,11)="YES" S STATUS=STATUS_" (Admitted)" Q
  1.  .... I $$GET1^DIQ(9009012.01,IENS,15)="YES" S STATUS=STATUS_" (Unescorted)"
  1.  ... ;
  1.  ... I STATUS="" D
  1.  .... I $$GET1^DIQ(9009012.01,IENS,12)="YES" S STATUS="**CANCELLED**" Q
  1.  .... I $$GET1^DIQ(9009012.01,IENS,13)="YES" S STATUS="**NO-SHOW**" Q
  1.  ... ;
  1.  ... D SET($$SP(10)_STATUS,.VALMCNT,BDGCNT,"DS"_U_DFN_U_BDGDS)
  1.  ... ;
  1.  ... ; increment counter
  1.  ... S BDGCNT=BDGCNT+1
  1.  Q
  1.  ;
  1. SCHDS ; find scheduled day surgeries
  1.  ;D SCHED^BDGPV1("DS")
  1.  Q
  1.  ;
  1. APPTS ; find all appts for provider for today
  1.  NEW BSDPRV,BSDQUIET,BSDDT
  1.  S BSDPRV=BDGPV,BSDDT=DT,BSDQUIET=1
  1.  D CLINICS^BSDPVD  ;sets ^TMP("BSDPV2",$J) array
  1.  ;
  1.  ; next lines of code were copied from BSDPVD and modified to fit this
  1.  ;   display array with the proper selelction numbers
  1.  K ^TMP("BDGPV1",$J)
  1.  ;
  1.  ; loop thru provider's clinics and then appts for date
  1.  NEW CLN,CLNM,IEN,DATE,END,NODE
  1.  S CLN=0 F  S CLN=$O(^TMP("BSDPVD2",$J,CLN)) Q:'CLN  D
  1.  . S CLNM=$$GET1^DIQ(44,CLN,1)        ;clinic abbrievation
  1.  . ;
  1.  . S DATE=BSDDT-.0001,END=BSDDT_".2400"
  1.  . F  S DATE=$O(^SC(CLN,"S",DATE))  Q:'DATE  Q:(DATE>END)  D
  1.  .. S IEN=0 F  S IEN=$O(^SC(CLN,"S",DATE,1,IEN)) Q:'IEN  D
  1.  ... ;
  1.  ... ; sort by date,clinic; save clinic ien, patient, length, info
  1.  ... S NODE=$G(^SC(CLN,"S",DATE,1,IEN,0)) Q:'NODE
  1.  ... S ^TMP("BDGPV1",$J,DATE,CLNM,IEN)=$P(NODE,U,1,4)_U_CLN_U_$G(^SC(CLN,"S",DATE,1,IEN,"OB"))
  1.  ;
  1.  I '$D(^TMP("BDGPV1",$J)) Q
  1.  D SET($G(IORVON)_"Today's Appointments:"_$G(IORVOFF),.VALMCNT,BDGCNT,"")
  1.  D SET($$SP(4)_$G(IOUON)_"Appt Time    Clinic   Patient"_$G(IOUOFF),.VALMCNT,BDGCNT,"")
  1.  ;
  1.  ; put sorted list into display array
  1.  NEW DATE,CLN,IEN,DATA,LINE,X,I,LAST,ENDTM
  1.  S DATE=0 F  S DATE=$O(^TMP("BDGPV1",$J,DATE)) Q:'DATE  D
  1.  . S CLN=0 F  S CLN=$O(^TMP("BDGPV1",$J,DATE,CLN)) Q:CLN=""  D
  1.  .. S IEN=0 F  S IEN=$O(^TMP("BDGPV1",$J,DATE,CLN,IEN)) Q:'IEN  D
  1.  ... S DATA=^TMP("BDGPV1",$J,DATE,CLN,IEN)
  1.  ... S LINE=$J(BDGCNT,2)_") "_$P($$FMTE^XLFDT(DATE,2),"@",2)  ;appt time
  1.  ... S ENDTM=$P($$FMTE^XLFDT($$FMADD^XLFDT(DATE,0,0,$P(DATA,U,2))),"@",2)
  1.  ... S LINE=LINE_"-"_ENDTM_$TR($P(DATA,U,6),"O","*")  ;end time/overbk
  1.  ... S LINE=$$PAD(LINE,17)_CLN                        ;end time & clinic
  1.  ... S LINE=$$PAD(LINE,26)_$E($$GET1^DIQ(2,+DATA,.01),1,18)  ;patient
  1.  ... S LINE=$$PAD(LINE,45)_$J("#"_$$HRCN^BDGF2(+DATA,DUZ(2)),6)  ;chart #
  1.  ... S LINE=$$PAD(LINE,54)_$$CWAD^BDGF2(+DATA)               ;cwad
  1.  ... ;
  1.  ... ; add extra lines if end time diff hour from last appt
  1.  ... I $D(LAST) D
  1.  .... S X=$E($P(DATE,".",2),1,2)-$E(LAST,1,2)   ;difference in hours
  1.  .... F I=1:1:X D SET("",.VALMCNT,BDGCNT,"")    ;determines # of lines
  1.  ... S LAST=ENDTM   ;save end time to compare with next appt
  1.  ... ;
  1.  ... ; now print this appt
  1.  ... D SET(LINE,.VALMCNT,BDGCNT,"OP"_U_(+DATA)_U_$P(DATA,U,5)_U_DATE)
  1.  ... ; and other info comments
  1.  ... D SET($$SP(17)_$E($P(DATA,U,4),1,50),.VALMCNT,BDGCNT,"")
  1.  ... ;
  1.  ... ; increment counter
  1.  ... S BDGCNT=BDGCNT+1   ;number on display page
  1.  ;
  1.  K ^TMP("BDGPV1",$J)
  1.  Q
  1.  ;
  1.  Q
  1.  ;
  1. SCHVST ; find scheduled outpat visits and those for quarters
  1.  ;D SCHED^BDGPV1("OUT")
  1.  Q
  1.  ;
  1. PRINT ; print report to paper
  1.  U IO D HDG
  1.  NEW LINE
  1.  S LINE=0 F  S LINE=$O(^TMP("BDGPV",$J,LINE)) Q:'LINE  D
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,^TMP("BDGPV",$J,LINE,0)
  1.  D ^%ZISC,EXIT
  1.  Q
  1.  ;
  1. HDG ; heading for paper report
  1.  D HDR W @IOF,?30,"Provider's Current Inpatients"
  1.  NEW I F I=1:1 Q:'$D(VALMHDR(I))  W !,VALMHDR(I)
  1.  W !,$$REPEAT^XLFSTR("-",80)
  1.  W !?5,"Patient Name",?23,"Chart #",?33,"Wrd/Srv",?42,"Room-Bed"
  1.  W ?51,"Admit Date",?65,"Admitting Dx"
  1.  W !,$$REPEAT^XLFSTR("=",80)
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGPV",$J) K BDGPRT
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. SET(LINE,LNUM,PNUM,IEN) ; puts display line into array
  1.  S LNUM=LNUM+1
  1.  S ^TMP("BDGPV",$J,LNUM,0)=LINE
  1.  S ^TMP("BDGPV",$J,"IDX",LNUM,PNUM)=IEN
  1.  Q
  1.  ;
  1. SRV() ; return current service abbreviation for patient   
  1.  Q $$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99)
  1.  ;
  1. WRD() ; return current ward abbreviation for patient
  1.  NEW X
  1.  S X=$G(^DPT(DFN,.1)) I X="" Q "??"
  1.  S X=$$GET1^DIQ(9009016.5,+$O(^DIC(42,"B",X,0)),.02)
  1.  Q $S(X="":"??",1:X)
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)