SDECU ;ALB/SAT - VISTA SCHEDULING RPCS ;JUN 21, 2017
;;5.3;Scheduling;**627,665,680**;Aug 13, 1993;Build 2
;
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
;
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:"")
;
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")
;
CONF() ;EP; -- returns confidential warning
Q "Confidential Patient Data Covered by Privacy Act"
;
GREETING(LETTER,PAT) ;EP; -- returns letter salutation
NEW LINE
S LINE="Dear "
;S LINE=LINE_$S($$SEX^SDECPAT(PAT)="M":"Mr. ",1:"Ms. ") ;SD*5.3*680 - Removed concatenation "Mr. "/"Ms. "
;
;S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1) ;add printable name
;S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1)_"," ;add printable name
Q LINE
;
PRV(SDCL) ;
Q
;
PAUSE N X
U IO(0) W !!,"Press RETURN to continue, '^' to exit:"
R X:$G(DTIME)
U IO
Q
;
CLEAR ;remove SDEC RESOURCE USER entries; command line utility for testing
N DA,DIK,SDI,SDJ,SDK
S SDI=0 F S SDI=$O(^SDEC(409.833,SDI)) Q:SDI'>0 D
.;W !,SDI
.S DIK="^SDEC(409.833,"
.S DA=SDI
.D ^DIK
Q
;S SDI=0 F S SDI=$O(^SDEC(409.833,SDI)) Q:SDI'>0 W !,SDI S DIK="^SDEC(409.833," S DA=SDI D ^DIK
;
DUPS ;find duplicate entries in SDEC APPOINTMENT
N DUP,H,NOD,NOD2,PAT,RES,TYP
; 1 2 3 4 5 6
;DUP("ENTERED",<entered d/t>,<date/time>,<patient ien_name>,<resource ien_name>,type)=CNT
;DUP("START", <entered d/t>,<date/time>,<patient ien_name>,<resource ien_name>,type)=CNT
S H=0 F S H=$O(^SDEC(409.84,H)) Q:H'>0 D
.S NOD=$G(^SDEC(409.84,H,0))
.S NOD2=$G(^SDEC(409.84,H,2))
.S PAT=$P(NOD,U,5)_" "_$$GET1^DIQ(2,$P(NOD,U,5)_",",.01)
.S RES=$P(NOD,U,7)_" "_$$GET1^DIQ(409.831,$P(NOD,U,7)_",",.01)
.S TYP=$$GET1^DIQ(409.84,H_",",.22) S TYP=$S(TYP="":0,1:TYP)
.S DUP("ENTERED",$P(NOD,U,9),$P(NOD,U,1),PAT,RES,TYP)=$G(DUP($P(NOD,U,1),PAT,RES,$P(NOD,U,9),TYP))+1
.S DUP("START",$P(NOD,U,1),PAT,RES,$P(NOD,U,9),TYP)=$G(DUP($P(NOD,U,1),PAT,RES,$P(NOD,U,9),TYP))+1
N S1,S2,S3,S4,S5
S S1="" F S S1=$O(DUP(S1)) Q:S1="" D
.S S2="" F S S2=$O(DUP(S1,S2)) Q:S2="" D
..S S3="" F S S3=$O(DUP(S1,S2,S3)) Q:S3="" D
...S S4="" F S S4=$O(DUP(S1,S2,S3,S4)) Q:S4="" D
....S S5="" F S S5=$O(DUP(S1,S2,S3,S4,S5)) Q:S5="" D
.....W !,$E(S1,1,12),?(14),$E(S2,1,15),?(31),$E(S3,1,15),?(48),$E(S4,1,12),?(62),S5," ",DUP(S1,S2,S3,S4,S5)
Q
;
GETSUB(TXT) ;
N LAST
S LAST=""
I +TXT,+TXT=TXT S LAST=TXT-1 ;alb/sat 665 - handle numeric
E D
.S LAST=$E(TXT,$L(TXT))
.S LAST=$C($A(LAST)-1)
.S LAST=$E(TXT,1,$L(TXT)-1)_LAST_"~"
Q LAST
;
FILL(PADS,CHAR) ;pad string
N I,RET
S CHAR=$G(CHAR)
S:CHAR="" CHAR=" "
S RET=""
F I=1:1:PADS S RET=RET_CHAR
Q RET
;
RPC(BUILD) ;list rpcs Same as fields used in 7.2 Interface Detailed Design
N DASH,RP,RPA,RPN,SDI,SDJ,SDK
Q:$G(BUILD)=""
S BUILD=$O(^XPD(9.6,"B",BUILD,0))
Q:BUILD=""
S $P(DASH,"-",75)="-"
S SDI=0 F S SDI=$O(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI)) Q:SDI'>0 D
.S RPN=$P($G(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI,0)),U,1)
.S RP(RPN)=$O(^XWB(8994,"B",RPN,0))
S RPN="" F S RPN=$O(RP(RPN)) Q:RPN="" D
.S RP=RP(RPN)
.W !!,DASH,!!
.;NAME
.W RPN
.;DESCRIPTION
.S SDJ=0 F S SDJ=$O(^XWB(8994,RP,1,SDJ)) Q:SDJ'>0 W !,^(SDJ,0)
.;INPUT
.W !!,"***INPUT:"
.I $O(^XWB(8994,RP,2,0))'>0 W !," NO INPUT"
.S SDJ=0 F S SDJ=$O(^XWB(8994,RP,2,SDJ)) Q:SDJ'>0 D
..W !," ",$P(^XWB(8994,RP,2,SDJ,0),U,1)
..S SDK=0 F S SDK=$O(^XWB(8994,RP,2,SDJ,1,SDK)) Q:SDK'>0 D
...W !,^XWB(8994,RP,2,SDJ,1,SDK,0)
.W !!,"***RETURN:"
.S SDJ=0 F S SDJ=$O(^XWB(8994,RP,3,SDJ)) Q:SDJ'>0 D
..W !,^XWB(8994,RP,3,SDJ,0)
Q
;
RPC2(BUILD) ;list rpcs - same fields as 6.2.2.3.11 Remote Procedure Call (RPC)
N DASH,DATA,RP,RPA,RPN,SDI,SDJ,SDK,X
Q:$G(BUILD)=""
S BUILD=$O(^XPD(9.6,"B",BUILD,0))
Q:BUILD=""
S $P(DASH,"-",75)="-"
S SDI=0 F S SDI=$O(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI)) Q:SDI'>0 D
.S RPN=$P($G(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI,0)),U,1)
.S RP(RPN)=$O(^XWB(8994,"B",RPN,0))
S RPN="" F S RPN=$O(RP(RPN)) Q:RPN="" D
.S RP=RP(RPN)
.K DATA
.D GETS^DIQ(8994,RP,"*","IE","DATA")
.S X="DATA(8994,"""_RP_","")"
.W !!,DASH,!!
.W "Name",?20,RPN
.W !,"TAG^RTN",?20,@X@(.02,"E")_"^"_@X@(.03,"E")
.W !!,"***Input Parameters"
.I $O(^XWB(8994,RP,2,0))'>0 W !," NO INPUT"
.S SDJ=0 F S SDJ=$O(^XWB(8994,RP,2,SDJ)) Q:SDJ'>0 D
..W !," ",$P(^XWB(8994,RP,2,SDJ,0),U,1)
..S SDK=0 F S SDK=$O(^XWB(8994,RP,2,SDJ,1,SDK)) Q:SDK'>0 D
...W !,^XWB(8994,RP,2,SDJ,1,SDK,0)
.W !!,"Return Value Type",?20,@X@(.04,"E")
.;DESCRIPTION
.W !!,"DESCRIPTION"
.S SDJ=0 F S SDJ=$O(^XWB(8994,RP,1,SDJ)) Q:SDJ'>0 W !,^(SDJ,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECU 5129 printed Apr 09, 2024@21:48:30 Page 2
SDECU ;ALB/SAT - VISTA SCHEDULING RPCS ;JUN 21, 2017
+1 ;;5.3;Scheduling;**627,665,680**;Aug 13, 1993;Build 2
+2 ;
+3 QUIT
+4 ;
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 ;
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 ;
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 ;
CONF() ;EP; -- returns confidential warning
+1 QUIT "Confidential Patient Data Covered by Privacy Act"
+2 ;
GREETING(LETTER,PAT) ;EP; -- returns letter salutation
+1 NEW LINE
+2 SET LINE="Dear "
+3 ;S LINE=LINE_$S($$SEX^SDECPAT(PAT)="M":"Mr. ",1:"Ms. ") ;SD*5.3*680 - Removed concatenation "Mr. "/"Ms. "
+4 ;
+5 ;S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1) ;add printable name
+6 ;S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1)_"," ;add printable name
+7 QUIT LINE
+8 ;
PRV(SDCL) ;
+1 QUIT
+2 ;
PAUSE NEW X
+1 USE IO(0)
WRITE !!,"Press RETURN to continue, '^' to exit:"
+2 READ X:$GET(DTIME)
+3 USE IO
+4 QUIT
+5 ;
CLEAR ;remove SDEC RESOURCE USER entries; command line utility for testing
+1 NEW DA,DIK,SDI,SDJ,SDK
+2 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.833,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+3 ;W !,SDI
+4 SET DIK="^SDEC(409.833,"
+5 SET DA=SDI
+6 DO ^DIK
End DoDot:1
+7 QUIT
+8 ;S SDI=0 F S SDI=$O(^SDEC(409.833,SDI)) Q:SDI'>0 W !,SDI S DIK="^SDEC(409.833," S DA=SDI D ^DIK
+9 ;
DUPS ;find duplicate entries in SDEC APPOINTMENT
+1 NEW DUP,H,NOD,NOD2,PAT,RES,TYP
+2 ; 1 2 3 4 5 6
+3 ;DUP("ENTERED",<entered d/t>,<date/time>,<patient ien_name>,<resource ien_name>,type)=CNT
+4 ;DUP("START", <entered d/t>,<date/time>,<patient ien_name>,<resource ien_name>,type)=CNT
+5 SET H=0
FOR
SET H=$ORDER(^SDEC(409.84,H))
if H'>0
QUIT
Begin DoDot:1
+6 SET NOD=$GET(^SDEC(409.84,H,0))
+7 SET NOD2=$GET(^SDEC(409.84,H,2))
+8 SET PAT=$PIECE(NOD,U,5)_" "_$$GET1^DIQ(2,$PIECE(NOD,U,5)_",",.01)
+9 SET RES=$PIECE(NOD,U,7)_" "_$$GET1^DIQ(409.831,$PIECE(NOD,U,7)_",",.01)
+10 SET TYP=$$GET1^DIQ(409.84,H_",",.22)
SET TYP=$SELECT(TYP="":0,1:TYP)
+11 SET DUP("ENTERED",$PIECE(NOD,U,9),$PIECE(NOD,U,1),PAT,RES,TYP)=$GET(DUP($PIECE(NOD,U,1),PAT,RES,$PIECE(NOD,U,9),TYP))+1
+12 SET DUP("START",$PIECE(NOD,U,1),PAT,RES,$PIECE(NOD,U,9),TYP)=$GET(DUP($PIECE(NOD,U,1),PAT,RES,$PIECE(NOD,U,9),TYP))+1
End DoDot:1
+13 NEW S1,S2,S3,S4,S5
+14 SET S1=""
FOR
SET S1=$ORDER(DUP(S1))
if S1=""
QUIT
Begin DoDot:1
+15 SET S2=""
FOR
SET S2=$ORDER(DUP(S1,S2))
if S2=""
QUIT
Begin DoDot:2
+16 SET S3=""
FOR
SET S3=$ORDER(DUP(S1,S2,S3))
if S3=""
QUIT
Begin DoDot:3
+17 SET S4=""
FOR
SET S4=$ORDER(DUP(S1,S2,S3,S4))
if S4=""
QUIT
Begin DoDot:4
+18 SET S5=""
FOR
SET S5=$ORDER(DUP(S1,S2,S3,S4,S5))
if S5=""
QUIT
Begin DoDot:5
+19 WRITE !,$EXTRACT(S1,1,12),?(14),$EXTRACT(S2,1,15),?(31),$EXTRACT(S3,1,15),?(48),$EXTRACT(S4,1,12),?(62),S5," ",DUP(S1,S2,S3,S4,S5)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
GETSUB(TXT) ;
+1 NEW LAST
+2 SET LAST=""
+3 ;alb/sat 665 - handle numeric
IF +TXT
IF +TXT=TXT
SET LAST=TXT-1
+4 IF '$TEST
Begin DoDot:1
+5 SET LAST=$EXTRACT(TXT,$LENGTH(TXT))
+6 SET LAST=$CHAR($ASCII(LAST)-1)
+7 SET LAST=$EXTRACT(TXT,1,$LENGTH(TXT)-1)_LAST_"~"
End DoDot:1
+8 QUIT LAST
+9 ;
FILL(PADS,CHAR) ;pad string
+1 NEW I,RET
+2 SET CHAR=$GET(CHAR)
+3 if CHAR=""
SET CHAR=" "
+4 SET RET=""
+5 FOR I=1:1:PADS
SET RET=RET_CHAR
+6 QUIT RET
+7 ;
RPC(BUILD) ;list rpcs Same as fields used in 7.2 Interface Detailed Design
+1 NEW DASH,RP,RPA,RPN,SDI,SDJ,SDK
+2 if $GET(BUILD)=""
QUIT
+3 SET BUILD=$ORDER(^XPD(9.6,"B",BUILD,0))
+4 if BUILD=""
QUIT
+5 SET $PIECE(DASH,"-",75)="-"
+6 SET SDI=0
FOR
SET SDI=$ORDER(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI))
if SDI'>0
QUIT
Begin DoDot:1
+7 SET RPN=$PIECE($GET(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI,0)),U,1)
+8 SET RP(RPN)=$ORDER(^XWB(8994,"B",RPN,0))
End DoDot:1
+9 SET RPN=""
FOR
SET RPN=$ORDER(RP(RPN))
if RPN=""
QUIT
Begin DoDot:1
+10 SET RP=RP(RPN)
+11 WRITE !!,DASH,!!
+12 ;NAME
+13 WRITE RPN
+14 ;DESCRIPTION
+15 SET SDJ=0
FOR
SET SDJ=$ORDER(^XWB(8994,RP,1,SDJ))
if SDJ'>0
QUIT
WRITE !,^(SDJ,0)
+16 ;INPUT
+17 WRITE !!,"***INPUT:"
+18 IF $ORDER(^XWB(8994,RP,2,0))'>0
WRITE !," NO INPUT"
+19 SET SDJ=0
FOR
SET SDJ=$ORDER(^XWB(8994,RP,2,SDJ))
if SDJ'>0
QUIT
Begin DoDot:2
+20 WRITE !," ",$PIECE(^XWB(8994,RP,2,SDJ,0),U,1)
+21 SET SDK=0
FOR
SET SDK=$ORDER(^XWB(8994,RP,2,SDJ,1,SDK))
if SDK'>0
QUIT
Begin DoDot:3
+22 WRITE !,^XWB(8994,RP,2,SDJ,1,SDK,0)
End DoDot:3
End DoDot:2
+23 WRITE !!,"***RETURN:"
+24 SET SDJ=0
FOR
SET SDJ=$ORDER(^XWB(8994,RP,3,SDJ))
if SDJ'>0
QUIT
Begin DoDot:2
+25 WRITE !,^XWB(8994,RP,3,SDJ,0)
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
RPC2(BUILD) ;list rpcs - same fields as 6.2.2.3.11 Remote Procedure Call (RPC)
+1 NEW DASH,DATA,RP,RPA,RPN,SDI,SDJ,SDK,X
+2 if $GET(BUILD)=""
QUIT
+3 SET BUILD=$ORDER(^XPD(9.6,"B",BUILD,0))
+4 if BUILD=""
QUIT
+5 SET $PIECE(DASH,"-",75)="-"
+6 SET SDI=0
FOR
SET SDI=$ORDER(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI))
if SDI'>0
QUIT
Begin DoDot:1
+7 SET RPN=$PIECE($GET(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI,0)),U,1)
+8 SET RP(RPN)=$ORDER(^XWB(8994,"B",RPN,0))
End DoDot:1
+9 SET RPN=""
FOR
SET RPN=$ORDER(RP(RPN))
if RPN=""
QUIT
Begin DoDot:1
+10 SET RP=RP(RPN)
+11 KILL DATA
+12 DO GETS^DIQ(8994,RP,"*","IE","DATA")
+13 SET X="DATA(8994,"""_RP_","")"
+14 WRITE !!,DASH,!!
+15 WRITE "Name",?20,RPN
+16 WRITE !,"TAG^RTN",?20,@X@(.02,"E")_"^"_@X@(.03,"E")
+17 WRITE !!,"***Input Parameters"
+18 IF $ORDER(^XWB(8994,RP,2,0))'>0
WRITE !," NO INPUT"
+19 SET SDJ=0
FOR
SET SDJ=$ORDER(^XWB(8994,RP,2,SDJ))
if SDJ'>0
QUIT
Begin DoDot:2
+20 WRITE !," ",$PIECE(^XWB(8994,RP,2,SDJ,0),U,1)
+21 SET SDK=0
FOR
SET SDK=$ORDER(^XWB(8994,RP,2,SDJ,1,SDK))
if SDK'>0
QUIT
Begin DoDot:3
+22 WRITE !,^XWB(8994,RP,2,SDJ,1,SDK,0)
End DoDot:3
End DoDot:2
+23 WRITE !!,"Return Value Type",?20,@X@(.04,"E")
+24 ;DESCRIPTION
+25 WRITE !!,"DESCRIPTION"
+26 SET SDJ=0
FOR
SET SDJ=$ORDER(^XWB(8994,RP,1,SDJ))
if SDJ'>0
QUIT
WRITE !,^(SDJ,0)
End DoDot:1
+27 QUIT
