SCUTBK11 ;ALB/SCK - Scheduling Broker Utilities; 2/2/96 ;9/7/96 17:28
;;5.3;Scheduling;**41,54,86,148,177,205,209,255,297,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/30/2000 added call to IHS style patient lookup
;
Q
PARSE(SC) ;
S SCDFN=$G(SC("DFN"),"")
S SCPIEN=$G(SC("PIEN"),"")
S:$D(SC("TEAM")) SCTM=$G(SC("TEAM"))
S:$D(SC("BEGIN")) SCDT("BEGIN")=$G(SC("BEGIN"))
S:$D(SC("END")) SCDT("END")=$G(SC("END"))
I $D(SC("END")) S SCDT("INCL")=0
S SCFILE=$G(SC("FILE"))
S SCIEN=$G(SC("IEN"))
S SCFIELD=$G(SC("FIELD"))
S SCVAL=$G(SC("VALUE"))
Q
;
TMLST(SCDATA,SC) ;
; -- Return a list of teams for a patient. Pass in the DFN and
; optionally a date range and/or a team purpose to restrict the
; team look up. Return only the team entry, strip out any other
; array items.
;
N DFN,SCDT,SCPURP,SCLIST,SCER1,SCOK,SCD
;
D CHK^SCUTBK
D TMP^SCUTBK
;
S DFN=$G(SC("DFN"))
S SCDT("BEGIN")=$G(SC("BEGIN"),"")
I $L(SCDT("BEGIN"))>2 S SCDT("INCL")=$G(SC("INCL"),0)
S SCDT("END")=$G(SC("END"),"")
S SCPURP=$G(SC("PURP"),"")
;
S SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")
;
S I=0 F S I=$O(SCD(I)) Q:'I S SCDATA(I)=SCD(I)
TMQ Q
;
FINDP(SCOUT,SCIN) ; patient lookup used by SC PATIENT LOOKUP rpc
; input:
; SCIN("VALUE") = value to lookup
; Lookup uses multiple index lookup of File #2
; output:
; SCOUT = location of data = ^TMP("DILIST",$J,i,0)
; for i=1:number of records returned:
; DFN^patient name^DOB^PID^DOD
; 1 2 3 4 5
;
;bp/cmf 205 original code next line
;D FIND^DIC(2,,".01;.03;.363;.09","MPS",SCIN("VALUE"),500)
;bp/cmf 205 change code next line
;oifo/swo 297 added .351 for DOD warning new functionality
D PTLOOKUP^BSDSCRPC(SCIN("VALUE"),300) ;IHS/ANMC/LJF 11/30/2000
I $D(^TMP("DILIST",$J)) K SCOUT S SCOUT="^TMP(""DILIST"","_$J_")" ;IHS/ANMC/LJF 11/30/2000
Q ;IHS/ANMC/LJF 11/30/2000
;
D FIND^DIC(2,,".01;.03;.363;.09;.351","PS",SCIN("VALUE"),300,"B^BS^BS5^SSN")
I $G(DIERR) D CLEAN^DILF Q
N SCOUNT S SCOUNT=+^TMP("DILIST",$J,0)
N SC F SC=1:1:SCOUNT D
. N NODE,SSN,DSSN,PLID
. S NODE=^TMP("DILIST",$J,SC,0)
. ;Apply DOB screen
. S $P(NODE,U,3)=$$DOB^DPTLK1(+NODE)
. ;Apply SSN screen
. S SSN=$$SSN^DPTLK1(+NODE)
. S DSSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,11)
. S PLID=$P(NODE,U,4)
. I $E(SSN,1,9)'?9N S (DSSN,PLID)=SSN
. S $P(NODE,U,4)=$S($L(PLID)>5:PLID,1:DSSN)
. ;Move screened data back into output global
. ;oifo/swo 297 piece 6 is DOD field. Added for DOD warning
. S ^TMP("DILIST",$J,SC,0)=$P(NODE,U,1,4)_U_$P(NODE,U,6)
K ^TMP("DILIST",$J,0)
K SCOUT S SCOUT="^TMP(""DILIST"","_$J_")"
Q
PSLST(SCDATA,SC) ;
;
; - Returns a array of positions that show the person currently
; assigned to the position, the preceptor for that position,
; for the patient is assigned to.
;
; Pass in the Patient's DFN
; To restrict to specific entries, pass in the following:
; Beginning and Ending Date Range
; A specific Team Position
; A Specific User entry (8930)
; A specific Team Purpose. (Read SCAPMC23 for how it exclude
; a specific team purpose.
; A specific role
; Flag whether to include patients associated by enrollement
;
N SCDT,SCD,SCER1,SCDFN,SCPRP,SCPST,SCRLE,SCIND,SCUSR,SCTM,SCDTE
;
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE(.SC)
S SCDTE=$G(SCDT("BEGIN"))
;
S CNT=0
K ^TMP($J,"PSLST")
S SCOK=$$TPPT^SCAPMC(SCDFN,.SCDT,"","","","","","SCD","SCER1")
S I=0 F S I=$O(SCD(I)) Q:'I D
. I $D(SCTM) D
.. Q:$P(SCD(I),U,3)'=SCTM
.. S ^TMP($J,"PSLST",I)=$P($G(SCD(I)),U,3)_U_$P($G(SCD(I)),U,4)_U_$P($G(SCD(I)),U,1,2)_U_$P($G(SCD(I)),U,7,8)
. ;
. I '$D(SCTM) D
.. S ^TMP($J,"PSLST",I)=$P($G(SCD(I)),U,3)_U_$P($G(SCD(I)),U,4)_U_$P($G(SCD(I)),U,1,2)_U_$P($G(SCD(I)),U,7,8)
;
S CNT=0
S I=""
F S I=$O(^TMP($J,"PSLST",I)) Q:'I D
. S:'$D(SCDTE) SCDTE=DT
. S SCPIEN=$P($G(^TMP($J,"PSLST",I)),U,3)
. S SCDATA(CNT)=^TMP($J,"PSLST",I)_U_$$PSMBR(SCPIEN,SCDTE)_U_+$P($G(^SCPT(404.43,$P($G(^TMP($J,"PSLST",I)),U,2),0)),U,5)_U_+$P($G(^SCTM(404.57,SCPIEN,0)),U,4)
. S CNT=CNT+1
K ^TMP($J,"PSLST")
;
PSLTQ Q
;
PSMBR(SCPIEN,SCPDT) ;
;
N SCPRCP,SCMBR,SCPP
;
S SCMBR=$$GETPRTP^SCAPMCU2(SCPIEN,SCPDT)
S SCMBR=$S(+SCMBR>0:SCMBR,1:U)
S SCPP=$$OKPREC2^SCMCLK(SCPIEN,SCPDT)
S SCPRCP=$S(+SCPP>0:SCPP,1:U)
Q SCMBR_U_SCPRCP
;
VFILE(SCOK,SC) ;
N SCFILE,SCIEN,SCFIELD,SCVAL,SCFDA,SCMSG
;
D CHK^SCUTBK
D TMP^SCUTBK
;
S SCOK=1
D PARSE(.SC)
S SCFDA(SCFILE,""_SCIEN_","_"",SCFIELD)=SCVAL
;
D FILE^DIE("K","SCFDA","SCMSG")
;
I $D(SCMSG("DIERR")) D
. S SCOK=0
Q
;
SECKEY(SCOK,SCKEY) ;
;
D CHK^SCUTBK
;
S SCOK=$D(^XUSEC(SCKEY,DUZ))
Q
;
PSALST(SCDATA,SC) ;
;
; - Returns a array of positions that show the person currently
; assigned to the position, the preceptor for that position,
; for the patient is assigned to.
;
; Pass in the Patient's DFN
; To restrict to specific entries, pass in the following:
; Beginning and Ending Date Range
; A specific Team Position
; A Specific User entry (8930)
; A specific Team Purpose. (Read SCAPMC23 for how it exclude
; a specific team purpose.
; A specific role
; Flag whether to include patients associated by enrollement
;
N SCDT,SCD,SCER1,SCDFN,SCPRP,SCPST,SCRLE,SCIND,SCUSR,SCTM,SCDTE,SCPTTMA
;
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE(.SC)
S SCPTTMA=$G(SC("TEAMASSIGN")) ;NEW JLU
S SCDTE=$G(SCDT("BEGIN"),DT) ;bp/cmf 177 added DT for gui
;
S CNT=0
K ^TMP($J,"PSLST")
S SCOK=$$TPPT^SCAPMC(SCDFN,.SCDT,"","","","","","SCD","SCER1")
S I=0 F S I=$O(SCD(I)) Q:'I D
.Q:$P(SCD(I),U,11)'=SCPTTMA
.S ^TMP($J,"PSLST",I)=$P($G(SCD(I)),U,3)_U_$P($G(SCD(I)),U,4)_U_$P($G(SCD(I)),U,1,2)_U_$P($G(SCD(I)),U,7,8)
;
S CNT=0
S I=""
F S I=$O(^TMP($J,"PSLST",I)) Q:'I D
. S:'$D(SCDTE) SCDTE=DT
. S SCPIEN=$P($G(^TMP($J,"PSLST",I)),U,3)
. S SCDATA(CNT)=^TMP($J,"PSLST",I)_U_$$PSMBR(SCPIEN,SCDTE)_U_+$P($G(^SCPT(404.43,$P($G(^TMP($J,"PSLST",I)),U,2),0)),U,5)_U_+$P($G(^SCTM(404.57,SCPIEN,0)),U,4)
. S CNT=CNT+1
K ^TMP($J,"PSLST")
;
PSALSTQ Q
SCUTBK11 ;ALB/SCK - Scheduling Broker Utilities; 2/2/96 ;9/7/96 17:28
+1 ;;5.3;Scheduling;**41,54,86,148,177,205,209,255,297,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/30/2000 added call to IHS style patient lookup
+3 ;
+4 QUIT
PARSE(SC) ;
+1 SET SCDFN=$GET(SC("DFN"),"")
+2 SET SCPIEN=$GET(SC("PIEN"),"")
+3 IF $DATA(SC("TEAM"))
SET SCTM=$GET(SC("TEAM"))
+4 IF $DATA(SC("BEGIN"))
SET SCDT("BEGIN")=$GET(SC("BEGIN"))
+5 IF $DATA(SC("END"))
SET SCDT("END")=$GET(SC("END"))
+6 IF $DATA(SC("END"))
SET SCDT("INCL")=0
+7 SET SCFILE=$GET(SC("FILE"))
+8 SET SCIEN=$GET(SC("IEN"))
+9 SET SCFIELD=$GET(SC("FIELD"))
+10 SET SCVAL=$GET(SC("VALUE"))
+11 QUIT
+12 ;
TMLST(SCDATA,SC) ;
+1 ; -- Return a list of teams for a patient. Pass in the DFN and
+2 ; optionally a date range and/or a team purpose to restrict the
+3 ; team look up. Return only the team entry, strip out any other
+4 ; array items.
+5 ;
+6 NEW DFN,SCDT,SCPURP,SCLIST,SCER1,SCOK,SCD
+7 ;
+8 DO CHK^SCUTBK
+9 DO TMP^SCUTBK
+10 ;
+11 SET DFN=$GET(SC("DFN"))
+12 SET SCDT("BEGIN")=$GET(SC("BEGIN"),"")
+13 IF $LENGTH(SCDT("BEGIN"))>2
SET SCDT("INCL")=$GET(SC("INCL"),0)
+14 SET SCDT("END")=$GET(SC("END"),"")
+15 SET SCPURP=$GET(SC("PURP"),"")
+16 ;
+17 SET SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")
+18 ;
+19 SET I=0
FOR
SET I=$ORDER(SCD(I))
IF 'I
QUIT
SET SCDATA(I)=SCD(I)
TMQ QUIT
+1 ;
FINDP(SCOUT,SCIN) ; patient lookup used by SC PATIENT LOOKUP rpc
+1 ; input:
+2 ; SCIN("VALUE") = value to lookup
+3 ; Lookup uses multiple index lookup of File #2
+4 ; output:
+5 ; SCOUT = location of data = ^TMP("DILIST",$J,i,0)
+6 ; for i=1:number of records returned:
+7 ; DFN^patient name^DOB^PID^DOD
+8 ; 1 2 3 4 5
+9 ;
+10 ;bp/cmf 205 original code next line
+11 ;D FIND^DIC(2,,".01;.03;.363;.09","MPS",SCIN("VALUE"),500)
+12 ;bp/cmf 205 change code next line
+13 ;oifo/swo 297 added .351 for DOD warning new functionality
+14 ;IHS/ANMC/LJF 11/30/2000
DO PTLOOKUP^BSDSCRPC(SCIN("VALUE"),300)
+15 ;IHS/ANMC/LJF 11/30/2000
IF $DATA(^TMP("DILIST",$JOB))
KILL SCOUT
SET SCOUT="^TMP(""DILIST"","_$JOB_")"
+16 ;IHS/ANMC/LJF 11/30/2000
QUIT
+17 ;
+18 DO FIND^DIC(2,,".01;.03;.363;.09;.351","PS",SCIN("VALUE"),300,"B^BS^BS5^SSN")
+19 IF $GET(DIERR)
DO CLEAN^DILF
QUIT
+20 NEW SCOUNT
SET SCOUNT=+^TMP("DILIST",$JOB,0)
+21 NEW SC
FOR SC=1:1:SCOUNT
Begin DoDot:1
+22 NEW NODE,SSN,DSSN,PLID
+23 SET NODE=^TMP("DILIST",$JOB,SC,0)
+24 ;Apply DOB screen
+25 SET $PIECE(NODE,U,3)=$$DOB^DPTLK1(+NODE)
+26 ;Apply SSN screen
+27 SET SSN=$$SSN^DPTLK1(+NODE)
+28 SET DSSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,11)
+29 SET PLID=$PIECE(NODE,U,4)
+30 IF $EXTRACT(SSN,1,9)'?9N
SET (DSSN,PLID)=SSN
+31 SET $PIECE(NODE,U,4)=$SELECT($LENGTH(PLID)>5:PLID,1:DSSN)
+32 ;Move screened data back into output global
+33 ;oifo/swo 297 piece 6 is DOD field. Added for DOD warning
+34 SET ^TMP("DILIST",$JOB,SC,0)=$PIECE(NODE,U,1,4)_U_$PIECE(NODE,U,6)
End DoDot:1
+35 KILL ^TMP("DILIST",$JOB,0)
+36 KILL SCOUT
SET SCOUT="^TMP(""DILIST"","_$JOB_")"
+37 QUIT
PSLST(SCDATA,SC) ;
+1 ;
+2 ; - Returns a array of positions that show the person currently
+3 ; assigned to the position, the preceptor for that position,
+4 ; for the patient is assigned to.
+5 ;
+6 ; Pass in the Patient's DFN
+7 ; To restrict to specific entries, pass in the following:
+8 ; Beginning and Ending Date Range
+9 ; A specific Team Position
+10 ; A Specific User entry (8930)
+11 ; A specific Team Purpose. (Read SCAPMC23 for how it exclude
+12 ; a specific team purpose.
+13 ; A specific role
+14 ; Flag whether to include patients associated by enrollement
+15 ;
+16 NEW SCDT,SCD,SCER1,SCDFN,SCPRP,SCPST,SCRLE,SCIND,SCUSR,SCTM,SCDTE
+17 ;
+18 DO CHK^SCUTBK
+19 DO TMP^SCUTBK
+20 ;
+21 DO PARSE(.SC)
+22 SET SCDTE=$GET(SCDT("BEGIN"))
+23 ;
+24 SET CNT=0
+25 KILL ^TMP($JOB,"PSLST")
+26 SET SCOK=$$TPPT^SCAPMC(SCDFN,.SCDT,"","","","","","SCD","SCER1")
+27 SET I=0
FOR
SET I=$ORDER(SCD(I))
IF 'I
QUIT
Begin DoDot:1
+28 IF $DATA(SCTM)
Begin DoDot:2
+29 IF $PIECE(SCD(I),U,3)'=SCTM
QUIT
+30 SET ^TMP($JOB,"PSLST",I)=$PIECE($GET(SCD(I)),U,3)_U_$PIECE($GET(SCD(I)),U,4)_U_$PIECE($GET(SCD(I)),U,1,2)_U_$PIECE($GET(SCD(I)),U,7,8)
End DoDot:2
+31 ;
+32 IF '$DATA(SCTM)
Begin DoDot:2
+33 SET ^TMP($JOB,"PSLST",I)=$PIECE($GET(SCD(I)),U,3)_U_$PIECE($GET(SCD(I)),U,4)_U_$PIECE($GET(SCD(I)),U,1,2)_U_$PIECE($GET(SCD(I)),U,7,8)
End DoDot:2
End DoDot:1
+34 ;
+35 SET CNT=0
+36 SET I=""
+37 FOR
SET I=$ORDER(^TMP($JOB,"PSLST",I))
IF 'I
QUIT
Begin DoDot:1
+38 IF '$DATA(SCDTE)
SET SCDTE=DT
+39 SET SCPIEN=$PIECE($GET(^TMP($JOB,"PSLST",I)),U,3)
+40 SET SCDATA(CNT)=^TMP($JOB,"PSLST",I)_U_$$PSMBR(SCPIEN,SCDTE)_U_+$PIECE($GET(^SCPT(404.43,$PIECE($GET(^TMP($JOB,"PSLST",I)),U,2),0)),U,5)_U_+$PIECE($GET(^SCTM(404.57,SCPIEN,0)),U,4)
+41 SET CNT=CNT+1
End DoDot:1
+42 KILL ^TMP($JOB,"PSLST")
+43 ;
PSLTQ QUIT
+1 ;
PSMBR(SCPIEN,SCPDT) ;
+1 ;
+2 NEW SCPRCP,SCMBR,SCPP
+3 ;
+4 SET SCMBR=$$GETPRTP^SCAPMCU2(SCPIEN,SCPDT)
+5 SET SCMBR=$SELECT(+SCMBR>0:SCMBR,1:U)
+6 SET SCPP=$$OKPREC2^SCMCLK(SCPIEN,SCPDT)
+7 SET SCPRCP=$SELECT(+SCPP>0:SCPP,1:U)
+8 QUIT SCMBR_U_SCPRCP
+9 ;
VFILE(SCOK,SC) ;
+1 NEW SCFILE,SCIEN,SCFIELD,SCVAL,SCFDA,SCMSG
+2 ;
+3 DO CHK^SCUTBK
+4 DO TMP^SCUTBK
+5 ;
+6 SET SCOK=1
+7 DO PARSE(.SC)
+8 SET SCFDA(SCFILE,""_SCIEN_","_"",SCFIELD)=SCVAL
+9 ;
+10 DO FILE^DIE("K","SCFDA","SCMSG")
+11 ;
+12 IF $DATA(SCMSG("DIERR"))
Begin DoDot:1
+13 SET SCOK=0
End DoDot:1
+14 QUIT
+15 ;
SECKEY(SCOK,SCKEY) ;
+1 ;
+2 DO CHK^SCUTBK
+3 ;
+4 SET SCOK=$DATA(^XUSEC(SCKEY,DUZ))
+5 QUIT
+6 ;
PSALST(SCDATA,SC) ;
+1 ;
+2 ; - Returns a array of positions that show the person currently
+3 ; assigned to the position, the preceptor for that position,
+4 ; for the patient is assigned to.
+5 ;
+6 ; Pass in the Patient's DFN
+7 ; To restrict to specific entries, pass in the following:
+8 ; Beginning and Ending Date Range
+9 ; A specific Team Position
+10 ; A Specific User entry (8930)
+11 ; A specific Team Purpose. (Read SCAPMC23 for how it exclude
+12 ; a specific team purpose.
+13 ; A specific role
+14 ; Flag whether to include patients associated by enrollement
+15 ;
+16 NEW SCDT,SCD,SCER1,SCDFN,SCPRP,SCPST,SCRLE,SCIND,SCUSR,SCTM,SCDTE,SCPTTMA
+17 ;
+18 DO CHK^SCUTBK
+19 DO TMP^SCUTBK
+20 ;
+21 DO PARSE(.SC)
+22 ;NEW JLU
SET SCPTTMA=$GET(SC("TEAMASSIGN"))
+23 ;bp/cmf 177 added DT for gui
SET SCDTE=$GET(SCDT("BEGIN"),DT)
+24 ;
+25 SET CNT=0
+26 KILL ^TMP($JOB,"PSLST")
+27 SET SCOK=$$TPPT^SCAPMC(SCDFN,.SCDT,"","","","","","SCD","SCER1")
+28 SET I=0
FOR
SET I=$ORDER(SCD(I))
IF 'I
QUIT
Begin DoDot:1
+29 IF $PIECE(SCD(I),U,11)'=SCPTTMA
QUIT
+30 SET ^TMP($JOB,"PSLST",I)=$PIECE($GET(SCD(I)),U,3)_U_$PIECE($GET(SCD(I)),U,4)_U_$PIECE($GET(SCD(I)),U,1,2)_U_$PIECE($GET(SCD(I)),U,7,8)
End DoDot:1
+31 ;
+32 SET CNT=0
+33 SET I=""
+34 FOR
SET I=$ORDER(^TMP($JOB,"PSLST",I))
IF 'I
QUIT
Begin DoDot:1
+35 IF '$DATA(SCDTE)
SET SCDTE=DT
+36 SET SCPIEN=$PIECE($GET(^TMP($JOB,"PSLST",I)),U,3)
+37 SET SCDATA(CNT)=^TMP($JOB,"PSLST",I)_U_$$PSMBR(SCPIEN,SCDTE)_U_+$PIECE($GET(^SCPT(404.43,$PIECE($GET(^TMP($JOB,"PSLST",I)),U,2),0)),U,5)_U_+$PIECE($GET(^SCTM(404.57,SCPIEN,0)),U,4)
+38 SET CNT=CNT+1
End DoDot:1
+39 KILL ^TMP($JOB,"PSLST")
+40 ;
PSALSTQ QUIT
