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

BSDPCP.m

Go to the documentation of this file. 
  1. BSDPCP ; IHS/ANMC/LJF,WAR - UPDATE PCP FOR GROUP OF PTS ;  
  1.  ;;5.3;PIMS;**1003,1004,1007**;DEC 01, 2006
  1.  ;IHS/ITSC/LJF 06/17/2005 PATCH 1003 screened out deceased patients
  1.  ;IHS/OIT/LJF  09/28/2005 PATCH 1004 allow inactive providers in listing
  1.  ;cmi/anch/maw 11/22/2006 PATCH 1007 added line in ASKPN and code in GATHER for item 1007.11
  1.  ;
  1. PROV ; -- ask user to select a provider
  1.  NEW BSDPRV,SCREEN,BSDFL,BSDAAPN
  1.  S BSDFL=$S($P(^DD(9000001,.14,0),U,2)["200":200,1:6),SCREEN=""
  1.  ;I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
  1.  I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",+Y))"    ;IHS/OIT/LJF 09/28/2005 PATCH 1004
  1.  S BSDPRV=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Select a PRIMARY CARE PROVIDER","","",SCREEN) Q:BSDPRV<1
  1.  D ASKPN  ;cmi/anch/maw 11/9/2006 added item 1007.11 patch 1007
  1.  ;
  1. EN ; -- main entry point for SD IHS PCP LIST
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BSD PCP LIST")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
  1.  S VALMHDR(2)=$$SP(18)_"Patient List for "_$$GET1^DIQ(BSDFL,BSDPRV,.01)
  1.  S VALMSG="- Previous Screen  Q Quit  ?? for More Actions"
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  NEW BSDLN
  1.  D GATHER
  1.  S VALMCNT=BSDLN
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K VALMCNT,VALMQUIT,BSDPRV
  1.  K ^TMP("BSDPCP",$J),^TMP("BSDPCP2",$J)
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. RESET ; -- code executed upon return
  1.  I $D(VALMQUIT) S VALMBCK="Q" Q
  1.  D TERM^VALM0 S VALMBCK="R"
  1.  D INIT,HDR Q
  1.  ;
  1. RESET2 ; -- code executed upon return
  1.  I $D(VALMQUIT) S VALMBCK="Q" Q
  1.  D TERM^VALM0 S VALMBCK="R"
  1.  Q
  1.  ;
  1. GATHER ; -- build display array
  1.  NEW DFN,NAME,COMM,LINE,COUNT
  1.  D MSG^BDGF("Building Patient List. . .Please wait.",1,0)
  1.  K ^TMP("BSDPCP",$J),^TMP("BSDPCP1",$J),^TMP("BSDPCP2",$J)
  1.  S BSDLN=0
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT("AK",+BSDPRV,DFN)) Q:'DFN  D
  1.  . ;
  1.  . ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 screen out deceased patients
  1.  . Q:$$DOD^AUPNPAT(DFN)      ;skip if patient has date of death recorded
  1.  . ;
  1.  . S NAME=$$GET1^DIQ(2,DFN,.01)
  1.  . S COMM=$$GET1^DIQ(9000001,DFN,1118) S:COMM="" COMM="??"
  1.  . ;S ^TMP("BSDPCP1",$J,COMM,NAME,DFN)=""  cmi/anch/maw 11/9/2006 orig line item 1007.11 patch 1007
  1.  . I $G(BSDAPN)="C" S ^TMP("BSDPCP1",$J,COMM,NAME,DFN)=""  ;cmi/anch/maw 11/9/2006 new line item 1007.11 patch 1007
  1.  . I $G(BSDAPN)="P" S ^TMP("BSDPCP1",$J,NAME,COMM,DFN)=""  ;cmi/anch/maw 11/9/2006 new line added item 1007.11 patch 1007 
  1.  ;
  1.  ;cmi/anch/maw added below line for item 1007.11 patch 1007
  1.  I $G(BSDAPN)="C" D  ;cmi/anch/maw 11/9/2006 added for item 1007.11 patch 1007
  1.  . S COMM=0 F  S COMM=$O(^TMP("BSDPCP1",$J,COMM)) Q:COMM=""  D
  1.  .. S NAME=0 F  S NAME=$O(^TMP("BSDPCP1",$J,COMM,NAME)) Q:NAME=""  D
  1.  ... S DFN=0 F  S DFN=$O(^TMP("BSDPCP1",$J,COMM,NAME,DFN)) Q:'DFN  D
  1.  .... S COUNT=$G(COUNT)+1,LINE=$$PAD($J(COUNT,4)_" "_NAME,25)
  1.  .... S LINE=LINE_$J($$HRN^AUPNPAT(DFN,DUZ(2)),8)_"  "_COMM
  1.  .... S LINE=$$PAD(LINE,50)_$$LASTVST(DFN)
  1.  .... D SET(LINE,+$G(COUNT),DFN)
  1.  .... S ^TMP("BSDPCP2",$J,COMM,DFN)=""
  1.  ;
  1.  ;cmi/anch/maw added below lines for item 1007.11 patch 1007
  1.  I $G(BSDAPN)="P" D  ;cmi/anch/maw 11/9/2006 added for item 1007.11 patch 1007
  1.  . S NAME=0 F  S NAME=$O(^TMP("BSDPCP1",$J,NAME)) Q:NAME=""  D
  1.  .. S COMM=0 F  S COMM=$O(^TMP("BSDPCP1",$J,NAME,COMM)) Q:COMM=""  D
  1.  ... S DFN=0 F  S DFN=$O(^TMP("BSDPCP1",$J,NAME,COMM,DFN)) Q:'DFN  D
  1.  .... S COUNT=$G(COUNT)+1,LINE=$$PAD($J(COUNT,4)_" "_NAME,25)
  1.  .... S LINE=LINE_$J($$HRN^AUPNPAT(DFN,DUZ(2)),8)_"  "_COMM
  1.  .... S LINE=$$PAD(LINE,50)_$$LASTVST(DFN)
  1.  .... D SET(LINE,+$G(COUNT),DFN)
  1.  .... S ^TMP("BSDPCP2",$J,NAME,DFN)=""
  1.  ;
  1.  I '$G(COUNT) D SET($$SP(10)_"NONE FOUND",0,0)
  1.  K ^TMP("BSDPCP1",$J)
  1.  Q
  1.  ;
  1. SET(L,C,N) ; -- set display line into array
  1.  S BSDLN=BSDLN+1 S:N=0 N=1
  1.  S ^TMP("BSDPCP",$J,BSDLN,0)=L
  1.  S ^TMP("BSDPCP",$J,"IDX",BSDLN,C)=N
  1.  Q
  1.  ;
  1. LASTVST(DFN) ; -- returns date, serv cat, and clinic/srv of last visit
  1.  NEW X,V,CAT,VDT,CLIN,LINE
  1.  S X=0 F  S X=$O(^AUPNVSIT("AA",DFN,X)) Q:('X)!($D(LINE))  D
  1.  . S V=0 F  S V=$O(^AUPNVSIT("AA",DFN,X,V)) Q:'V  D
  1.  .. S CAT=$$SC^APCLV(V,"I") Q:"OHATS"'[CAT
  1.  .. S VDT=$$VD^APCLV(V,"S"),CLIN=$$CLINIC^APCLV(V,"E")
  1.  .. I CAT="H" S CLIN=$$DSCHSERV^APCLV(V,"E")
  1.  .. S CAT=$$SC^APCLV(V,"E")
  1.  .. S LINE=$$PAD($J(VDT,8),10)_$E(CAT,1,3)_"  "_CLIN
  1.  Q $G(LINE)
  1.  ;
  1.  ;
  1. GETITEM ; -- select item from list
  1.  K BSDRR
  1.  D EN^VALM2(XQORNOD(0),"O")
  1.  I '$D(VALMY) Q
  1.  NEW X,Y,Z,F
  1.  S X=0 F  S X=$O(VALMY(X)) Q:X=""  D
  1.  . S Y=0 F  S Y=$O(^TMP("BSDPCP",$J,"IDX",Y)) Q:Y=""  D
  1.  .. S Z=$O(^TMP("BSDPCP",$J,"IDX",Y,0))
  1.  .. Q:^TMP("BSDPCP",$J,"IDX",Y,Z)=""  Q:(Z'=X)
  1.  .. S BSDRR(X)=^TMP("BSDPCP",$J,"IDX",Y,Z)
  1.  .. S Y=99999999
  1.  D CLEAR^VALM1,FULL^VALM1
  1.  Q
  1.  ;
  1. PATLOOP ;EP; -- called to edit by patient from PCP List
  1.  NEW BSDRR,BSDCNT,DFN
  1.  D GETITEM I '$D(BSDRR) D RESET2 Q
  1.  D FULL^VALM1
  1.  S BSDCNT=0 F  S BSDCNT=$O(BSDRR(BSDCNT)) Q:'BSDCNT  D
  1.  . S DFN=BSDRR(BSDCNT) Q:'DFN
  1.  . D MSG^BDGF($J(BSDCNT,4)_"  "_$$GET1^DIQ(2,DFN,.01)_":",2,0)
  1.  . D ONEPAT(DFN)
  1.  D RESET
  1.  Q
  1.  ;
  1. COMLOOP ;EP; -- called to edit by community from PCP List
  1.  NEW BSDCOMN,Y,SCREEN,BSDNEW,BSDREAS,DIE,DA,DR
  1.  D FULL^VALM1
  1.  S Y=$$READ^BDGF("PO^9999999.05:EQMZ") I 'Y D RESET2 Q
  1.  S BSDCOMN=$P(Y,U,2)
  1.  ;
  1.  S SCREEN=""
  1.  I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",BSDPRV)),$P($G(^VA(200,BSDPRV,""PS"")),U,4)="""""
  1.  S Y=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Enter new PRIMARY CARE PROVIDER","","",SCREEN)
  1.  I Y<1 D RESET2 Q
  1.  S BSDNEW=+Y
  1.  ;
  1.  S BSDREAS=+$$READ^BDGF("PO^9999999.93:EMQZ","Select REASON for CHANGE")
  1.  I BSDREAS<1 D RESET2 Q
  1.  ;
  1.  D MSG^BDGF("I will now convert the Primary Care Provider for patients of ",2,0)
  1.  D MSG^BDGF($$SP(15)_$$GET1^DIQ(BSDFL,BSDPRV,.01)_" in "_BSDCOMN,1,0)
  1.  D MSG^BDGF("to"_$$SP(13)_$$GET1^DIQ(BSDFL,BSDNEW,.01),1,0)
  1.  I '$$READ^BDGF("YO","Ready to continue","NO") D RESET2 Q
  1.  ;
  1.  S DIE="^AUPNPAT(",DR=".14///`"_BSDNEW_";.37///`"_BSDREAS
  1.  S DFN=0 F  S DFN=$O(^TMP("BSDPCP2",$J,BSDCOMN,DFN)) Q:'DFN  D
  1.  . S DA=DFN D ^DIE W "."
  1.  D RESET
  1.  Q
  1.  ;
  1. UPD ;EP; -- called by update all patients from PCP List
  1.  D CLEAR^VALM1,MSG^BDGF($$SP(20)_"CONVERT PRIMARY CARE PROVIDER",2,2)
  1.  NEW Y,BSDNEW,SCREEN,BSDREAS
  1.  S SCREEN=""
  1.  I BSDFL=200 S SCREEN="I $D(^XUSEC(""PROVIDER"",+Y)),$P($G(^VA(200,+Y,""PS"")),U,4)="""""
  1.  S Y=+$$READ^BDGF("PO^"_BSDFL_":EMQZ","Enter new PRIMARY CARE PROVIDER","","",SCREEN)
  1.  Q:Y<1  S BSDNEW=+Y
  1.  ;
  1.  S BSDREAS=""
  1.  F  Q:+BSDREAS>0!(BSDREAS="^")  D
  1.  .S BSDREAS=$$READ^BDGF("PO^9999999.93:EMQZ","Select REASON for CHANGE")
  1.  .I BSDREAS=-1 D
  1.  ..W !!,$C(7),"You must enter a REASON or '^' to Quit"
  1.  ..D PAUSE^BDGF
  1.  I BSDREAS<1 D RESET2 Q
  1.  S BSDREAS=+BSDREAS
  1.  ;
  1.  D MSG^BDGF("I will now convert the Primary Care Provider for patients of ",2,0)
  1.  D MSG^BDGF($$SP(15)_$$GET1^DIQ(BSDFL,BSDPRV,.01),1,0)
  1.  D MSG^BDGF("to"_$$SP(13)_$$GET1^DIQ(BSDFL,BSDNEW,.01),1,0)
  1.  I '$$READ^BDGF("YO","Ready to continue","NO") D RESET2 Q
  1.  ;
  1.  S DIE="^AUPNPAT(",DR=".14///`"_BSDNEW_";.37///`"_BSDREAS
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT("AK",BSDPRV,DFN)) Q:'DFN  D
  1.  . S DA=DFN D ^DIE W "."
  1.  ;
  1.  S BSDPRV=BSDNEW D RESET
  1.  Q
  1.  ;
  1. PAD(DATA,LENGTH) ; -- SUBRTN to pad length of data
  1.  Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)
  1.  ;
  1.  ;
  1. GETPAT ;EP;-- edit PCP for 1 patient when patient not known
  1.  NEW DIC,Y,DFN
  1.  S Y=1 F  D  Q:Y<1
  1.  . S DIC=9000001,DIC(0)="AEMQ" D ^DIC Q:Y<1
  1.  . S DFN=+Y
  1.  . NEW Y,I W ! D PCPDISP^BSDU1(DFN,.Y) F I=1:1 Q:'$D(Y(I))  W !,Y(I)
  1.  . Q:'$$READ^BDGF("Y","Want to CHANGE this patient's Providers","NO")
  1.  . D ONEPAT(DFN) S Y=DFN
  1.  Q
  1.  ;
  1. ONEPAT(DFN) ; once patient is selected, edit PCP fields
  1.  NEW BEFORE,DIE,DA,DR,DITC
  1.  S BEFORE=$$GET1^DIQ(9000001,DFN,.14,"I")  ;current PCP
  1.  S DIE="^AUPNPAT(",DA=DFN,DR=".14" D ^DIE  ;edit PCP
  1.  ;
  1.  ; if PCP changed, ask reason (date and user updated via triggers)
  1.  I BEFORE]"",BEFORE'=$$GET1^DIQ(9000001,DFN,.14,"I") D  Q:$D(Y)
  1.  . S DITC="",DIE="^AUPNPAT(",DA=DFN,DR=".37///@" D ^DIE
  1.  . S DIE="^AUPNPAT(",DA=DFN,DR=".37" D ^DIE
  1.  ;
  1.  I $$GET1^DIQ(2,DFN,.02)="FEMALE",$D(^BWP(DFN)) D WHREF(DFN)
  1.  Q
  1.  ;
  1. WHREF(PAT) ; edit WH Referral Provider
  1.  NEW DIE,BEFORE,DA,DR
  1.  S BEFORE=$$GET1^DIQ(9002086,PAT,.25,"I")
  1.  S DIE="^BWP(",DA=DFN,DR=".25" D ^DIE
  1.  I BEFORE]"",BEFORE'=$$GET1^DIQ(9002086,DFN,.25,"I") D
  1.  . S DIE="^BWP(",DA=DFN,DR=".28///@" D ^DIE
  1.  . S DIE="^BWP(",DA=DFN,DR=".28" D ^DIE
  1.  Q
  1.  ;
  1. AMPCP ;EP; update PCP from Appt Mgt
  1.  D FULL^VALM1
  1.  I $G(DFN) D  S VALMBCK="R" Q
  1.  . NEW Y,I W ! D PCPDISP^BSDU1(DFN,.Y) F I=1:1 Q:'$D(Y(I))  W !,Y(I)
  1.  . Q:'$$READ^BDGF("Y","Want to CHANGE this patient's Providers","NO")
  1.  . D ONEPAT(DFN)
  1.  ;
  1.  D GETPAT S VALMBCK="R"
  1.  Q
  1.  ;cmi/anch/maw added ASKPN 11/9/2006 item 1007.11 patch 1007
  1. ASKPN ;EP - ask if they want to sort by patient name
  1.  S BSDAPN=$$READ^BDGF("S^C:Community of Residence;P:Patient Name","Sort By","Community of Residence")
  1.  Q
  1.  ;