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

SDECU.m

Go to the documentation of this file.
  1. SDECU ;ALB/SAT - VISTA SCHEDULING RPCS ;JUN 21, 2017
  1. ;;5.3;Scheduling;**627,665,680**;Aug 13, 1993;Build 2
  1. ;
  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. 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. 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. CONF() ;EP; -- returns confidential warning
  1. Q "Confidential Patient Data Covered by Privacy Act"
  1. ;
  1. GREETING(LETTER,PAT) ;EP; -- returns letter salutation
  1. NEW LINE
  1. S LINE="Dear "
  1. ;S LINE=LINE_$S($$SEX^SDECPAT(PAT)="M":"Mr. ",1:"Ms. ") ;SD*5.3*680 - Removed concatenation "Mr. "/"Ms. "
  1. ;
  1. ;S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1) ;add printable name
  1. ;S LINE=LINE_$$NAMEPRT^BDGF2(PAT,1)_"," ;add printable name
  1. Q LINE
  1. ;
  1. PRV(SDCL) ;
  1. Q
  1. ;
  1. PAUSE N X
  1. U IO(0) W !!,"Press RETURN to continue, '^' to exit:"
  1. R X:$G(DTIME)
  1. U IO
  1. Q
  1. ;
  1. CLEAR ;remove SDEC RESOURCE USER entries; command line utility for testing
  1. N DA,DIK,SDI,SDJ,SDK
  1. S SDI=0 F S SDI=$O(^SDEC(409.833,SDI)) Q:SDI'>0 D
  1. .;W !,SDI
  1. .S DIK="^SDEC(409.833,"
  1. .S DA=SDI
  1. .D ^DIK
  1. Q
  1. ;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
  1. ;
  1. DUPS ;find duplicate entries in SDEC APPOINTMENT
  1. N DUP,H,NOD,NOD2,PAT,RES,TYP
  1. ; 1 2 3 4 5 6
  1. ;DUP("ENTERED",<entered d/t>,<date/time>,<patient ien_name>,<resource ien_name>,type)=CNT
  1. ;DUP("START", <entered d/t>,<date/time>,<patient ien_name>,<resource ien_name>,type)=CNT
  1. S H=0 F S H=$O(^SDEC(409.84,H)) Q:H'>0 D
  1. .S NOD=$G(^SDEC(409.84,H,0))
  1. .S NOD2=$G(^SDEC(409.84,H,2))
  1. .S PAT=$P(NOD,U,5)_" "_$$GET1^DIQ(2,$P(NOD,U,5)_",",.01)
  1. .S RES=$P(NOD,U,7)_" "_$$GET1^DIQ(409.831,$P(NOD,U,7)_",",.01)
  1. .S TYP=$$GET1^DIQ(409.84,H_",",.22) S TYP=$S(TYP="":0,1:TYP)
  1. .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
  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
  1. N S1,S2,S3,S4,S5
  1. S S1="" F S S1=$O(DUP(S1)) Q:S1="" D
  1. .S S2="" F S S2=$O(DUP(S1,S2)) Q:S2="" D
  1. ..S S3="" F S S3=$O(DUP(S1,S2,S3)) Q:S3="" D
  1. ...S S4="" F S S4=$O(DUP(S1,S2,S3,S4)) Q:S4="" D
  1. ....S S5="" F S S5=$O(DUP(S1,S2,S3,S4,S5)) Q:S5="" D
  1. .....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)
  1. Q
  1. ;
  1. GETSUB(TXT) ;
  1. N LAST
  1. S LAST=""
  1. I +TXT,+TXT=TXT S LAST=TXT-1 ;alb/sat 665 - handle numeric
  1. E D
  1. .S LAST=$E(TXT,$L(TXT))
  1. .S LAST=$C($A(LAST)-1)
  1. .S LAST=$E(TXT,1,$L(TXT)-1)_LAST_"~"
  1. Q LAST
  1. ;
  1. FILL(PADS,CHAR) ;pad string
  1. N I,RET
  1. S CHAR=$G(CHAR)
  1. S:CHAR="" CHAR=" "
  1. S RET=""
  1. F I=1:1:PADS S RET=RET_CHAR
  1. Q RET
  1. ;
  1. RPC(BUILD) ;list rpcs Same as fields used in 7.2 Interface Detailed Design
  1. N DASH,RP,RPA,RPN,SDI,SDJ,SDK
  1. Q:$G(BUILD)=""
  1. S BUILD=$O(^XPD(9.6,"B",BUILD,0))
  1. Q:BUILD=""
  1. S $P(DASH,"-",75)="-"
  1. S SDI=0 F S SDI=$O(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI)) Q:SDI'>0 D
  1. .S RPN=$P($G(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI,0)),U,1)
  1. .S RP(RPN)=$O(^XWB(8994,"B",RPN,0))
  1. S RPN="" F S RPN=$O(RP(RPN)) Q:RPN="" D
  1. .S RP=RP(RPN)
  1. .W !!,DASH,!!
  1. .;NAME
  1. .W RPN
  1. .;DESCRIPTION
  1. .S SDJ=0 F S SDJ=$O(^XWB(8994,RP,1,SDJ)) Q:SDJ'>0 W !,^(SDJ,0)
  1. .;INPUT
  1. .W !!,"***INPUT:"
  1. .I $O(^XWB(8994,RP,2,0))'>0 W !," NO INPUT"
  1. .S SDJ=0 F S SDJ=$O(^XWB(8994,RP,2,SDJ)) Q:SDJ'>0 D
  1. ..W !," ",$P(^XWB(8994,RP,2,SDJ,0),U,1)
  1. ..S SDK=0 F S SDK=$O(^XWB(8994,RP,2,SDJ,1,SDK)) Q:SDK'>0 D
  1. ...W !,^XWB(8994,RP,2,SDJ,1,SDK,0)
  1. .W !!,"***RETURN:"
  1. .S SDJ=0 F S SDJ=$O(^XWB(8994,RP,3,SDJ)) Q:SDJ'>0 D
  1. ..W !,^XWB(8994,RP,3,SDJ,0)
  1. Q
  1. ;
  1. RPC2(BUILD) ;list rpcs - same fields as 6.2.2.3.11 Remote Procedure Call (RPC)
  1. N DASH,DATA,RP,RPA,RPN,SDI,SDJ,SDK,X
  1. Q:$G(BUILD)=""
  1. S BUILD=$O(^XPD(9.6,"B",BUILD,0))
  1. Q:BUILD=""
  1. S $P(DASH,"-",75)="-"
  1. S SDI=0 F S SDI=$O(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI)) Q:SDI'>0 D
  1. .S RPN=$P($G(^XPD(9.6,BUILD,"KRN",8994,"NM",SDI,0)),U,1)
  1. .S RP(RPN)=$O(^XWB(8994,"B",RPN,0))
  1. S RPN="" F S RPN=$O(RP(RPN)) Q:RPN="" D
  1. .S RP=RP(RPN)
  1. .K DATA
  1. .D GETS^DIQ(8994,RP,"*","IE","DATA")
  1. .S X="DATA(8994,"""_RP_","")"
  1. .W !!,DASH,!!
  1. .W "Name",?20,RPN
  1. .W !,"TAG^RTN",?20,@X@(.02,"E")_"^"_@X@(.03,"E")
  1. .W !!,"***Input Parameters"
  1. .I $O(^XWB(8994,RP,2,0))'>0 W !," NO INPUT"
  1. .S SDJ=0 F S SDJ=$O(^XWB(8994,RP,2,SDJ)) Q:SDJ'>0 D
  1. ..W !," ",$P(^XWB(8994,RP,2,SDJ,0),U,1)
  1. ..S SDK=0 F S SDK=$O(^XWB(8994,RP,2,SDJ,1,SDK)) Q:SDK'>0 D
  1. ...W !,^XWB(8994,RP,2,SDJ,1,SDK,0)
  1. .W !!,"Return Value Type",?20,@X@(.04,"E")
  1. .;DESCRIPTION
  1. .W !!,"DESCRIPTION"
  1. .S SDJ=0 F S SDJ=$O(^XWB(8994,RP,1,SDJ)) Q:SDJ'>0 W !,^(SDJ,0)
  1. Q