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