SCMCTMU ;ALB/REW - Team-Patient Utilities ; 1 May 95
;;5.3;Scheduling;**41**;AUG 13, 1993
;1
ACTTM(SCTM,SCDT) ;is the team currently active?
; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.51
; Input:
; SCTM - Pointer to Team file #404.51
; SCDT - Date to check for, Default=DT
; Returns:
; 1 if after effective date and before inactive date
; 0 if not yet active or inactivated
; -1 if error
;
Q $$DATES^SCAPMCU1(404.58,.SCTM,.SCDT)
;
ENROLL(DFN,CLINIC,DATE) ;is this patient enrolled in this clinic on a date?
;Input:
; DFN - ien of Patient file
; CLINIC - Pointer to file 44
; DATE - (Optional) Effective Date, default=DT
;Return: [1|Yes, he is enrolled;0|he is not]
;
N SCCL,SCL1,SCNODE,SCACT,SCINACT,SCYES
S SCYES=0
S SCCL=0
F S SCCL=$O(^DPT(DFN,"DE","B",CLINIC,SCCL)) Q:'SCCL D
.S SCCL1=0
.F S SCCL1=$O(^DPT(DFN,"DE",SCCL,1,SCCL1)) Q:'SCCL1 D
..S SCNODE=$G(^DPT(DFN,"DE",SCCL,1,SCCL1,0))
..S SCACT=+SCNODE
..S SCINACT=$P(SCNODE,U,3)
..S:$S('SCACT:0,(SCACT>DATE):0,'SCINACT:1,(SCINACT<DATE):0,1:1) SCYES=1
Q SCYES
;
RESTCONS(DFN) ;does this patient have restricted consults?
; for a clinic in which the patient is NOT enrolled, some patients/teams
; require more authority to enroll or make appointments
; this will often be used with $$ENROLL(dfn) to see if he is enrolled
;
; Input: DFN - ien of Patient File
; Return: [1|Yes, restrict 0|No
Q 1
WHOCLIN(SDCL,DATE) ;give clinic & date return prt to 200
; SDCL - ien of #44
; DATE - effective date (optional) default =DT
; Returned: ien of 200
;
Q
POSCLIN(SDCL,DATE) ;given clinic & date, return ptr to team position 404.57
; SDCL - ien of Hospital Location (#44)
; Returned: If exactly one position for clinic - ien of team postion
; else null
;
N X,SCD
S:'$G(DATE) DATE=DT
S SCD=$O(^SCTM(404.57,"ACLINDT",+SDCL,-DATE)) ;SCD is the effective date
S X=$O(^SCTM(404.57,"ACLINDT",+SDCL,+SCD,"")) ;position assoc w/ clinic
Q $G(X)
WHOPOS(SCTP,DATE) ;given position & date,return pointer to 200^name of pr
;SCTP - ien of Team Position File (#404.57)
; Date - (Optional) effective date - default=today
;
Q $$GETPRTP^SCAPMCU2(SCTP,.DATE)
DISPWHO(SCPOS,DATE) ;given position & date, return external of 200
;SCPOS - ien of 404.48)
; DATE - (Optional) effective date - default=today
;
N Y,SCP
S:'$G(DATE) DATE=DT
S SCP=$$WHOPOS(SCPOS,DATE)
S:SCP Y=$S($D(^VA(200,+SCP,0)):$P(^(0),U,1),1:"Unknown")
Q $G(Y)
PR(SDNPI) ;Provider Display Data
; Input -- SDNPI New Person IEN
; Output -- Provider Display Data - Provider Name
N Y
S Y=$S($D(^VA(200,SDNPI,0)):$P(^(0),"^"),1:"Unknown")
Q $G(Y)
PTTMSCRN ;define dic('s') to ensure patient team position assignement is ok
;
CK N SCTM,SCTMA
S SCTMA=$P($G(^SCPT(404.43,Y,0)),U,1)
S SCTM=$P($G(^SCPT(404.42,SCTMA,0)),U,3)
S DIC("S")="IF $D(^SCTM(404.57,""C"","_SCTM_",Y))"
Q
OKPTTM(SCNODE,DA) ;check pt team assignment - 404.42
; SCNODE is proposed new node
Q 1
N OK,DFN,SCTM,SCACT,SCINACT,SCDTS,SCTMHIST,SCB4,SCAFT
S OK=1
G:'DA QTOKTM
S DFN=$P(SCNODE,U,1)
S SCTM=$P(SCNODE,U,3)
S SCACT=$P(SCNODE,U,2)
S SCINACT=$P(SCNODE,U,9)
S:$G(SCACT) SCDTS("BEGIN")=SCACT
S:$D(SCACT) SCDTS("END")=$S(SCINACT:SCINACT,1:3990101)
S:$D(SCDTS) SCDTS("INCL")=1
;check patient (.01) - none now
;check team (.03)
IF SCINACT&('SCACT) S OK=0_U_"Activation must be defined before Discharge" G QTOKTM
IF SCTM&SCACT&DFN D
.S SCTMHIST=$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCDTS)
.S:'SCTMHIST OK=0_U_"Team Not Active"
.;check assignment dt (.02)
.; - is there an assignment on exactly the same date in 404.42?
.S SCPTTMA=0 F S SCPTTMA=$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,SCPTTMA)) Q:SCPTTMA=""!(SCPTTMA=DA)!(DA="") S OK=0_U_"Already an activation for patient/team on this date"
.; - is there an assignment w/o a discharge before in 404.42?
.S SCB4=$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT))
.S SCB4A=$O(^SCPT(404.42,"AIDT",DFN,SCTM,+SCB4,0))
.S:SCB4A&('$P($G(^SCPT(404.42,+SCB4A,0)),U,9)) OK=0_U_"Existing active patient/team assignment already"
.;check inactivation dt (.09)
.; - if exists, is inactivation after assignment dt
.S:SCINACT&(SCACT'<SCINACT) OK=0_U_"Activation must be before discharge"
.; - if there is a future assignment is it after this inactivation?
.S SCAFT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCINACT),-1)
.S:SCAFT&(SCAFT'>SCINACT) OK=0_U_"Existing future activation before this inactivation"
QTOKTM Q OK
;
INSTPCTM(DFN,SCEFF) ;return institution & team for pt's pc team
; return ptr4^institution^sctm^team name
N SCTM,SCINST,SCOK
S SCOK=0
S SCTM=+$$GETPCTM^SCAPMCU2(.DFN,.SCEFF,1)
S SCINST=+$P($G(^SCTM(404.51,+$G(SCTM),0)),U,7)
S:SCTM&SCINST SCOK=1
Q $S('SCOK:0,1:SCTM_U_$P($G(^SCTM(404.51,SCTM,0)),U,1)_U_SCINST_U_$P($G(^DIC(4,SCINST,0)),U,1))
;
EVT(SCCVEVT,SCCVORG) ;Invoke encounter conversion event driver
; Input -- SCCVEVT Conversion event
; 0=Estimate, 1=Convert, 2=Re-convert
; SCCVORG Originating process type
; Output -- ^TMP("SCCVEVT",$J, disposition array
K DTOUT,DIROUT
S X=+$O(^ORD(101,"B","SCMC ENCOUNTER CONVERSION EVENTS",0))_";ORD(101,"
I X D EN^XQOR
K X,^TMP("SCCVEVT",$J)
EVTQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTMU 5325 printed Apr 09, 2024@21:48:09 Page 2
SCMCTMU ;ALB/REW - Team-Patient Utilities ; 1 May 95
+1 ;;5.3;Scheduling;**41**;AUG 13, 1993
+2 ;1
ACTTM(SCTM,SCDT) ;is the team currently active?
+1 ; Used by computed field #300 (CURRENTLY ACTIVE?) OF file #404.51
+2 ; Input:
+3 ; SCTM - Pointer to Team file #404.51
+4 ; SCDT - Date to check for, Default=DT
+5 ; Returns:
+6 ; 1 if after effective date and before inactive date
+7 ; 0 if not yet active or inactivated
+8 ; -1 if error
+9 ;
+10 QUIT $$DATES^SCAPMCU1(404.58,.SCTM,.SCDT)
+11 ;
ENROLL(DFN,CLINIC,DATE) ;is this patient enrolled in this clinic on a date?
+1 ;Input:
+2 ; DFN - ien of Patient file
+3 ; CLINIC - Pointer to file 44
+4 ; DATE - (Optional) Effective Date, default=DT
+5 ;Return: [1|Yes, he is enrolled;0|he is not]
+6 ;
+7 NEW SCCL,SCL1,SCNODE,SCACT,SCINACT,SCYES
+8 SET SCYES=0
+9 SET SCCL=0
+10 FOR
SET SCCL=$ORDER(^DPT(DFN,"DE","B",CLINIC,SCCL))
if 'SCCL
QUIT
Begin DoDot:1
+11 SET SCCL1=0
+12 FOR
SET SCCL1=$ORDER(^DPT(DFN,"DE",SCCL,1,SCCL1))
if 'SCCL1
QUIT
Begin DoDot:2
+13 SET SCNODE=$GET(^DPT(DFN,"DE",SCCL,1,SCCL1,0))
+14 SET SCACT=+SCNODE
+15 SET SCINACT=$PIECE(SCNODE,U,3)
+16 if $SELECT('SCACT
SET SCYES=1
End DoDot:2
End DoDot:1
+17 QUIT SCYES
+18 ;
RESTCONS(DFN) ;does this patient have restricted consults?
+1 ; for a clinic in which the patient is NOT enrolled, some patients/teams
+2 ; require more authority to enroll or make appointments
+3 ; this will often be used with $$ENROLL(dfn) to see if he is enrolled
+4 ;
+5 ; Input: DFN - ien of Patient File
+6 ; Return: [1|Yes, restrict 0|No
+7 QUIT 1
WHOCLIN(SDCL,DATE) ;give clinic & date return prt to 200
+1 ; SDCL - ien of #44
+2 ; DATE - effective date (optional) default =DT
+3 ; Returned: ien of 200
+4 ;
+5 QUIT
POSCLIN(SDCL,DATE) ;given clinic & date, return ptr to team position 404.57
+1 ; SDCL - ien of Hospital Location (#44)
+2 ; Returned: If exactly one position for clinic - ien of team postion
+3 ; else null
+4 ;
+5 NEW X,SCD
+6 if '$GET(DATE)
SET DATE=DT
+7 ;SCD is the effective date
SET SCD=$ORDER(^SCTM(404.57,"ACLINDT",+SDCL,-DATE))
+8 ;position assoc w/ clinic
SET X=$ORDER(^SCTM(404.57,"ACLINDT",+SDCL,+SCD,""))
+9 QUIT $GET(X)
WHOPOS(SCTP,DATE) ;given position & date,return pointer to 200^name of pr
+1 ;SCTP - ien of Team Position File (#404.57)
+2 ; Date - (Optional) effective date - default=today
+3 ;
+4 QUIT $$GETPRTP^SCAPMCU2(SCTP,.DATE)
DISPWHO(SCPOS,DATE) ;given position & date, return external of 200
+1 ;SCPOS - ien of 404.48)
+2 ; DATE - (Optional) effective date - default=today
+3 ;
+4 NEW Y,SCP
+5 if '$GET(DATE)
SET DATE=DT
+6 SET SCP=$$WHOPOS(SCPOS,DATE)
+7 if SCP
SET Y=$SELECT($DATA(^VA(200,+SCP,0)):$PIECE(^(0),U,1),1:"Unknown")
+8 QUIT $GET(Y)
PR(SDNPI) ;Provider Display Data
+1 ; Input -- SDNPI New Person IEN
+2 ; Output -- Provider Display Data - Provider Name
+3 NEW Y
+4 SET Y=$SELECT($DATA(^VA(200,SDNPI,0)):$PIECE(^(0),"^"),1:"Unknown")
+5 QUIT $GET(Y)
PTTMSCRN ;define dic('s') to ensure patient team position assignement is ok
+1 ;
CK NEW SCTM,SCTMA
+1 SET SCTMA=$PIECE($GET(^SCPT(404.43,Y,0)),U,1)
+2 SET SCTM=$PIECE($GET(^SCPT(404.42,SCTMA,0)),U,3)
+3 SET DIC("S")="IF $D(^SCTM(404.57,""C"","_SCTM_",Y))"
+4 QUIT
OKPTTM(SCNODE,DA) ;check pt team assignment - 404.42
+1 ; SCNODE is proposed new node
+2 QUIT 1
+3 NEW OK,DFN,SCTM,SCACT,SCINACT,SCDTS,SCTMHIST,SCB4,SCAFT
+4 SET OK=1
+5 if 'DA
GOTO QTOKTM
+6 SET DFN=$PIECE(SCNODE,U,1)
+7 SET SCTM=$PIECE(SCNODE,U,3)
+8 SET SCACT=$PIECE(SCNODE,U,2)
+9 SET SCINACT=$PIECE(SCNODE,U,9)
+10 if $GET(SCACT)
SET SCDTS("BEGIN")=SCACT
+11 if $DATA(SCACT)
SET SCDTS("END")=$SELECT(SCINACT:SCINACT,1:3990101)
+12 if $DATA(SCDTS)
SET SCDTS("INCL")=1
+13 ;check patient (.01) - none now
+14 ;check team (.03)
+15 IF SCINACT&('SCACT)
SET OK=0_U_"Activation must be defined before Discharge"
GOTO QTOKTM
+16 IF SCTM&SCACT&DFN
Begin DoDot:1
+17 SET SCTMHIST=$$ACTHIST^SCAPMCU2(404.58,.SCTM,.SCDTS)
+18 if 'SCTMHIST
SET OK=0_U_"Team Not Active"
+19 ;check assignment dt (.02)
+20 ; - is there an assignment on exactly the same date in 404.42?
+21 SET SCPTTMA=0
FOR
SET SCPTTMA=$ORDER(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,SCPTTMA))
if SCPTTMA=""!(SCPTTMA=DA)!(DA="")
QUIT
SET OK=0_U_"Already an activation for patient/team on this date"
+22 ; - is there an assignment w/o a discharge before in 404.42?
+23 SET SCB4=$ORDER(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT))
+24 SET SCB4A=$ORDER(^SCPT(404.42,"AIDT",DFN,SCTM,+SCB4,0))
+25 if SCB4A&('$PIECE($GET(^SCPT(404.42,+SCB4A,0)),U,9))
SET OK=0_U_"Existing active patient/team assignment already"
+26 ;check inactivation dt (.09)
+27 ; - if exists, is inactivation after assignment dt
+28 if SCINACT&(SCACT'<SCINACT)
SET OK=0_U_"Activation must be before discharge"
+29 ; - if there is a future assignment is it after this inactivation?
+30 SET SCAFT=-$ORDER(^SCPT(404.42,"AIDT",DFN,SCTM,-SCINACT),-1)
+31 if SCAFT&(SCAFT'>SCINACT)
SET OK=0_U_"Existing future activation before this inactivation"
End DoDot:1
QTOKTM QUIT OK
+1 ;
INSTPCTM(DFN,SCEFF) ;return institution & team for pt's pc team
+1 ; return ptr4^institution^sctm^team name
+2 NEW SCTM,SCINST,SCOK
+3 SET SCOK=0
+4 SET SCTM=+$$GETPCTM^SCAPMCU2(.DFN,.SCEFF,1)
+5 SET SCINST=+$PIECE($GET(^SCTM(404.51,+$GET(SCTM),0)),U,7)
+6 if SCTM&SCINST
SET SCOK=1
+7 QUIT $SELECT('SCOK:0,1:SCTM_U_$PIECE($GET(^SCTM(404.51,SCTM,0)),U,1)_U_SCINST_U_$PIECE($GET(^DIC(4,SCINST,0)),U,1))
+8 ;
EVT(SCCVEVT,SCCVORG) ;Invoke encounter conversion event driver
+1 ; Input -- SCCVEVT Conversion event
+2 ; 0=Estimate, 1=Convert, 2=Re-convert
+3 ; SCCVORG Originating process type
+4 ; Output -- ^TMP("SCCVEVT",$J, disposition array
+5 KILL DTOUT,DIROUT
+6 SET X=+$ORDER(^ORD(101,"B","SCMC ENCOUNTER CONVERSION EVENTS",0))_";ORD(101,"
+7 IF X
DO EN^XQOR
+8 KILL X,^TMP("SCCVEVT",$JOB)
EVTQ QUIT
