SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,48,98,177,231,433,526,520,1015**;AUG 13, 1993;Build 21
;;DMR BP-OIFO Patch SD*5.3*526
;IHS/ANMC/LJF 11/03/2000 used IHS code for last/next appts
;
;List of Team's Patients Report
;
HITS(ARRY,TIEN) ;
;ARRY - list of patients for a given team
;TIEN - team ien
;
N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT
N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE
N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN
S INACTIVE=0
S NXT=0
F S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N) D
.S NODE=$G(@ARRY@(NXT))
.Q:NODE=""
.S PTIEN=+$P(NODE,"^") ;patient ien
.S PTNAME=$P(NODE,"^",2) ;patient name
.S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42)
.;
.S PNODE=$G(^DPT(PTIEN,0))
.Q:PNODE=""
.S DFN=PTIEN
.D PID^VADPT6
.;S PID=VA("BID")
.S PID=$E(VA("PID"),1,3)_$E(VA("PID"),5,6)_$E(VA("PID"),8,12)
.;
.N CNAME,PINF,CLIEN
.S CNT=""
.F S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N) D
..D TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP)
Q
;
TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ;
N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN
I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]"
; ^ no patient team position assignment
IF START="" D
.S PTPA=$O(^SCPT(404.43,"B",PTAI,START))
ELSE D
.S PTPA=START
I PTPA="" Q "0^[Not Assigned]"
S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team assignment
I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]"
I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1
S TPIEN=+$P(PTPAN,"^",2) ;team position ien (#404.57)
I '$D(^SCTM(404.57,TPIEN,0)) Q "0^[Not Assigned]"
S TPNODE=$G(^SCTM(404.57,TPIEN,0))
I TPNODE="" Q "0^[Not Assigned]"
S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
Q:'$D(ROLE(ROL))&(ROLE'=1) -1
; ^ not a selected role
S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
;
S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC?
;
D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN)
;next two lines commented off - SD*5.3*433
;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
;I 'ENROLL S CNAME="",CIEN=0
;
S PAIEN=$$CHK(TPIEN)
I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name
;SD*5.3*231
I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]"
;
D GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF) ;get patient info
S CNAME=$G(CNAME(0))
S PINF=$G(PINF(0))
I PINF="" D
.S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
I INACTIVE S @STORE@(INS,TIEN,"INACT")=""
S FLAG="Y"
S TINFO=$$TINF^SCRPTP(TIEN) ;team information
S INST=+$P(TINFO,"^") ;institution ien
S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
S PHONE=$P(TINFO,"^",4) ;team phone
S PC=$P(TINFO,"^",3) ;primary care?
S TNAME=$P(TINFO,"^",2) ;team name
;
S (NEXT,LAST)=""
;I +CIEN>0 S NEXT=$$GETNEXT^SCRPU3(PTIEN,CIEN) ;next appointment;IHS/ANMC/LJF 11/03/2000
;I +CIEN>0 S LAST=$$GETLAST^SCRPU3(PTIEN,CIEN) ;last appointment;IHS/ANMC/LJF 11/03/2000
S NEXT=$$GETAPPT^BSDSCEC(PTIEN,TIEN,"NEXT") ;IHS/ANMC/LJF 11/03/2000
S LAST=$$GETAPPT^BSDSCEC(PTIEN,TIEN,"LAST") ;IHS/ANMC/LJF 11/03/2000
;
D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
D FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP)
N SCCNT
S SCCNT=0 F S SCCNT=$O(CNAME(SCCNT)) Q:SCCNT="" D FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP)
Q
;
ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED
;
;N FOUND,ENODE,EN,NXT
;S FOUND=0
;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
;S NXT=""
;F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D
;check if active enrollment
;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q ;not active enrollment
;; ^ discharge date ^ enrollment date
S FOUND=0
Q FOUND
;
CHK(TPIEN) ;assigned to a position
;TPIEN - ien of 404.57 Team Position file
;returns: ien of 200 New Person file
N EN,PLIST,PERR,ERR,NAME
S PLIST="PLST",PERR="PRR"
K @PLIST,@PERR
S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR)
I '$D(@PERR) D
.S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file
.S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name
K @PLIST,@PERR
Q EN_"^"_NAME
;
SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,48,98,177,231,433,526,520,1015**;AUG 13, 1993;Build 21
+2 ;;DMR BP-OIFO Patch SD*5.3*526
+3 ;IHS/ANMC/LJF 11/03/2000 used IHS code for last/next appts
+4 ;
+5 ;List of Team's Patients Report
+6 ;
HITS(ARRY,TIEN) ;
+1 ;ARRY - list of patients for a given team
+2 ;TIEN - team ien
+3 ;
+4 NEW PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT
+5 NEW PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE
+6 NEW CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN
+7 SET INACTIVE=0
+8 SET NXT=0
+9 FOR
SET NXT=$ORDER(@ARRY@(NXT))
IF NXT=""!(NXT'?.N)
QUIT
Begin DoDot:1
+10 SET NODE=$GET(@ARRY@(NXT))
+11 IF NODE=""
QUIT
+12 ;patient ien
SET PTIEN=+$PIECE(NODE,"^")
+13 ;patient name
SET PTNAME=$PIECE(NODE,"^",2)
+14 ;patient team assignment ien (#404.42)
SET PTAI=+$PIECE(NODE,"^",3)
+15 ;
+16 SET PNODE=$GET(^DPT(PTIEN,0))
+17 IF PNODE=""
QUIT
+18 SET DFN=PTIEN
+19 DO PID^VADPT6
+20 ;S PID=VA("BID")
+21 SET PID=$EXTRACT(VA("PID"),1,3)_$EXTRACT(VA("PID"),5,6)_$EXTRACT(VA("PID"),8,12)
+22 ;
+23 NEW CNAME,PINF,CLIEN
+24 SET CNT=""
+25 FOR
SET CNT=$ORDER(^SCPT(404.43,"B",PTAI,CNT))
IF CNT=""!(CNT'?.N)
QUIT
Begin DoDot:2
+26 DO TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP)
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ;
+1 NEW PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN
+2 IF '$DATA(^SCPT(404.43,"B",PTAI))
QUIT "0^[Not Assigned]"
+3 ; ^ no patient team position assignment
+4 IF START=""
Begin DoDot:1
+5 SET PTPA=$ORDER(^SCPT(404.43,"B",PTAI,START))
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET PTPA=START
End DoDot:1
+8 IF PTPA=""
QUIT "0^[Not Assigned]"
+9 ;patient team assignment
SET PTPAN=$GET(^SCPT(404.43,PTPA,0))
+10 IF PTPAN=""!(PTPAN=0)
QUIT "0^[Not Assigned]"
+11 IF $PIECE(PTPAN,"^",4)'=""
IF $PIECE(PTPAN,"^",4)<DT
QUIT -1
+12 ;team position ien (#404.57)
SET TPIEN=+$PIECE(PTPAN,"^",2)
+13 IF '$DATA(^SCTM(404.57,TPIEN,0))
QUIT "0^[Not Assigned]"
+14 SET TPNODE=$GET(^SCTM(404.57,TPIEN,0))
+15 IF TPNODE=""
QUIT "0^[Not Assigned]"
+16 ;role for position (ien)
SET ROL=+$PIECE(TPNODE,"^",3)
+17 IF '$DATA(ROLE(ROL))&(ROLE'=1)
QUIT -1
+18 ; ^ not a selected role
+19 ;role name
SET ROLN=$PIECE($GET(^SD(403.46,ROL,0)),U)
+20 ;
+21 ;PC?
SET PCAP=$SELECT($PIECE(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP")
+22 ;
+23 DO SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN)
+24 ;next two lines commented off - SD*5.3*433
+25 ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
+26 ;I 'ENROLL S CNAME="",CIEN=0
+27 ;
+28 SET PAIEN=$$CHK(TPIEN)
+29 ; practitioner's name
IF +PAIEN'=0
SET PIEN=+PAIEN
SET PNAME=$PIECE(PAIEN,"^",2)
+30 ;SD*5.3*231
+31 IF +PAIEN=0
SET PIEN=0
SET PNAME="[Inactive Position]"
+32 ;
+33 ;get patient info
DO GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF)
+34 SET CNAME=$GET(CNAME(0))
+35 SET PINF=$GET(PINF(0))
+36 IF PINF=""
Begin DoDot:1
+37 SET PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
End DoDot:1
+38 IF INACTIVE
SET @STORE@(INS,TIEN,"INACT")=""
+39 SET FLAG="Y"
+40 ;team information
SET TINFO=$$TINF^SCRPTP(TIEN)
+41 ;institution ien
SET INST=+$PIECE(TINFO,"^")
+42 ;institution name
SET INAME=$PIECE($GET(^DIC(4,INST,0)),"^")
+43 ;team phone
SET PHONE=$PIECE(TINFO,"^",4)
+44 ;primary care?
SET PC=$PIECE(TINFO,"^",3)
+45 ;team name
SET TNAME=$PIECE(TINFO,"^",2)
+46 ;
+47 SET (NEXT,LAST)=""
+48 ;I +CIEN>0 S NEXT=$$GETNEXT^SCRPU3(PTIEN,CIEN) ;next appointment;IHS/ANMC/LJF 11/03/2000
+49 ;I +CIEN>0 S LAST=$$GETLAST^SCRPU3(PTIEN,CIEN) ;last appointment;IHS/ANMC/LJF 11/03/2000
+50 ;IHS/ANMC/LJF 11/03/2000
SET NEXT=$$GETAPPT^BSDSCEC(PTIEN,TIEN,"NEXT")
+51 ;IHS/ANMC/LJF 11/03/2000
SET LAST=$$GETAPPT^BSDSCEC(PTIEN,TIEN,"LAST")
+52 ;
+53 DO TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
+54 DO FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP)
+55 NEW SCCNT
+56 SET SCCNT=0
FOR
SET SCCNT=$ORDER(CNAME(SCCNT))
IF SCCNT=""
QUIT
DO FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP)
+57 QUIT
+58 ;
ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED
+1 ;
+2 ;N FOUND,ENODE,EN,NXT
+3 ;S FOUND=0
+4 ;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
+5 ;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
+6 ;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
+7 ;S NXT=""
+8 ;F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D
+9 ;check if active enrollment
+10 ;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
+11 ;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q ;not active enrollment
+12 ;; ^ discharge date ^ enrollment date
+13 SET FOUND=0
+14 QUIT FOUND
+15 ;
CHK(TPIEN) ;assigned to a position
+1 ;TPIEN - ien of 404.57 Team Position file
+2 ;returns: ien of 200 New Person file
+3 NEW EN,PLIST,PERR,ERR,NAME
+4 SET PLIST="PLST"
SET PERR="PRR"
+5 KILL @PLIST,@PERR
+6 SET ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR)
+7 IF '$DATA(@PERR)
Begin DoDot:1
+8 ;ien of new person file
SET EN=$PIECE($GET(@PLIST@(1)),"^")
+9 ; new person name
SET NAME=$PIECE($GET(@PLIST@(1)),"^",2)
End DoDot:1
+10 KILL @PLIST,@PERR
+11 QUIT EN_"^"_NAME
+12 ;
