- 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 Jan 18, 2025@03:53:54 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