SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99 1:33 PM
;;5.3;Scheduling;**41,88,140,148,174,181,177,526,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/02/2000 changed PT ID from SSN to HRCN
; moved PT ID column to fit 6 digits
;
;Patient Listing w/Team Assignment Data Report continued
;
CHK(PTIEN,PIEN) ;assigned to a position
;PTIEN - ien of 404.42 Patient Team Assignment file
;PIEN - ien of patient file #2
;
N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN
S START=""
Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="")
I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q
F S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START="" D
.S NODE=$G(^SCPT(404.43,START,0))
.Q:NODE=""
.Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)<DT)
.; ^ not assigned currently
.S PCAP=+$P(NODE,U,5)
.S TPIEN=+$P(NODE,"^",2) ;team position ien (404.57)
.I '$D(^SCTM(404.57,TPIEN,0)) D NOTA(PTIEN,PIEN) Q
.S TPNODE=$G(^SCTM(404.57,TPIEN,0))
.I TPNODE="" D NOTA(PTIEN,PIEN) Q
.S PCAP=$S('PCAP:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ; PC?
.S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) ;preceptor name
.;
.S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
.Q:'$D(ROLE(ROL))&(ROLE'=1) ;not a selected role
.S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
.;
.S PRAC=$$PRACI(TPIEN) ;practitioner information
.I +PRAC=-1 D NOTA(PTIEN,PIEN) Q
.I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q
.; ^ not a selected practitioner
.;
.S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^")
.D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN)
Q
PRACI(TPIEN) ;
;TPIEN - team position ien (404.57)
;
N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN
S TPLIST="TPLST",TPERR="ERR2"
K @TPLIST,@TPERR
S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR)
Q:ERR=0!($D(@TPERR)) -1
S NODE=$G(@TPLIST@(1))
Q:NODE="" "0^[Not Assigned]"
S NAME=$P(NODE,"^",2) ;practitioner name
S NPIEN=+$P(NODE,"^") ;practitioner ien
S POS=$P(NODE,"^",4) ;position name
S POSIEN=+$P(NODE,"^",3) ;position ien
I POS="" S POS="[Not Assigned]",POSIEN=0
I NAME="" S NAME="[Not Assigned]",NPIEN=0
K @TPLIST,@TPERR
Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN
;
FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ;
;START - patient team assignment position ien
;NODE - patient team position assignment node
;TPIEN - team position ien (404.57)
;POS - team position
;TPNODE - team position node (404.57)
;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN
;ROLN - role name
;PCAP - PC/AP/NPC assignment?
;PRCN - preceptor name
;
N PTNAME,PID,ADATE
S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name
S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
;9 digit ssn SD*5.3*526 - dmr
;S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation
;
S PID=$$HRCN^BDGF2(PIEN,+$G(DUZ(2))) ;IHS/ANMC/LJF 11/2/2000
S ADATE=$P(NODE,"^",3) ;position assignment date - fm format
;convert to external format
I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0")
;
S PNAME=$P(PRAC,"^",2) ;practitioner name
S PNIEN=$P(PRAC,"^") ;practitioner ien
;
S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51
S TMN=$G(^SCTM(404.51,TIEN,0))
Q:TMN=""
S TNAME=$P(TMN,"^") ;team name
S PC=$P(TMN,"^",5) ;primary care team 1/0
S IIEN=+$P(TMN,"^",7) ;institution ien
S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution
;
D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
Q
;
FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ;
;IIEN - institution ien
;INAME - institution name
;TNAME - team name
;TIEN - team ien
;PC - primary care 1/0
;PTNAME - patient name
;PID - last 4 pid plus 5th pseudo
;PNAME - practitioner name
;PIEN - practitioner ien
;POS - position name
;TPIEN - position ien
;ADATE - assignment date
;PTIEN - patient ien
;ROLN - role name
;PCAP - PC/AP/NPC assignment?
;PRCN - preceptor name
;
I INAME="" S INAME="[BAD DATA]"
I TNAME="" S TNAME="[BAD DATA]"
I PNAME="" S PNAME="[BAD DATA]"
I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)=""
I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)=""
I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)=""
S @STORE@(IIEN)="Division: "_INAME
S @STORE@(IIEN,TIEN)="Team: "_TNAME
S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO")
;
S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,17)
;S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID ;IHS/ANMC/LJF 11/2/2000
S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),23)=PID ;IHS/ANMC/LJF 11/2/2000
S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE
S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP
S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21)
S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20)
S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20)
S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20)
Q
;
NOTA(PTIEN,PIEN) ;
;PTIEN - patient team assignment (#404.42)
;PIEN - patient ien
N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN
N ROLN,PCAP,PRCN,ADATE
S POS="[Not Assigned]",POSIEN=0
S PNAME="[Not Assigned]",PNIEN=0
S (ROLN,PCAP,PRCN,ADATE)=""
;
S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name
S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
;S PID=$E(PID,6,10) ;9 digit ssn patch 526
;
S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien
S TMN=$G(^SCTM(404.51,TIEN,0))
Q:TMN=""
S TNAME=$P(TMN,"^") ;team name
S PC=$P(TMN,"^",5) ;primary care team 1/0
S IIEN=+$P(TMN,"^",7) ;institution ien
S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name
;
D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
Q
SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99 1:33 PM
+1 ;;5.3;Scheduling;**41,88,140,148,174,181,177,526,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/02/2000 changed PT ID from SSN to HRCN
+3 ; moved PT ID column to fit 6 digits
+4 ;
+5 ;Patient Listing w/Team Assignment Data Report continued
+6 ;
CHK(PTIEN,PIEN) ;assigned to a position
+1 ;PTIEN - ien of 404.42 Patient Team Assignment file
+2 ;PIEN - ien of patient file #2
+3 ;
+4 NEW NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN
+5 SET START=""
+6 IF '$DATA(^SCPT(404.43,"B",PTIEN))&(PRACT'="")
QUIT
+7 IF '$DATA(^SCPT(404.43,"B",PTIEN))&(PRACT="")
DO NOTA(PTIEN,PIEN)
QUIT
+8 FOR
SET START=$ORDER(^SCPT(404.43,"B",PTIEN,START))
IF START=""
QUIT
Begin DoDot:1
+9 SET NODE=$GET(^SCPT(404.43,START,0))
+10 IF NODE=""
QUIT
+11 IF ($PIECE(NODE,"^",4)'="")&($PIECE(NODE,"^",4)<DT)
QUIT
+12 ; ^ not assigned currently
+13 SET PCAP=+$PIECE(NODE,U,5)
+14 ;team position ien (404.57)
SET TPIEN=+$PIECE(NODE,"^",2)
+15 IF '$DATA(^SCTM(404.57,TPIEN,0))
DO NOTA(PTIEN,PIEN)
QUIT
+16 SET TPNODE=$GET(^SCTM(404.57,TPIEN,0))
+17 IF TPNODE=""
DO NOTA(PTIEN,PIEN)
QUIT
+18 ; PC?
SET PCAP=$SELECT('PCAP:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP")
+19 ;preceptor name
SET PRCN=$PIECE($$OKPREC2^SCMCLK(TPIEN,DT),U,2)
+20 ;
+21 ;role for position (ien)
SET ROL=+$PIECE(TPNODE,"^",3)
+22 ;not a selected role
IF '$DATA(ROLE(ROL))&(ROLE'=1)
QUIT
+23 ;role name
SET ROLN=$PIECE($GET(^SD(403.46,ROL,0)),U)
+24 ;
+25 ;practitioner information
SET PRAC=$$PRACI(TPIEN)
+26 IF +PRAC=-1
DO NOTA(PTIEN,PIEN)
QUIT
+27 IF (PRACT'=1)&('$DATA(PRACT(+PRAC)))&(+PRAC'=0)
QUIT
+28 ; ^ not a selected practitioner
+29 ;
+30 SET POS=$PIECE($GET(^SCTM(404.57,TPIEN,0)),"^")
+31 DO FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN)
End DoDot:1
+32 QUIT
PRACI(TPIEN) ;
+1 ;TPIEN - team position ien (404.57)
+2 ;
+3 NEW EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN
+4 SET TPLIST="TPLST"
SET TPERR="ERR2"
+5 KILL @TPLIST,@TPERR
+6 SET ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR)
+7 IF ERR=0!($DATA(@TPERR))
QUIT -1
+8 SET NODE=$GET(@TPLIST@(1))
+9 IF NODE=""
QUIT "0^[Not Assigned]"
+10 ;practitioner name
SET NAME=$PIECE(NODE,"^",2)
+11 ;practitioner ien
SET NPIEN=+$PIECE(NODE,"^")
+12 ;position name
SET POS=$PIECE(NODE,"^",4)
+13 ;position ien
SET POSIEN=+$PIECE(NODE,"^",3)
+14 IF POS=""
SET POS="[Not Assigned]"
SET POSIEN=0
+15 IF NAME=""
SET NAME="[Not Assigned]"
SET NPIEN=0
+16 KILL @TPLIST,@TPERR
+17 QUIT NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN
+18 ;
FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ;
+1 ;START - patient team assignment position ien
+2 ;NODE - patient team position assignment node
+3 ;TPIEN - team position ien (404.57)
+4 ;POS - team position
+5 ;TPNODE - team position node (404.57)
+6 ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN
+7 ;ROLN - role name
+8 ;PCAP - PC/AP/NPC assignment?
+9 ;PRCN - preceptor name
+10 ;
+11 NEW PTNAME,PID,ADATE
+12 ;patient name
SET PTNAME=$PIECE($GET(^DPT(PIEN,0)),"^")
+13 SET PID=$PIECE($GET(^DPT(PIEN,.36)),"^",3)
SET PID=$TRANSLATE(PID,"-","")
+14 ;9 digit ssn SD*5.3*526 - dmr
+15 ;S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation
+16 ;
+17 ;IHS/ANMC/LJF 11/2/2000
SET PID=$$HRCN^BDGF2(PIEN,+$GET(DUZ(2)))
+18 ;position assignment date - fm format
SET ADATE=$PIECE(NODE,"^",3)
+19 ;convert to external format
+20 IF ADATE'=""
SET ADATE=$TRANSLATE($$FMTE^XLFDT(ADATE,"5DF")," ","0")
+21 ;
+22 ;practitioner name
SET PNAME=$PIECE(PRAC,"^",2)
+23 ;practitioner ien
SET PNIEN=$PIECE(PRAC,"^")
+24 ;
+25 ;ien team file 404.51
SET TIEN=+$PIECE(TPNODE,"^",2)
+26 SET TMN=$GET(^SCTM(404.51,TIEN,0))
+27 IF TMN=""
QUIT
+28 ;team name
SET TNAME=$PIECE(TMN,"^")
+29 ;primary care team 1/0
SET PC=$PIECE(TMN,"^",5)
+30 ;institution ien
SET IIEN=+$PIECE(TMN,"^",7)
+31 ;institution
SET INAME=$PIECE($GET(^DIC(4,IIEN,0)),"^")
+32 ;
+33 DO FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
+34 QUIT
+35 ;
FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ;
+1 ;IIEN - institution ien
+2 ;INAME - institution name
+3 ;TNAME - team name
+4 ;TIEN - team ien
+5 ;PC - primary care 1/0
+6 ;PTNAME - patient name
+7 ;PID - last 4 pid plus 5th pseudo
+8 ;PNAME - practitioner name
+9 ;PIEN - practitioner ien
+10 ;POS - position name
+11 ;TPIEN - position ien
+12 ;ADATE - assignment date
+13 ;PTIEN - patient ien
+14 ;ROLN - role name
+15 ;PCAP - PC/AP/NPC assignment?
+16 ;PRCN - preceptor name
+17 ;
+18 IF INAME=""
SET INAME="[BAD DATA]"
+19 IF TNAME=""
SET TNAME="[BAD DATA]"
+20 IF PNAME=""
SET PNAME="[BAD DATA]"
+21 IF '$DATA(@STORE@("I",INAME,IIEN))
SET @STORE@("I",INAME,IIEN)=""
+22 IF '$DATA(@STORE@("T",IIEN,TNAME,TIEN))
SET @STORE@("T",IIEN,TNAME,TIEN)=""
+23 IF '$DATA(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN))
SET @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)=""
+24 SET @STORE@(IIEN)="Division: "_INAME
+25 SET @STORE@(IIEN,TIEN)="Team: "_TNAME
+26 SET $EXTRACT(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$SELECT(PC=1:"YES",1:"NO")
+27 ;
+28 SET @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$EXTRACT(PTNAME,1,17)
+29 ;S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID ;IHS/ANMC/LJF 11/2/2000
+30 ;IHS/ANMC/LJF 11/2/2000
SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),23)=PID
+31 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE
+32 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP
+33 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$EXTRACT(PNAME,1,21)
+34 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$EXTRACT(POS,1,20)
+35 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$EXTRACT(ROLN,1,20)
+36 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$EXTRACT(PRCN,1,20)
+37 QUIT
+38 ;
NOTA(PTIEN,PIEN) ;
+1 ;PTIEN - patient team assignment (#404.42)
+2 ;PIEN - patient ien
+3 NEW IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN
+4 NEW ROLN,PCAP,PRCN,ADATE
+5 SET POS="[Not Assigned]"
SET POSIEN=0
+6 SET PNAME="[Not Assigned]"
SET PNIEN=0
+7 SET (ROLN,PCAP,PRCN,ADATE)=""
+8 ;
+9 ;patient name
SET PTNAME=$EXTRACT($PIECE($GET(^DPT(PIEN,0)),"^"),1,20)
+10 SET PID=$PIECE($GET(^DPT(PIEN,.36)),"^",3)
SET PID=$TRANSLATE(PID,"-","")
+11 ;S PID=$E(PID,6,10) ;9 digit ssn patch 526
+12 ;
+13 ;team ien
SET TIEN=+$PIECE($GET(^SCPT(404.42,PTIEN,0)),"^",3)
+14 SET TMN=$GET(^SCTM(404.51,TIEN,0))
+15 IF TMN=""
QUIT
+16 ;team name
SET TNAME=$PIECE(TMN,"^")
+17 ;primary care team 1/0
SET PC=$PIECE(TMN,"^",5)
+18 ;institution ien
SET IIEN=+$PIECE(TMN,"^",7)
+19 ;institution name
SET INAME=$PIECE($GET(^DIC(4,IIEN,0)),"^")
+20 ;
+21 DO FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
+22 QUIT
