- 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**;AUG 13, 1993
- ;
- 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 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCUTBK11 6008 printed Feb 19, 2025@00:10:44 Page 2
- 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**;AUG 13, 1993
- +2 ;
- +3 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 DO FIND^DIC(2,,".01;.03;.363;.09;.351","PS",SCIN("VALUE"),300,"B^BS^BS5^SSN")
- +15 IF $GET(DIERR)
- DO CLEAN^DILF
- QUIT
- +16 NEW SCOUNT
- SET SCOUNT=+^TMP("DILIST",$JOB,0)
- +17 NEW SC
- FOR SC=1:1:SCOUNT
- Begin DoDot:1
- +18 NEW NODE,SSN,DSSN,PLID
- +19 SET NODE=^TMP("DILIST",$JOB,SC,0)
- +20 ;Apply DOB screen
- +21 SET $PIECE(NODE,U,3)=$$DOB^DPTLK1(+NODE)
- +22 ;Apply SSN screen
- +23 SET SSN=$$SSN^DPTLK1(+NODE)
- +24 SET DSSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,11)
- +25 SET PLID=$PIECE(NODE,U,4)
- +26 IF $EXTRACT(SSN,1,9)'?9N
- SET (DSSN,PLID)=SSN
- +27 SET $PIECE(NODE,U,4)=$SELECT($LENGTH(PLID)>5:PLID,1:DSSN)
- +28 ;Move screened data back into output global
- +29 ;oifo/swo 297 piece 6 is DOD field. Added for DOD warning
- +30 SET ^TMP("DILIST",$JOB,SC,0)=$PIECE(NODE,U,1,4)_U_$PIECE(NODE,U,6)
- End DoDot:1
- +31 KILL ^TMP("DILIST",$JOB,0)
- +32 KILL SCOUT
- SET SCOUT="^TMP(""DILIST"","_$JOB_")"
- +33 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