SCAPMC26 ;ALB/REW - API: Patients in a Clinic ; December 1, 1995 [12/21/98 4:30pm]
;;5.3;Scheduling;**41,157**;AUG 13, 1993
;
PTCL(SC44,SCDATES,SCLIST,SCERR) ; patients in a clinic
; Input:
; SC44 - Pointer to Hospital Location File #44
; SCDATES- Date array (begin, end, incl)
; SCLIST - Name of output array
; SCERR = array NAME to store error messages.
; [ex. ^TMP("ORXX",$J
; Output:
; SCLIST() = array of practitioners (users) - pointers to file #200
; Format:
; Subscript: Sequential # from 1 to n
; Piece Description
; 1 DFN - Ptr to Patient File (#2)
; 2 Patient Name (External)
; 3 null
; 4 Activation Date
; 5 Discharge Date
; 6 '1' - for merge reasons with other pt lists
; 7 sc44
;
; SCERR() = Array of DIALOG file messages(errors) .
; @SCERR(0)= Number of error(s), UNDEFINED if no errors
; Foramt:
; Subscript: Sequential # from 1 to n
; Piece Description
; 1 IEN of DIALOG file
; Returned: 1 if ok, 0 if error
;
ST N DFN,SCOK,SCCL,SCCLDT
N SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS
; -- initialize control variables
S SCOK=1
G:'$$OKDATA CLTPQ
;S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN IF $D(^DPT(DFN,"DE","B",SC44)) S SCCL=$O(^DPT(DFN,"DE","B",SC44,0)) D
S SCCLDT=0
F S SCCLDT=$O(^DPT("AEB1",SC44,SCCLDT)) Q:'SCCLDT D
.S DFN=0
.F S DFN=$O(^DPT("AEB1",SC44,SCCLDT,DFN)) Q:'DFN D
..Q:$D(^TMP("SCMC",$J,"EXCLUDE PT","SCPTA",DFN))
..;;bp/cmf 2981008
..;;modified code begin
..S SCCL=$O(^DPT("AEB1",SC44,SCCLDT,DFN,0))
..Q:'SCCL
..S SCX=$O(^DPT("AEB1",SC44,SCCLDT,DFN,SCCL,0))
..Q:'SCX
..S SCNODE=$G(^DPT(DFN,"DE",SCCL,1,SCX,0))
..I $$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,$P($P(SCNODE,U,1),"."),$P(SCNODE,U,3)) D
...S SCN=$G(@SCLIST@(0),0)+1
...S @SCLIST@(0)=SCN
...S @SCLIST@(SCN)=DFN_U_$P($G(^DPT(DFN,0)),U,1)_U_U_$P(SCNODE,U,1)_U_$P(SCNODE,U,3)_U_"1"_U_SC44_U_$P($G(^DPT(DFN,.36)),U,3)
...Q
..S @SCLIST@("SC PTCL",DFN,SCX,SCN)=""
..Q
.Q
;;..modified code end
;;..original code begin
;;..Q:$D(@SCLIST@("SC PTCL",DFN))
;;..S SCCL=0
;;..F S SCCL=$O(^DPT(DFN,"DE","B",SC44,SCCL)) Q:'SCCL D
;;...S SCX=0 F S SCX=$O(^DPT(DFN,"DE",SCCL,1,SCX)) Q:'SCX S SCNODE=^(SCX,0) D
;;....IF $$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,$P(SCNODE,U,1),$P(SCNODE,U,3)) D
;;.....Q:$D(@SCLIST@("SC PTCL",DFN))
;;.....S SCN=$G(@SCLIST@(0),0)+1
;;.....S @SCLIST@(0)=SCN
;;.....S @SCLIST@(SCN)=DFN_U_$P($G(^DPT(DFN,0)),U,1)_U_U_$P(SCNODE,U,1)_U_$P(SCNODE,U,3)_U_"1"_U_SC44_U_$P($G(^DPT(DFN,.36)),U,3)
;;....S @SCLIST@("SC PTCL",DFN,SCX,SCN)=""
;;original code end
;;bp/cmf 2981008
CLTPQ Q $G(@SCERR@(0))<1
;
OKDATA() ;check/setup variables - return 1 if ok; 0 if error
N SCOK
S SCOK=1
S (SCN,SCESEQ,SCLSEQ)=0
D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
IF '$D(^SC(+$G(SC44),0)) D S SCOK=0
. S SCPARM("CLINIC")=$G(SC44,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
IF '$L($G(SCLIST)) D S SCOK=0
. S SCPARM("OUTPUT ARRAY")=$G(SCLIST,"Undefined")
. D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
Q SCOK
;
PTCLBR(SC44,SCTM,SCDATES) ;for PCMM use only!! returns list to ^tmp($j,'scclpt'
; SC44 - Clinic we're adding to team
; SCTM - EXCLUDES Patients assigned to SCTM Team during time period
; SCDATES - Standard Date array
; Returns: $j if successful & at least one entry, 0 if error or none
; Warning: Kills ^tmp($j,'scclpt') before it runs & ^tmp('scmc',$j,'exclude pt') after it runs
N SCCLERR,SCX,SCXX
K ^TMP($J,"SCCLPT")
S SCXX=$$PTTM^SCAPMC(SCTM,.SCDATES,"^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCCLERR")
S SCX=$$PTCL(.SC44,.SCDATES,"^TMP($J,""SCCLPT"")","SCCLERR")
K ^TMP("SCMC",$J,"EXCLUDE PT")
Q $S('SCX:0,('$G(^TMP($J,"SCCLPT",0))):0,1:$J)
;
PTCLBRTP(SC44,SCTP,SCDATES) ;for PCMM use only!! returns list to ^tmp($j,'scclpt'
; SC44 - Clinic we're adding to team
; SCTP - EXCLUDES Patients assigned to SCTP Position during scdates
; SCDATES - Standard Date array
; Returns: $j if successful & at least one entry, 0 if error or none
; Warning: Kills ^tmp($j,'scclpt') before it runs
N SCCLERR,SCX,SCXX
K ^TMP($J,"SCCLPT")
S SCXX=$$PTTP^SCAPMC(SCTP,.SCDATES,"^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCCLERR")
S SCX=$$PTCL(.SC44,.SCDATES,"^TMP($J,""SCCLPT"")","SCCLERR")
K ^TMP("SCMC",$J,"EXCLUDE PT")
Q $S('SCX:0,('$G(^TMP($J,"SCCLPT",0))):0,1:$J)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC26 4705 printed Dec 13, 2024@02:38 Page 2
SCAPMC26 ;ALB/REW - API: Patients in a Clinic ; December 1, 1995 [12/21/98 4:30pm]
+1 ;;5.3;Scheduling;**41,157**;AUG 13, 1993
+2 ;
PTCL(SC44,SCDATES,SCLIST,SCERR) ; patients in a clinic
+1 ; Input:
+2 ; SC44 - Pointer to Hospital Location File #44
+3 ; SCDATES- Date array (begin, end, incl)
+4 ; SCLIST - Name of output array
+5 ; SCERR = array NAME to store error messages.
+6 ; [ex. ^TMP("ORXX",$J
+7 ; Output:
+8 ; SCLIST() = array of practitioners (users) - pointers to file #200
+9 ; Format:
+10 ; Subscript: Sequential # from 1 to n
+11 ; Piece Description
+12 ; 1 DFN - Ptr to Patient File (#2)
+13 ; 2 Patient Name (External)
+14 ; 3 null
+15 ; 4 Activation Date
+16 ; 5 Discharge Date
+17 ; 6 '1' - for merge reasons with other pt lists
+18 ; 7 sc44
+19 ;
+20 ; SCERR() = Array of DIALOG file messages(errors) .
+21 ; @SCERR(0)= Number of error(s), UNDEFINED if no errors
+22 ; Foramt:
+23 ; Subscript: Sequential # from 1 to n
+24 ; Piece Description
+25 ; 1 IEN of DIALOG file
+26 ; Returned: 1 if ok, 0 if error
+27 ;
ST NEW DFN,SCOK,SCCL,SCCLDT
+1 NEW SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS
+2 ; -- initialize control variables
+3 SET SCOK=1
+4 if '$$OKDATA
GOTO CLTPQ
+5 ;S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN IF $D(^DPT(DFN,"DE","B",SC44)) S SCCL=$O(^DPT(DFN,"DE","B",SC44,0)) D
+6 SET SCCLDT=0
+7 FOR
SET SCCLDT=$ORDER(^DPT("AEB1",SC44,SCCLDT))
if 'SCCLDT
QUIT
Begin DoDot:1
+8 SET DFN=0
+9 FOR
SET DFN=$ORDER(^DPT("AEB1",SC44,SCCLDT,DFN))
if 'DFN
QUIT
Begin DoDot:2
+10 if $DATA(^TMP("SCMC",$JOB,"EXCLUDE PT","SCPTA",DFN))
QUIT
+11 ;;bp/cmf 2981008
+12 ;;modified code begin
+13 SET SCCL=$ORDER(^DPT("AEB1",SC44,SCCLDT,DFN,0))
+14 if 'SCCL
QUIT
+15 SET SCX=$ORDER(^DPT("AEB1",SC44,SCCLDT,DFN,SCCL,0))
+16 if 'SCX
QUIT
+17 SET SCNODE=$GET(^DPT(DFN,"DE",SCCL,1,SCX,0))
+18 IF $$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,$PIECE($PIECE(SCNODE,U,1),"."),$PIECE(SCNODE,U,3))
Begin DoDot:3
+19 SET SCN=$GET(@SCLIST@(0),0)+1
+20 SET @SCLIST@(0)=SCN
+21 SET @SCLIST@(SCN)=DFN_U_$PIECE($GET(^DPT(DFN,0)),U,1)_U_U_$PIECE(SCNODE,U,1)_U_$PIECE(SCNODE,U,3)_U_"1"_U_SC44_U_$PIECE($GET(^DPT(DFN,.36)),U,3)
+22 QUIT
End DoDot:3
+23 SET @SCLIST@("SC PTCL",DFN,SCX,SCN)=""
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 ;;..modified code end
+27 ;;..original code begin
+28 ;;..Q:$D(@SCLIST@("SC PTCL",DFN))
+29 ;;..S SCCL=0
+30 ;;..F S SCCL=$O(^DPT(DFN,"DE","B",SC44,SCCL)) Q:'SCCL D
+31 ;;...S SCX=0 F S SCX=$O(^DPT(DFN,"DE",SCCL,1,SCX)) Q:'SCX S SCNODE=^(SCX,0) D
+32 ;;....IF $$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,$P(SCNODE,U,1),$P(SCNODE,U,3)) D
+33 ;;.....Q:$D(@SCLIST@("SC PTCL",DFN))
+34 ;;.....S SCN=$G(@SCLIST@(0),0)+1
+35 ;;.....S @SCLIST@(0)=SCN
+36 ;;.....S @SCLIST@(SCN)=DFN_U_$P($G(^DPT(DFN,0)),U,1)_U_U_$P(SCNODE,U,1)_U_$P(SCNODE,U,3)_U_"1"_U_SC44_U_$P($G(^DPT(DFN,.36)),U,3)
+37 ;;....S @SCLIST@("SC PTCL",DFN,SCX,SCN)=""
+38 ;;original code end
+39 ;;bp/cmf 2981008
CLTPQ QUIT $GET(@SCERR@(0))<1
+1 ;
OKDATA() ;check/setup variables - return 1 if ok; 0 if error
+1 NEW SCOK
+2 SET SCOK=1
+3 SET (SCN,SCESEQ,SCLSEQ)=0
+4 ; set default dates & error array (if undefined)
DO INIT^SCAPMCU1(.SCOK)
+5 IF '$DATA(^SC(+$GET(SC44),0))
Begin DoDot:1
+6 SET SCPARM("CLINIC")=$GET(SC44,"Undefined")
+7 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
SET SCOK=0
+8 IF '$LENGTH($GET(SCLIST))
Begin DoDot:1
+9 SET SCPARM("OUTPUT ARRAY")=$GET(SCLIST,"Undefined")
+10 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
SET SCOK=0
+11 QUIT SCOK
+12 ;
PTCLBR(SC44,SCTM,SCDATES) ;for PCMM use only!! returns list to ^tmp($j,'scclpt'
+1 ; SC44 - Clinic we're adding to team
+2 ; SCTM - EXCLUDES Patients assigned to SCTM Team during time period
+3 ; SCDATES - Standard Date array
+4 ; Returns: $j if successful & at least one entry, 0 if error or none
+5 ; Warning: Kills ^tmp($j,'scclpt') before it runs & ^tmp('scmc',$j,'exclude pt') after it runs
+6 NEW SCCLERR,SCX,SCXX
+7 KILL ^TMP($JOB,"SCCLPT")
+8 SET SCXX=$$PTTM^SCAPMC(SCTM,.SCDATES,"^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCCLERR")
+9 SET SCX=$$PTCL(.SC44,.SCDATES,"^TMP($J,""SCCLPT"")","SCCLERR")
+10 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+11 QUIT $SELECT('SCX:0,('$GET(^TMP($JOB,"SCCLPT",0))):0,1:$JOB)
+12 ;
PTCLBRTP(SC44,SCTP,SCDATES) ;for PCMM use only!! returns list to ^tmp($j,'scclpt'
+1 ; SC44 - Clinic we're adding to team
+2 ; SCTP - EXCLUDES Patients assigned to SCTP Position during scdates
+3 ; SCDATES - Standard Date array
+4 ; Returns: $j if successful & at least one entry, 0 if error or none
+5 ; Warning: Kills ^tmp($j,'scclpt') before it runs
+6 NEW SCCLERR,SCX,SCXX
+7 KILL ^TMP($JOB,"SCCLPT")
+8 SET SCXX=$$PTTP^SCAPMC(SCTP,.SCDATES,"^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCCLERR")
+9 SET SCX=$$PTCL(.SC44,.SCDATES,"^TMP($J,""SCCLPT"")","SCCLERR")
+10 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+11 QUIT $SELECT('SCX:0,('$GET(^TMP($JOB,"SCCLPT",0))):0,1:$JOB)
+12 ;
