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

BSDU.m

Go to the documentation of this file. 
  1. BSDU ; IHS/ANMC/LJF - IHS UTILITY CALLS-CLINIC INFO ;  [ 01/06/2005  11:39 AM ]
  1.  ;;5.3;PIMS;**1001,1010,1011,1012**;APR 26, 2002
  1.  ;
  1.  ;cmi/flag/maw 10/29/2009 PATCH 1011 added calls for TAXONOMY, GETTAX, TAX
  1.  ;
  1. CLINIC(BSDTNI,BSDNALL,BSDDIV) ;EP; get clinic choices-includes principal clinic groups ;IHS/ITSC/LJF 4/21/2004
  1.  ; if BSDTNI=1 array is VAUTC(clinic name)=ien
  1.  ; if BSDTNI=2 array is VAUTC(clinic ien)=name
  1.  ; if BSDNALL is set to 1, don't ask for all clinics or expand principal cln
  1.  ; if BSDDIV is set to 1, assume DIV is set for division and don't ask again;IHS/ITSC/LJF
  1.  K BSDQ
  1.  ;
  1.  ;IHS/ITSC/LJF 4/21/2004 don't ask division if already known
  1.  ;D ASK2^SDDIV I Y<0 S BSDQ="" Q
  1.  K VAUTD
  1.  I $G(BSDDIV) D                         ;division assumed
  1.  . I '$D(DIV) Q                         ;no division variable set
  1.  . I DIV="" S VAUTD=1 Q                 ;already set to all divisions
  1.  . S VAUTD=0,VAUTD(DIV)=$$DIVNM(DIV)    ;division already set
  1.  I '$D(VAUTD) D ASK2^SDDIV I Y<0 S BSDQ="" Q
  1.  ;I $D(BSDNALL) S VAUTNALL=""
  1.  I $G(BSDNALL) S VAUTNALL=""
  1.  ;IHS/ITSC/LJF 4/21/2004
  1.  ;
  1.  ;cmi/maw 10/15/2009 PATCH 1011 ask for taxonomy here
  1.  N BSDTAX
  1.  I $G(BSDTAXYN) D
  1.  . I $$READ^BDGF("Y","Would you like a preexisting Clinic Taxonomy?","NO") D
  1.  .. S BSDTAX=$$GETTAX(BSDTNI)
  1.  .. I $G(BSDTAX) S Y=1,VAUTC=0
  1.  I '$G(BSDTAX) S VAUTNI=BSDTNI D CLINIC^VAUTOMA I Y<0 S BSDQ="" Q
  1.  ;S VAUTNI=BSDTNI D CLINIC^VAUTOMA I Y<0 S BSDQ="" Q  cmi/maw 10/15/2009 orig line
  1.  I '$G(BSDTAX),$O(VAUTC(""))]"" D
  1.  . Q:$$READ^BDGF("Y","Would you like to save this clinic list as a Taxonomy?","NO")'=1
  1.  . N BSDTAXE
  1.  . D TAX(.VAUTC,BSDTNI)
  1.  . S Y=1
  1.  ;
  1.  I '$D(BSDNALL) D EXPNDPC(BSDTNI,.VAUTC)
  1.  Q
  1.  ;
  1. EXPNDPC(BSDTNI,ARRAY) ;EP; expands array if any are principal clinics  
  1.  NEW X,Z,Y
  1.  S X=0 F  S X=$O(ARRAY(X)) Q:X=""  D
  1.  . S Y=$S(BSDTNI=1:ARRAY(X),1:X)
  1.  . S Z=0 F  S Z=$O(^SC("AIHSPC",Y,Z)) Q:Z=""  D
  1.  .. I BSDTNI=1 S ARRAY($P(^SC(Z,0),U))=Z
  1.  .. I BSDTNI=2 S ARRAY(Z)=$P(^SC(Z,0),U)
  1.  Q
  1.  ;
  1. PCASK(BSDTNI,BSDTYPE) ;EP; get provider or team (with associated clinics)
  1.  ; if BSDTNI=1 array is VAUTC(clinic name)=ien
  1.  ; if BSDTNI=2 array is VAUTC(clinic ien)=name
  1.  ; BSDTYPE="V" for provider or "T" for team
  1.  NEW DIC,VAUTSTR,VAUTVB,VAUTNI
  1.  K BSDQ,BSDTT,VAUTC
  1.  S DIC=$S(BSDTYPE="V":"^VA(200,",1:"^BSDPCT(")
  1.  S VAUTSTR=$S(BSDTYPE="V":"provider",1:"team")
  1.  S VAUTVB="BSDTT",VAUTNI=2
  1.  I BSDTYPE="V" S DIC("S")="I $$SCREEN^DGPMDD(Y,"""",DT)"
  1.  I BSDTYPE="T" S DIC("S")="I $P($G(^BSDPCT(+Y,0)),U,3)="""""
  1.  D FIRST^VAUTOMA I Y<0 S BSDQ="" Q
  1.  ;
  1.  NEW X,Y S X=0 F  S X=$O(BSDTT(X)) Q:'X  D
  1.  . S Y=X_U_BSDTT(X) D FINDCL(Y,BSDTYPE,BSDTNI)
  1.  S VAUTC=BSDTT
  1.  Q
  1.  ;
  1. FINDCL(BSDX,TYPE,MODE) ;EP; -- sets array of clinics for provider or team
  1.  ; returns BSDCL array with clinic name and then ien
  1.  ; BSDX=IEN of provider or team ^ provider or team name
  1.  ; TYPE="V" for provider; "T" for team
  1.  ;
  1.  ;IHS/ITSC/WAR 2/12/03 P50 per Linda LJF41
  1.  ;K VAUTC   ;IHS/ITSC/LJF 1/22/2003 do not wipe out VAUTC between calls from PCASK
  1.  I TYPE="V" D CLN(+BSDX,MODE) Q   ;for provider sort
  1.  ;
  1.  ; for team sort
  1.  ;7/18/2002 WAR - next section per LJF18
  1.  ;IHS/ANMC/LJF 7/5/2002 changed all BDG to BSD in next 3 lines
  1.  NEW BSDP
  1.  S BSDP=0 F  S BSDP=$O(^BSDPCT(+BSDX,1,BSDP)) Q:'BSDP  D
  1.  . D CLN($P(^BSDPCT(+BSDX,1,BSDP,0),U),MODE)
  1.  ;IHS/ANMC/LJF 7/5/2002 end of fix
  1.  Q
  1.  ;
  1. CLN(SUB2,MODE) ; sets clinic array based on provider
  1.  NEW X
  1.  S X=0
  1.  F  S X=$O(^SC("AIHSDPR",SUB2,X)) Q:'X  D
  1.  . I MODE=1 S VAUTC($$GET1^DIQ(44,X,.01))=X
  1.  . I MODE=2 S VAUTC(X)=$$GET1^DIQ(44,X,.01)
  1.  Q
  1.  ;
  1. DIV() ;EP; -- returns division ien for user
  1.  ;Q +$O(^DG(40.8,"C",DUZ(2),0))  ;cmi/maw 10/1/2009 patch 1011 orig line
  1.  Q +$O(^DG(40.8,"AD",DUZ(2),0))  ;cmi/maw 10/1/2009 patch 1011 for station number
  1.  ;
  1. DIVNM(D) ;EP; -- returns division name for division sent
  1.  NEW X S X=$$GET1^DIQ(40.8,+$G(D),.01) S:X="" X="UNKNOWN DIVISION" Q X
  1.  ;
  1. DIVC(CLINIC) ;EP; -- returns division for clinic
  1.  Q $$GET1^DIQ(44,+CLINIC,3.5,"I")
  1.  ;
  1. FAC(CLINIC) ;EP; -- returns institution for clinic based on division
  1.  NEW X S X=$$DIVC(CLINIC)
  1.  Q $S(+X:$$GET1^DIQ(40.8,+X,.07,"I"),1:"")
  1.  ;
  1. ACTV(CLINIC,DATE) ;PEP; -- returns 1 if clinic is active for date
  1.  I $$GET1^DIQ(44,CLINIC,2,"I")'="C" Q 0   ;not a clinic
  1.  Q $S($P($G(^SC(CLINIC,"I")),U)="":1,$P(^("I"),U)>DATE:1,$P(^("I"),U,2)="":0,$P(^("I"),U,2)'>DATE:1,1:0)
  1.  ;
  1. INACTMSG() ;EP; -- returns message to display if clinic inactivated
  1.  ; called by code that sets DIC("W")
  1.  Q "NEW BSDMSG S BSDMSG=$S($$ACTV^BSDU(+Y,DT):"""",1:"" *inactivated on ""_$$INACTVDT^BSDU(+Y)) W BSDMSG"
  1.  ;
  1. INACTVDT(CLINIC) ;PEP; -- returns date clinic was inactivated
  1.  Q $$GET1^DIQ(44,+CLINIC,2505)
  1.  ;
  1. PRV(CLINIC) ;EP; -- returns default provider for clinic
  1.  ; Y returns as ien^provider name
  1.  NEW X,Y
  1.  S X=0 F  S X=$O(^SC(CLINIC,"PR",X)) Q:'X  D
  1.  . I $P($G(^SC(CLINIC,"PR",X,0)),U,2)=1 S Y=+^SC(CLINIC,"PR",X,0)
  1.  I $G(Y) S Y=Y_U_$$GET1^DIQ(200,Y,.01)
  1.  I '$G(Y) S Y="0^UNAFFILIATED CLINICS"
  1.  Q $G(Y)
  1.  ;
  1. TEAM(CLINIC) ;EP; -- returns team associated with this clinic
  1.  ; Y returns as ien^team name
  1.  NEW X,Y
  1.  ;  first find default provider entry for clinic
  1.  S X=$$PRV(CLINIC) I 'X Q X
  1.  ;  then find provider's team (assumes only on one)
  1.  S Y=$O(^BSDPCT("AB",+X,0)) I 'Y Q "0^UNAFFILIATED CLINICS"
  1.  ;  return team ien ^ team name
  1.  ;Q Y_U_$$GET1^DIQ(9009017.5,Z,.01)
  1.  Q Y_U_$$GET1^DIQ(9009017.5,Y,.01)   ;IHS/ITSC/LJF 4/23/2004 PATCH #1001
  1.  ;
  1. OWNER(CLINIC,USER) ;EP
  1.  ; -- returns 1 if user is clinic's owner or no owners assigned
  1.  I $D(^XUSEC("SDZAC",DUZ)) Q 1       ;let app coordinators in
  1.  NEW X S X=+$$GET1^DIQ(44,CLINIC,1916,"I")          ;princ clinic
  1.  I '$O(^BSDSC(CLINIC,2,0)),'$O(^BSDSC(X,2,0)) Q 1   ;no owners; unlocked
  1.  I $D(^BSDSC("AB",USER,CLINIC)) Q 1  ;user is one of the owners
  1.  I $D(^BSDSC("AB",USER,X)) Q 1       ;user is owner of princ clinic
  1.  Q 0
  1.  ;
  1. OVRBKUSR(DUZ,CLINIC) ;EP; returns 1 if user has overbook access to clinic
  1.  Q $S($D(^XUSEC("SDOB",DUZ)):1,$D(^BSDSC("AOV",DUZ,CLINIC)):1,$D(^BSDSC("AOV",DUZ,+$$PC(CLINIC))):1,1:0)
  1.  ;
  1. MOVBKUSR(DUZ,CLINIC) ;EP; returns 1 if user has master overbook access to clinic
  1.  Q $S($D(^XUSEC("SDMOB",DUZ)):1,$$OBLEVL(DUZ,CLINIC)="M":1,$$OBLEVL(DUZ,+$$PC(CLINIC))="M":1,1:0)
  1.  ;
  1. OBLEVL(DUZ,CLINIC) ;EP; returns M or R as overbok level for user for clinic
  1.  NEW X S X=$O(^BSDSC("AOV",DUZ,CLINIC,0)) I 'X Q ""
  1.  Q $P($G(^BSDSC(CLINIC,1,X,0)),U,2)
  1.  ;
  1. PRIN(CLINIC) ;PEP -- returns name of clinic's principal clinic
  1.  NEW X S X=$$GET1^DIQ(44,+CLINIC,1916)
  1.  Q $S(X]"":X,1:"UNAFFILIATED CLINICS")
  1.  ;
  1. PC(CLINIC) ;PEP; -- returns IEN for clinic's principal clinic
  1.  Q +$$GET1^DIQ(44,CLINIC,1916,"I")
  1.  ;
  1. CLNCODE(CLINIC) ;PEP -- returns clinic code number and name
  1.  ; if you want only the code, add + to the result
  1.  NEW X S X=$$GET1^DIQ(44,+CLINIC,8,"I") I 'X Q "??"
  1.  Q $$GET1^DIQ(40.7,X,1)_" - "_$$GET1^DIQ(40.7,X,.01)
  1.  ;
  1. CONF() ;EP; -- returns confidential warning
  1.  Q "Confidential Patient Data Covered by Privacy Act"
  1.  ;
  1. NONCOUNT(CLINIC) ;EP; --returns statement if non-count clinic
  1.  NEW X,Y
  1.  S X=$$GET1^DIQ(44,CLINIC,2502) I X'="YES" Q ""
  1.  S Y=$$GET1^DIQ(44,CLINIC,2502.5)
  1.  S X="Non-Count Clinic, "_$S(Y="YES":"",1:"NOT ")
  1.  S X=X_"included on File Room List"
  1.  Q X
  1.  ;
  1. DOW(CLINIC) ;EP; -- returns list of days clinic meets
  1.  ; borrowed code from VA routine SDCP
  1.  NEW DOW,L,M,DAYS,X,Y
  1.  F L=0:1:6 F M=DT-.1:0 S M=$O(^SC(CLINIC,"T"_L,M)) Q:M=""  I $D(^(M,1)) S:^(1)]"" DOW(L+1)="" Q:^(1)]""  K DOW(L+1)
  1.  F L=DT-.1:0 S L=$O(^SC(CLINIC,"T",L)) Q:L=""  S X=L D DW^%DTC I '$D(DOW(Y+1)),$D(^SC(CLINIC,"OST",L,1)),^(1)["[" S DOW(Y+1)=""
  1.  S DAYS="" F M=1:1:7 I $D(DOW(M)) S DAYS=DAYS_$S(DAYS'="":",",1:"")_$P("SU^MO^TU^WE^TH^FR^SA",U,M)
  1.  Q DAYS
  1.  ;
  1. HSPRINT(CLINIC,MODE) ;EP; -- returns data on printing HS and its type
  1.  ; MODE="I" for return internal values
  1.  NEW X,Y
  1.  S MODE=$G(MODE)
  1.  S X=$$GET1^DIQ(9009017.2,CLINIC,.04,"I") S:X="" S=0
  1.  S Y=$$GET1^DIQ(9009017.2,CLINIC,.05,MODE)
  1.  Q $S(MODE="I":X_U_Y,X=1:"YES, "_Y,1:"NO")
  1.  ;
  1. GREETING(LETTER,PAT) ;EP; -- returns letter salutation
  1.  NEW LINE
  1.  S LINE="Dear "
  1.  ;
  1.  I $$GET1^DIQ(407.5,LETTER,9999999.01)="YES",$$AGE^AUPNPAT(PAT)<18 D
  1.  . S LINE=LINE_"Parents of "
  1.  ;
  1.  E  I $$GET1^DIQ(9009020.2,$$DIV,.07)'="YES" D
  1.  . S LINE=LINE_$S($$SEX^AUPNPAT(PAT)="M":"Mr. ",1:"Ms. ")
  1.  ;
  1.  ;S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1)  ;add printable name
  1.  S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1)_","  ;add printable name; IHS/ITSC/WAR 7/8/2004 PATCH #1001
  1.  Q LINE
  1.  ;
  1. LEGEND(ARRAY) ;EP; -- returns legend explaining month-at-a-glance display   
  1.  S ARRAY(1)="FOR CLINIC AVAILABILITY PATTERNS:"
  1.  S ARRAY(2)=$$PAD("  0-9 and j-z",15)_" --denote available slots where j=10,k=11...z=26"
  1.  S ARRAY(3)=$$PAD("  A-W",15)_" --denote overbooks with A being the first slot to be overbooked"
  1.  S ARRAY(4)=$$SP(18)_"and B being the second for that same time, etc."
  1.  S ARRAY(5)=$$PAD("  *,$,!,@,#",15)_" --denote overbooks or appts. that fall outside of a clinic's"
  1.  S ARRAY(6)=$$SP(18)_"regular hours" Q
  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)
  1.  ;
  1. GETTAX(TNI) ;-- get taxonomy name
  1.  S DIC="^ATXAX(",DIC(0)="AEMQZ",DIC("A")="Select Taxonomy: ",DIC("S")="I $P(^(0),U,15)=44"
  1.  D ^DIC
  1.  I Y<0 Q ""
  1.  N TDA,CNT,DATA
  1.  S CNT=0
  1.  S TDA=0 F  S TDA=$O(^ATXAX(+Y,21,TDA)) Q:'TDA  D
  1.  . S CNT=CNT+1
  1.  . S DATA=$G(^ATXAX(+Y,21,TDA,0))
  1.  . I TNI=2 S VAUTC(DATA)=$P($G(^SC(DATA,0)),U)
  1.  . I TNI=1 S VAUTC($P($G(^SC(DATA,0)),U))=DATA
  1.  K DIC
  1.  Q +$G(Y)
  1.  ;
  1. TAX(ARRAY,TNI) ;-- get taxonomy name
  1.  N TAXE
  1.  S DLAYGO=9002226,ATXFLG=1
  1.  S DIC="^ATXAX(",DIC(0)="AEMQLZ",DIC("A")="Taxonomy Name: "
  1.  D ^DIC
  1.  Q:Y<0
  1.  S TAXE=+Y
  1.  N FDA,FIENS,FERR
  1.  S FIENS=TAXE_","
  1.  S FDA(9002226,FIENS,.02)="PIMS Report Clinic Taxonomy"
  1.  S FDA(9002226,FIENS,.09)=DT
  1.  S FDA(9002226,FIENS,.15)=44
  1.  D FILE^DIE("K","FDA","FERR(1)")
  1.  N BDA
  1.  S BDA=0 F  S BDA=$O(ARRAY(BDA)) Q:BDA=""  D
  1.  . N AFDA,AFIENS,AFERR
  1.  . S AFIENS="+2,"_TAXE_","
  1.  . S AFDA(9002226.02101,AFIENS,.01)=$S(TNI=1:$O(^SC("B",BDA,0)),1:BDA)
  1.  . D UPDATE^DIE("","AFDA","AFIENS","AFERR(1)")
  1.  . S MARK=$G(AFIENS(2))
  1.  Q
  1.  ;