SDESCLINICSET2 ;ALB/TAW/MGD/RRM/MGD - CLINIC CREATE AND UPDATE ;July 10, 2023
;;5.3;Scheduling;**799,813,827,828,846**;Aug 13, 1993;Build 12
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to ^ICDEX( in ICR #5747
; Reference to ^VA(200 in ICR #10060
;
Q
GETDEFAULT(INDEX,SDIEN) ;Get the IEN of the disposition or provider flagged as default
N KEY,RETURN,SDIENS
S RETURN=""
Q:'$G(SDIEN) ""
S KEY=$O(^SC(INDEX,SDIEN,""))
I INDEX="ADDX",KEY D
.S SDIENS=KEY_","_SDIEN_","
.S RETURN=$$GET1^DIQ(44.11,SDIENS,.01,"I")
I INDEX="ADPR",KEY D
.S SDIENS=KEY_","_SDIEN_","
.S RETURN=$$GET1^DIQ(44.1,SDIENS,.01,"I")
Q RETURN
;
CHECKYN(VAR) ;
I VAR'="@",VAR'="",VAR'="Y",VAR'="N" Q 0
Q 1
;
LETTERIEN(LETTER,NAME) ;Look up the letter IEN
N RETURN
I LETTER'="@",LETTER'="" D
.;I +LETTER,$D(^VA(407.5,LETTER,0)) Q
.I +LETTER,$$GET1^DIQ(407.5,LETTER,.01)'="" Q
.S LETTER=$O(^VA(407.5,"B",$E(LETTER,1,30),""))
.I 'LETTER D ERRLOG^SDESCLINICSET(82,NAME)
Q LETTER
;
SAVE(POP,SDIEN,FDA,SDCLINIC,PROVIDER,DIAGNOSIS,SPECIALINSTRUCT,PRIVLIAGEDUSER) ;
N CLINRET,CLINMSG,MI,IEN
I $D(FDA(44))'>9 D ERRLOG^SDESCLINICSET(47,"No changes found") Q
D UPDATE^DIE("","FDA","CLINRET","CLINMSG")
I $D(CLINMSG) D Q
. F MI=1:1:$G(CLINMSG("DIERR")) D ERRLOG^SDESCLINICSET(48,$G(CLINMSG("DIERR",MI,"TEXT",1)))
;
S IEN=$S(+SDIEN:+SDIEN,1:CLINRET(1))
; Add clinic HASH info
D ADDHASH2CLIN^SDESRTVCLN2(IEN)
; Add entry to SDEC RESOURCE (#409.831) file VSE-2769
D SDRES(IEN)
;
I $D(PROVIDER) D PROVIDER
I $D(DIAGNOSIS) D DIAGNOSIS
I $D(SPECIALINSTRUCT) D INSTRUCTION
I $D(PRIVLIAGEDUSER) D PRIVUSERS(IEN,.PRIVLIAGEDUSER)
;
I +$G(CLINRET(1)) S SDCLINIC("ClinicCreate","IEN")=IEN
E S SDCLINIC("ClinicUpdate","IEN")=IEN
Q
;
PROVIDER ;Upodate the Provider multiple in field 44.1
N KEY,ACTION,SDFDA,PROVIEN,PROV44IEN
S KEY=""
F S KEY=$O(PROVIDER(KEY)) Q:KEY="" D
.S PROVIEN=""
.F S PROVIEN=$O(PROVIDER(KEY,PROVIEN)) Q:PROVIEN="" D
..S ACTION=PROVIDER(KEY,PROVIEN)
..; Is provider already linked to clinic?
..S PROV44IEN=$O(^SC(IEN,"PR","B",PROVIEN,""))
..I PROV44IEN="" S PROV44IEN="+1" ;New provider
..I ACTION="@",PROV44IEN="+1" Q ;Can't delete if not linked to clinic
..I ACTION="@" S SDFDA(44.1,PROV44IEN_","_IEN_",",.01)="@"
..I PROV44IEN="+1" S SDFDA(44.1,PROV44IEN_","_IEN_",",.01)=PROVIEN
..I ACTION'="@" S SDFDA(44.1,PROV44IEN_","_IEN_",",.02)=$S(ACTION="D":1,1:0)
..D UPDATE^DIE("","SDFDA") K SDFDA
Q
;
DIAGNOSIS ;Diagnosis multiple in field 44.11
N SDFDA,KEY,ACTION,DIAGIEN,DIAG44IEN
;SD*828:remove any existing diagnosis tied to this clinic before adding
;the diagnosis list(s) to be exactly what was passed in as input from the RPC
D DELDIAGNOSIS^SDESINPUTVALUTL($G(SDIEN))
S KEY=""
F S KEY=$O(DIAGNOSIS(KEY)) Q:KEY="" D
.S DIAGIEN=""
.F S DIAGIEN=$O(DIAGNOSIS(KEY,DIAGIEN)) Q:DIAGIEN="" D
..S ACTION=DIAGNOSIS(KEY,DIAGIEN)
..; Is diag already linked to clinic?
..S DIAG44IEN=$O(^SC(IEN,"DX","B",DIAGIEN,""))
..I DIAG44IEN="" S DIAG44IEN="+1" ;New diag
..I ACTION="@",DIAG44IEN="+1" Q ;Can't delete if not linked to clinic
..I ACTION="@" S SDFDA(44.11,DIAG44IEN_","_IEN_",",.01)="@"
..I DIAG44IEN="+1" S SDFDA(44.11,DIAG44IEN_","_IEN_",",.01)=DIAGIEN
..I ACTION'="@" S SDFDA(44.11,DIAG44IEN_","_IEN_",",.02)=$S(ACTION="D":1,1:0)
..D UPDATE^DIE("","SDFDA") K SDFDA
Q
;
INSTRUCTION ;Special instructions multiple in field 44.03
N SDFDA,KEY,DATA,SIIEN
S KEY=""
F S KEY=$O(SPECIALINSTRUCT(KEY)) Q:KEY="" D
.S INSTRUCTION=""
.F S INSTRUCTION=$O(SPECIALINSTRUCT(KEY,INSTRUCTION)) Q:INSTRUCTION="" D
..S ACTION=SPECIALINSTRUCT(KEY,INSTRUCTION),SIIEN=""
..I INSTRUCTION?1.N S SIIEN=INSTRUCTION
..E S SIIEN=0 F S SIIEN=$O(^SC(IEN,"SI",SIIEN)) Q:SIIEN="" Q:INSTRUCTION=$G(^SC(IEN,"SI",+SIIEN,0))
..I SIIEN="" S SIIEN="+1"
..I ACTION="@",SIIEN="+1" Q ;Can't delete iF not linked to Clinic
..S SDFDA(44.03,SIIEN_","_IEN_",",.01)=$S(ACTION="@":"@",1:INSTRUCTION)
..D UPDATE^DIE("","SDFDA") K SDFDA
Q
;
PRIVUSERS(SDIEN,PRIVLIAGEDUSER) ;Privileged user multiple 44.04
N KEY,PRIVUSER,ELGRETURN,ADDFLAG
S KEY="",ELGRETURN=""
F S KEY=$O(PRIVLIAGEDUSER(KEY)) Q:KEY="" D
.S PRIVUSER=""
.F S PRIVUSER=$O(PRIVLIAGEDUSER(KEY,PRIVUSER)) Q:PRIVUSER="" D
..S ADDFLAG=$S(+KEY=1:0,1:1)
..D UPDPRIV^SDESLOC(ELGRETURN,ADDFLAG,SDIEN,PRIVUSER)
Q
;
VALIDATEPROV(SDPROVIDER,PROVIDER,IEN) ;
N DEFAULT,DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW,I,ACTION,PROV,PROVDATA,KEY
S (DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW)=""
S DEFAULT=$$GETDEFAULT("ADPR",IEN) ;Get current diag default for this clinic
S I="" F I=1:1:$L(SDPROVIDER,";") D
.S PROVDATA=$P(SDPROVIDER,";",I)
.Q:$P(PROVDATA,"|")=""!(PROVDATA="@")
.S ACTION=$P(PROVDATA,"|",2)
.I ACTION'="",ACTION'="@",ACTION'="D",ACTION'="@D" D ERRLOG^SDESCLINICSET(52,"Provider special action code is invalid") Q
.S PROV=$P(PROVDATA,"|")
.;
.S KEY="3-ADD PROVIDER" ;default
.I ACTION="@D" S KEY="2-REMOVE DEFAULT" ;takes priority over add provider
.I ACTION="@" S KEY="1-REMOVE PROVIDER" ;takes priority over remove default
.I +PROV,$D(^VA(200,PROV,0)) D SETPROV Q
.S PROV=$O(^VA(200,"B",$E(PROV,1,30),""),-1)
.I PROV="" D ERRLOG^SDESCLINICSET(54) Q
.D SETPROV
.; Only 1 provider allowed to be flagged as default / default removal
I DEFAULTCNT>1 D ERRLOG^SDESCLINICSET(52,"Only 1 provider can be set as default") Q
I DEFAULTCNT2>1 D ERRLOG^SDESCLINICSET(52,"Only 1 default provider removal is allowed") Q
;If adding a default, make sure the current default is being removed
I DEFAULTNEW,DEFAULT,DEFAULT'=DEFAULTNEW D
.; If current default is not identified to have its default flag removed then send error
.I DEFAULT'=DEFAULTREMOVE D ERRLOG^SDESCLINICSET(120)
Q
SETPROV ;
S PROVIDER(KEY,PROV)=ACTION
I ACTION="D" S DEFAULTCNT=DEFAULTCNT+1,DEFAULTNEW=PROV
I ACTION="@D" S DEFAULTCNT2=DEFAULTCNT2+1,DEFAULTREMOVE=PROV
Q
;
VALIDATEDIAG(SDDIAG,DIAGNOSIS,IEN) ;
N DEFAULT,DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW,I,ACTION,DIAG,DIAGDATA,KEY
S (DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW)=""
S DEFAULT=$$GETDEFAULT("ADDX",IEN) ;Get current Diagnosis default for this clinic
S I="" F I=1:1:$L(SDDIAG,";") D
.S DIAGDATA=$P(SDDIAG,";",I)
.Q:$P(DIAGDATA,"|")=""!(DIAGDATA="@")
.S ACTION=$P(DIAGDATA,"|",2)
.I ACTION'="",ACTION'="@",ACTION'="D",ACTION'="@D" D ERRLOG^SDESCLINICSET(52,"Diagnosis special action code is invalid") Q
.S DIAG=$P(DIAGDATA,"|")
.;
.S KEY="3-ADD DIAGNOSIS" ;default
.I ACTION="@D" S KEY="2-REMOVE DEFAULT" ;takes priority over add diagnosis
.I ACTION="@" S KEY="1-REMOVE DIAGNOSIS" ;Takes priority over remove default
.;I +DIAG,$D(^ICD9(DIAG,0)) D SETDIAG Q
.I +DIAG,$$GET1^DIQ(80,DIAG,.01)'="" D Q
..I $$GETDIAGSTAT^SDESINPUTVALUTL(DIAG)<1 D ERRLOG^SDESCLINICSET(363) Q ;SD*828-Inactive diagnosis not allowed
..D SETDIAG
.;S DIAG=$O(^ICD9("BA",$E(DIAG_" ",1,30),""),-1)
.S DIAG=+$$CODEN^ICDEX(DIAG,80)
.I DIAG=-1 D ERRLOG^SDESCLINICSET(85) Q
.I $$GETDIAGSTAT^SDESINPUTVALUTL(DIAG)<1 D ERRLOG^SDESCLINICSET(363) Q
.D SETDIAG
; Only 1 diag allowed to be flagged as default / default removal
I DEFAULTCNT>1 D ERRLOG^SDESCLINICSET(52,"Only 1 diagnosis can be set as default") Q
I DEFAULTCNT2>1 D ERRLOG^SDESCLINICSET(52,"Only 1 default diagnosis removal is allowed") Q
;If adding a default, make sure the current default is being removed
I DEFAULTNEW,DEFAULT,DEFAULT'=DEFAULTNEW D
.; If current default is not identified to have its default flag removed then send error
.I DEFAULT'=DEFAULTREMOVE D ERRLOG^SDESCLINICSET(121)
Q
SETDIAG ;
S DIAGNOSIS(KEY,DIAG)=ACTION
I ACTION="D" S DEFAULTCNT=DEFAULTCNT+1,DEFAULTNEW=DIAG
I ACTION="@D" S DEFAULTCNT2=DEFAULTCNT2+1,DEFAULTREMOVE=DIAG
Q
;
VALIDATEPPRIVUSR(SDNOACCESS,PRIVLIAGEDUSER) ;
N I,PRIVUSER,ACTION,KEY
I $E(SDNOACCESS)="@" S SDNOACCESS="@"
I SDNOACCESS'="@",$E(SDNOACCESS)'="Y" S SDNOACCESS="" ;Default
I $E(SDNOACCESS)="Y" D
.F I=2:1:$L(SDNOACCESS,";") D
..S PRIVUSER=$P(SDNOACCESS,";",I)
..S ACTION=$P(PRIVUSER,"|",2)
..S PRIVUSER=$P(PRIVUSER,"|")
..Q:PRIVUSER=""
..I ACTION'="@" S ACTION=""
..S KEY="1-REMOVE USER"
..S:ACTION="" KEY="2-ADD USER"
..I +PRIVUSER,$D(^VA(200,PRIVUSER,0)) S PRIVLIAGEDUSER(KEY,PRIVUSER)=ACTION Q
..S PRIVUSER=$O(^VA(200,"B",$E(PRIVUSER,1,30),""),-1)
..I PRIVUSER="" D ERRLOG^SDESCLINICSET(86) Q
..S PRIVLIAGEDUSER(KEY,PRIVUSER)=ACTION
.S SDNOACCESS="Y"
Q
;
VALIDATESI(SDSPECINSTRU,SPECIALINSTRUCT) ;
N I,INSTRUCTION,ACTION,KEY,MAXCHAR
S MAXCHAR=80
S I="" F I=1:1:$L(SDSPECINSTRU,";") D
.S INSTRUCTION=$P(SDSPECINSTRU,";",I)
.Q:$P(INSTRUCTION,"|")=""!(INSTRUCTION="@")
.S ACTION=$P(INSTRUCTION,"|",2)
.I ACTION'="",ACTION'="@" D ERRLOG^SDESCLINICSET(52,"Instructions special action code is invalid") Q
.S INSTRUCTION=$P(INSTRUCTION,"|")
.I $L(INSTRUCTION)>MAXCHAR D ERRLOG^SDESCLINICSET(52,"Instructions can not exceed "_MAXCHAR_" chars") Q
.S KEY="2-ADD INSTRUCTION"
.I ACTION="@" S KEY="1-REMOVE INSTRUCTION"
.S SPECIALINSTRUCT(KEY,INSTRUCTION)=ACTION
S SDSPECINSTRU=$E(SDSPECINSTRU) ;Get the Y/N value
Q
;
YNTOBOOL(VAR) ;convert a Y/N input param to 1 or 0
Q $S(VAR="Y":1,VAR="N":0,1:VAR)
;
SDRES(SDCL) ;add clinic resource
N ABBR,SDDATA,SDDI,SDFDA,SDFOUND,SDI,SDNOD,SDRT,SDFIELDS
S SDFOUND=0
S SDI="" F S SDI=$O(^SDEC(409.831,"ALOC",SDCL,SDI)) Q:SDI="" D Q:SDFOUND=1
.S SDNOD=$G(^SDEC(409.831,SDI,0))
.S SDRT=$P(SDNOD,U,11)
.I $P(SDRT,";",2)="SC(",$P(SDRT,";",1)=SDCL S SDFOUND=1
S SDI=$S(SDFOUND=1:SDI,1:"+1")
S SDFIELDS=".01;1;1917" ;alb/sat 658 - add field 1
D GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA")
S SDFDA(409.831,SDI_",",.01)=SDDATA(44,SDCL_",",.01,"E")
S SDDI=SDDATA(44,SDCL_",",1917,"E") S SDFDA(409.831,SDI_",",.03)=$E(SDDI,1,2)
S ABBR=SDDATA(44,SDCL_",",1,"E") S:ABBR'="" SDFDA(409.831,SDI_",",.011)=ABBR ;alb/sat 658 - add abbreviation
S SDFDA(409.831,SDI_",",.04)=SDCL
S SDFDA(409.831,SDI_",",.012)=SDCL_";SC("
S SDFDA(409.831,SDI_",",.015)=$E($$NOW^XLFDT,1,12)
S SDFDA(409.831,SDI_",",.016)=DUZ
D UPDATE^DIE("","SDFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESCLINICSET2 10277 printed Dec 13, 2024@02:56:13 Page 2
SDESCLINICSET2 ;ALB/TAW/MGD/RRM/MGD - CLINIC CREATE AND UPDATE ;July 10, 2023
+1 ;;5.3;Scheduling;**799,813,827,828,846**;Aug 13, 1993;Build 12
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to ^ICDEX( in ICR #5747
+5 ; Reference to ^VA(200 in ICR #10060
+6 ;
+7 QUIT
GETDEFAULT(INDEX,SDIEN) ;Get the IEN of the disposition or provider flagged as default
+1 NEW KEY,RETURN,SDIENS
+2 SET RETURN=""
+3 if '$GET(SDIEN)
QUIT ""
+4 SET KEY=$ORDER(^SC(INDEX,SDIEN,""))
+5 IF INDEX="ADDX"
IF KEY
Begin DoDot:1
+6 SET SDIENS=KEY_","_SDIEN_","
+7 SET RETURN=$$GET1^DIQ(44.11,SDIENS,.01,"I")
End DoDot:1
+8 IF INDEX="ADPR"
IF KEY
Begin DoDot:1
+9 SET SDIENS=KEY_","_SDIEN_","
+10 SET RETURN=$$GET1^DIQ(44.1,SDIENS,.01,"I")
End DoDot:1
+11 QUIT RETURN
+12 ;
CHECKYN(VAR) ;
+1 IF VAR'="@"
IF VAR'=""
IF VAR'="Y"
IF VAR'="N"
QUIT 0
+2 QUIT 1
+3 ;
LETTERIEN(LETTER,NAME) ;Look up the letter IEN
+1 NEW RETURN
+2 IF LETTER'="@"
IF LETTER'=""
Begin DoDot:1
+3 ;I +LETTER,$D(^VA(407.5,LETTER,0)) Q
+4 IF +LETTER
IF $$GET1^DIQ(407.5,LETTER,.01)'=""
QUIT
+5 SET LETTER=$ORDER(^VA(407.5,"B",$EXTRACT(LETTER,1,30),""))
+6 IF 'LETTER
DO ERRLOG^SDESCLINICSET(82,NAME)
End DoDot:1
+7 QUIT LETTER
+8 ;
SAVE(POP,SDIEN,FDA,SDCLINIC,PROVIDER,DIAGNOSIS,SPECIALINSTRUCT,PRIVLIAGEDUSER) ;
+1 NEW CLINRET,CLINMSG,MI,IEN
+2 IF $DATA(FDA(44))'>9
DO ERRLOG^SDESCLINICSET(47,"No changes found")
QUIT
+3 DO UPDATE^DIE("","FDA","CLINRET","CLINMSG")
+4 IF $DATA(CLINMSG)
Begin DoDot:1
+5 FOR MI=1:1:$GET(CLINMSG("DIERR"))
DO ERRLOG^SDESCLINICSET(48,$GET(CLINMSG("DIERR",MI,"TEXT",1)))
End DoDot:1
QUIT
+6 ;
+7 SET IEN=$SELECT(+SDIEN:+SDIEN,1:CLINRET(1))
+8 ; Add clinic HASH info
+9 DO ADDHASH2CLIN^SDESRTVCLN2(IEN)
+10 ; Add entry to SDEC RESOURCE (#409.831) file VSE-2769
+11 DO SDRES(IEN)
+12 ;
+13 IF $DATA(PROVIDER)
DO PROVIDER
+14 IF $DATA(DIAGNOSIS)
DO DIAGNOSIS
+15 IF $DATA(SPECIALINSTRUCT)
DO INSTRUCTION
+16 IF $DATA(PRIVLIAGEDUSER)
DO PRIVUSERS(IEN,.PRIVLIAGEDUSER)
+17 ;
+18 IF +$GET(CLINRET(1))
SET SDCLINIC("ClinicCreate","IEN")=IEN
+19 IF '$TEST
SET SDCLINIC("ClinicUpdate","IEN")=IEN
+20 QUIT
+21 ;
PROVIDER ;Upodate the Provider multiple in field 44.1
+1 NEW KEY,ACTION,SDFDA,PROVIEN,PROV44IEN
+2 SET KEY=""
+3 FOR
SET KEY=$ORDER(PROVIDER(KEY))
if KEY=""
QUIT
Begin DoDot:1
+4 SET PROVIEN=""
+5 FOR
SET PROVIEN=$ORDER(PROVIDER(KEY,PROVIEN))
if PROVIEN=""
QUIT
Begin DoDot:2
+6 SET ACTION=PROVIDER(KEY,PROVIEN)
+7 ; Is provider already linked to clinic?
+8 SET PROV44IEN=$ORDER(^SC(IEN,"PR","B",PROVIEN,""))
+9 ;New provider
IF PROV44IEN=""
SET PROV44IEN="+1"
+10 ;Can't delete if not linked to clinic
IF ACTION="@"
IF PROV44IEN="+1"
QUIT
+11 IF ACTION="@"
SET SDFDA(44.1,PROV44IEN_","_IEN_",",.01)="@"
+12 IF PROV44IEN="+1"
SET SDFDA(44.1,PROV44IEN_","_IEN_",",.01)=PROVIEN
+13 IF ACTION'="@"
SET SDFDA(44.1,PROV44IEN_","_IEN_",",.02)=$SELECT(ACTION="D":1,1:0)
+14 DO UPDATE^DIE("","SDFDA")
KILL SDFDA
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
DIAGNOSIS ;Diagnosis multiple in field 44.11
+1 NEW SDFDA,KEY,ACTION,DIAGIEN,DIAG44IEN
+2 ;SD*828:remove any existing diagnosis tied to this clinic before adding
+3 ;the diagnosis list(s) to be exactly what was passed in as input from the RPC
+4 DO DELDIAGNOSIS^SDESINPUTVALUTL($GET(SDIEN))
+5 SET KEY=""
+6 FOR
SET KEY=$ORDER(DIAGNOSIS(KEY))
if KEY=""
QUIT
Begin DoDot:1
+7 SET DIAGIEN=""
+8 FOR
SET DIAGIEN=$ORDER(DIAGNOSIS(KEY,DIAGIEN))
if DIAGIEN=""
QUIT
Begin DoDot:2
+9 SET ACTION=DIAGNOSIS(KEY,DIAGIEN)
+10 ; Is diag already linked to clinic?
+11 SET DIAG44IEN=$ORDER(^SC(IEN,"DX","B",DIAGIEN,""))
+12 ;New diag
IF DIAG44IEN=""
SET DIAG44IEN="+1"
+13 ;Can't delete if not linked to clinic
IF ACTION="@"
IF DIAG44IEN="+1"
QUIT
+14 IF ACTION="@"
SET SDFDA(44.11,DIAG44IEN_","_IEN_",",.01)="@"
+15 IF DIAG44IEN="+1"
SET SDFDA(44.11,DIAG44IEN_","_IEN_",",.01)=DIAGIEN
+16 IF ACTION'="@"
SET SDFDA(44.11,DIAG44IEN_","_IEN_",",.02)=$SELECT(ACTION="D":1,1:0)
+17 DO UPDATE^DIE("","SDFDA")
KILL SDFDA
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
INSTRUCTION ;Special instructions multiple in field 44.03
+1 NEW SDFDA,KEY,DATA,SIIEN
+2 SET KEY=""
+3 FOR
SET KEY=$ORDER(SPECIALINSTRUCT(KEY))
if KEY=""
QUIT
Begin DoDot:1
+4 SET INSTRUCTION=""
+5 FOR
SET INSTRUCTION=$ORDER(SPECIALINSTRUCT(KEY,INSTRUCTION))
if INSTRUCTION=""
QUIT
Begin DoDot:2
+6 SET ACTION=SPECIALINSTRUCT(KEY,INSTRUCTION)
SET SIIEN=""
+7 IF INSTRUCTION?1.N
SET SIIEN=INSTRUCTION
+8 IF '$TEST
SET SIIEN=0
FOR
SET SIIEN=$ORDER(^SC(IEN,"SI",SIIEN))
if SIIEN=""
QUIT
if INSTRUCTION=$GET(^SC(IEN,"SI",+SIIEN,0))
QUIT
+9 IF SIIEN=""
SET SIIEN="+1"
+10 ;Can't delete iF not linked to Clinic
IF ACTION="@"
IF SIIEN="+1"
QUIT
+11 SET SDFDA(44.03,SIIEN_","_IEN_",",.01)=$SELECT(ACTION="@":"@",1:INSTRUCTION)
+12 DO UPDATE^DIE("","SDFDA")
KILL SDFDA
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
PRIVUSERS(SDIEN,PRIVLIAGEDUSER) ;Privileged user multiple 44.04
+1 NEW KEY,PRIVUSER,ELGRETURN,ADDFLAG
+2 SET KEY=""
SET ELGRETURN=""
+3 FOR
SET KEY=$ORDER(PRIVLIAGEDUSER(KEY))
if KEY=""
QUIT
Begin DoDot:1
+4 SET PRIVUSER=""
+5 FOR
SET PRIVUSER=$ORDER(PRIVLIAGEDUSER(KEY,PRIVUSER))
if PRIVUSER=""
QUIT
Begin DoDot:2
+6 SET ADDFLAG=$SELECT(+KEY=1:0,1:1)
+7 DO UPDPRIV^SDESLOC(ELGRETURN,ADDFLAG,SDIEN,PRIVUSER)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
VALIDATEPROV(SDPROVIDER,PROVIDER,IEN) ;
+1 NEW DEFAULT,DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW,I,ACTION,PROV,PROVDATA,KEY
+2 SET (DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW)=""
+3 ;Get current diag default for this clinic
SET DEFAULT=$$GETDEFAULT("ADPR",IEN)
+4 SET I=""
FOR I=1:1:$LENGTH(SDPROVIDER,";")
Begin DoDot:1
+5 SET PROVDATA=$PIECE(SDPROVIDER,";",I)
+6 if $PIECE(PROVDATA,"|")=""!(PROVDATA="@")
QUIT
+7 SET ACTION=$PIECE(PROVDATA,"|",2)
+8 IF ACTION'=""
IF ACTION'="@"
IF ACTION'="D"
IF ACTION'="@D"
DO ERRLOG^SDESCLINICSET(52,"Provider special action code is invalid")
QUIT
+9 SET PROV=$PIECE(PROVDATA,"|")
+10 ;
+11 ;default
SET KEY="3-ADD PROVIDER"
+12 ;takes priority over add provider
IF ACTION="@D"
SET KEY="2-REMOVE DEFAULT"
+13 ;takes priority over remove default
IF ACTION="@"
SET KEY="1-REMOVE PROVIDER"
+14 IF +PROV
IF $DATA(^VA(200,PROV,0))
DO SETPROV
QUIT
+15 SET PROV=$ORDER(^VA(200,"B",$EXTRACT(PROV,1,30),""),-1)
+16 IF PROV=""
DO ERRLOG^SDESCLINICSET(54)
QUIT
+17 DO SETPROV
+18 ; Only 1 provider allowed to be flagged as default / default removal
End DoDot:1
+19 IF DEFAULTCNT>1
DO ERRLOG^SDESCLINICSET(52,"Only 1 provider can be set as default")
QUIT
+20 IF DEFAULTCNT2>1
DO ERRLOG^SDESCLINICSET(52,"Only 1 default provider removal is allowed")
QUIT
+21 ;If adding a default, make sure the current default is being removed
+22 IF DEFAULTNEW
IF DEFAULT
IF DEFAULT'=DEFAULTNEW
Begin DoDot:1
+23 ; If current default is not identified to have its default flag removed then send error
+24 IF DEFAULT'=DEFAULTREMOVE
DO ERRLOG^SDESCLINICSET(120)
End DoDot:1
+25 QUIT
SETPROV ;
+1 SET PROVIDER(KEY,PROV)=ACTION
+2 IF ACTION="D"
SET DEFAULTCNT=DEFAULTCNT+1
SET DEFAULTNEW=PROV
+3 IF ACTION="@D"
SET DEFAULTCNT2=DEFAULTCNT2+1
SET DEFAULTREMOVE=PROV
+4 QUIT
+5 ;
VALIDATEDIAG(SDDIAG,DIAGNOSIS,IEN) ;
+1 NEW DEFAULT,DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW,I,ACTION,DIAG,DIAGDATA,KEY
+2 SET (DEFAULTCNT,DEFAULTCNT2,DEFAULTREMOVE,DEFAULTNEW)=""
+3 ;Get current Diagnosis default for this clinic
SET DEFAULT=$$GETDEFAULT("ADDX",IEN)
+4 SET I=""
FOR I=1:1:$LENGTH(SDDIAG,";")
Begin DoDot:1
+5 SET DIAGDATA=$PIECE(SDDIAG,";",I)
+6 if $PIECE(DIAGDATA,"|")=""!(DIAGDATA="@")
QUIT
+7 SET ACTION=$PIECE(DIAGDATA,"|",2)
+8 IF ACTION'=""
IF ACTION'="@"
IF ACTION'="D"
IF ACTION'="@D"
DO ERRLOG^SDESCLINICSET(52,"Diagnosis special action code is invalid")
QUIT
+9 SET DIAG=$PIECE(DIAGDATA,"|")
+10 ;
+11 ;default
SET KEY="3-ADD DIAGNOSIS"
+12 ;takes priority over add diagnosis
IF ACTION="@D"
SET KEY="2-REMOVE DEFAULT"
+13 ;Takes priority over remove default
IF ACTION="@"
SET KEY="1-REMOVE DIAGNOSIS"
+14 ;I +DIAG,$D(^ICD9(DIAG,0)) D SETDIAG Q
+15 IF +DIAG
IF $$GET1^DIQ(80,DIAG,.01)'=""
Begin DoDot:2
+16 ;SD*828-Inactive diagnosis not allowed
IF $$GETDIAGSTAT^SDESINPUTVALUTL(DIAG)<1
DO ERRLOG^SDESCLINICSET(363)
QUIT
+17 DO SETDIAG
End DoDot:2
QUIT
+18 ;S DIAG=$O(^ICD9("BA",$E(DIAG_" ",1,30),""),-1)
+19 SET DIAG=+$$CODEN^ICDEX(DIAG,80)
+20 IF DIAG=-1
DO ERRLOG^SDESCLINICSET(85)
QUIT
+21 IF $$GETDIAGSTAT^SDESINPUTVALUTL(DIAG)<1
DO ERRLOG^SDESCLINICSET(363)
QUIT
+22 DO SETDIAG
End DoDot:1
+23 ; Only 1 diag allowed to be flagged as default / default removal
+24 IF DEFAULTCNT>1
DO ERRLOG^SDESCLINICSET(52,"Only 1 diagnosis can be set as default")
QUIT
+25 IF DEFAULTCNT2>1
DO ERRLOG^SDESCLINICSET(52,"Only 1 default diagnosis removal is allowed")
QUIT
+26 ;If adding a default, make sure the current default is being removed
+27 IF DEFAULTNEW
IF DEFAULT
IF DEFAULT'=DEFAULTNEW
Begin DoDot:1
+28 ; If current default is not identified to have its default flag removed then send error
+29 IF DEFAULT'=DEFAULTREMOVE
DO ERRLOG^SDESCLINICSET(121)
End DoDot:1
+30 QUIT
SETDIAG ;
+1 SET DIAGNOSIS(KEY,DIAG)=ACTION
+2 IF ACTION="D"
SET DEFAULTCNT=DEFAULTCNT+1
SET DEFAULTNEW=DIAG
+3 IF ACTION="@D"
SET DEFAULTCNT2=DEFAULTCNT2+1
SET DEFAULTREMOVE=DIAG
+4 QUIT
+5 ;
VALIDATEPPRIVUSR(SDNOACCESS,PRIVLIAGEDUSER) ;
+1 NEW I,PRIVUSER,ACTION,KEY
+2 IF $EXTRACT(SDNOACCESS)="@"
SET SDNOACCESS="@"
+3 ;Default
IF SDNOACCESS'="@"
IF $EXTRACT(SDNOACCESS)'="Y"
SET SDNOACCESS=""
+4 IF $EXTRACT(SDNOACCESS)="Y"
Begin DoDot:1
+5 FOR I=2:1:$LENGTH(SDNOACCESS,";")
Begin DoDot:2
+6 SET PRIVUSER=$PIECE(SDNOACCESS,";",I)
+7 SET ACTION=$PIECE(PRIVUSER,"|",2)
+8 SET PRIVUSER=$PIECE(PRIVUSER,"|")
+9 if PRIVUSER=""
QUIT
+10 IF ACTION'="@"
SET ACTION=""
+11 SET KEY="1-REMOVE USER"
+12 if ACTION=""
SET KEY="2-ADD USER"
+13 IF +PRIVUSER
IF $DATA(^VA(200,PRIVUSER,0))
SET PRIVLIAGEDUSER(KEY,PRIVUSER)=ACTION
QUIT
+14 SET PRIVUSER=$ORDER(^VA(200,"B",$EXTRACT(PRIVUSER,1,30),""),-1)
+15 IF PRIVUSER=""
DO ERRLOG^SDESCLINICSET(86)
QUIT
+16 SET PRIVLIAGEDUSER(KEY,PRIVUSER)=ACTION
End DoDot:2
+17 SET SDNOACCESS="Y"
End DoDot:1
+18 QUIT
+19 ;
VALIDATESI(SDSPECINSTRU,SPECIALINSTRUCT) ;
+1 NEW I,INSTRUCTION,ACTION,KEY,MAXCHAR
+2 SET MAXCHAR=80
+3 SET I=""
FOR I=1:1:$LENGTH(SDSPECINSTRU,";")
Begin DoDot:1
+4 SET INSTRUCTION=$PIECE(SDSPECINSTRU,";",I)
+5 if $PIECE(INSTRUCTION,"|")=""!(INSTRUCTION="@")
QUIT
+6 SET ACTION=$PIECE(INSTRUCTION,"|",2)
+7 IF ACTION'=""
IF ACTION'="@"
DO ERRLOG^SDESCLINICSET(52,"Instructions special action code is invalid")
QUIT
+8 SET INSTRUCTION=$PIECE(INSTRUCTION,"|")
+9 IF $LENGTH(INSTRUCTION)>MAXCHAR
DO ERRLOG^SDESCLINICSET(52,"Instructions can not exceed "_MAXCHAR_" chars")
QUIT
+10 SET KEY="2-ADD INSTRUCTION"
+11 IF ACTION="@"
SET KEY="1-REMOVE INSTRUCTION"
+12 SET SPECIALINSTRUCT(KEY,INSTRUCTION)=ACTION
End DoDot:1
+13 ;Get the Y/N value
SET SDSPECINSTRU=$EXTRACT(SDSPECINSTRU)
+14 QUIT
+15 ;
YNTOBOOL(VAR) ;convert a Y/N input param to 1 or 0
+1 QUIT $SELECT(VAR="Y":1,VAR="N":0,1:VAR)
+2 ;
SDRES(SDCL) ;add clinic resource
+1 NEW ABBR,SDDATA,SDDI,SDFDA,SDFOUND,SDI,SDNOD,SDRT,SDFIELDS
+2 SET SDFOUND=0
+3 SET SDI=""
FOR
SET SDI=$ORDER(^SDEC(409.831,"ALOC",SDCL,SDI))
if SDI=""
QUIT
Begin DoDot:1
+4 SET SDNOD=$GET(^SDEC(409.831,SDI,0))
+5 SET SDRT=$PIECE(SDNOD,U,11)
+6 IF $PIECE(SDRT,";",2)="SC("
IF $PIECE(SDRT,";",1)=SDCL
SET SDFOUND=1
End DoDot:1
if SDFOUND=1
QUIT
+7 SET SDI=$SELECT(SDFOUND=1:SDI,1:"+1")
+8 ;alb/sat 658 - add field 1
SET SDFIELDS=".01;1;1917"
+9 DO GETS^DIQ(44,SDCL_",",SDFIELDS,"IE","SDDATA")
+10 SET SDFDA(409.831,SDI_",",.01)=SDDATA(44,SDCL_",",.01,"E")
+11 SET SDDI=SDDATA(44,SDCL_",",1917,"E")
SET SDFDA(409.831,SDI_",",.03)=$EXTRACT(SDDI,1,2)
+12 ;alb/sat 658 - add abbreviation
SET ABBR=SDDATA(44,SDCL_",",1,"E")
if ABBR'=""
SET SDFDA(409.831,SDI_",",.011)=ABBR
+13 SET SDFDA(409.831,SDI_",",.04)=SDCL
+14 SET SDFDA(409.831,SDI_",",.012)=SDCL_";SC("
+15 SET SDFDA(409.831,SDI_",",.015)=$EXTRACT($$NOW^XLFDT,1,12)
+16 SET SDFDA(409.831,SDI_",",.016)=DUZ
+17 DO UPDATE^DIE("","SDFDA")
+18 QUIT
