- 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**;AUG 13, 1993;Build 8
- ;
- ;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 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),19)=PID
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPTA2 5698 printed Jan 18, 2025@03:44:06 Page 2
- 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**;AUG 13, 1993;Build 8
- +2 ;
- +3 ;Patient Listing w/Team Assignment Data Report continued
- +4 ;
- 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 ;position assignment date - fm format
- SET ADATE=$PIECE(NODE,"^",3)
- +18 ;convert to external format
- +19 IF ADATE'=""
- SET ADATE=$TRANSLATE($$FMTE^XLFDT(ADATE,"5DF")," ","0")
- +20 ;
- +21 ;practitioner name
- SET PNAME=$PIECE(PRAC,"^",2)
- +22 ;practitioner ien
- SET PNIEN=$PIECE(PRAC,"^")
- +23 ;
- +24 ;ien team file 404.51
- SET TIEN=+$PIECE(TPNODE,"^",2)
- +25 SET TMN=$GET(^SCTM(404.51,TIEN,0))
- +26 if TMN=""
- QUIT
- +27 ;team name
- SET TNAME=$PIECE(TMN,"^")
- +28 ;primary care team 1/0
- SET PC=$PIECE(TMN,"^",5)
- +29 ;institution ien
- SET IIEN=+$PIECE(TMN,"^",7)
- +30 ;institution
- SET INAME=$PIECE($GET(^DIC(4,IIEN,0)),"^")
- +31 ;
- +32 DO FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
- +33 QUIT
- +34 ;
- 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 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),19)=PID
- +30 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE
- +31 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP
- +32 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$EXTRACT(PNAME,1,21)
- +33 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$EXTRACT(POS,1,20)
- +34 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$EXTRACT(ROLN,1,20)
- +35 SET $EXTRACT(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$EXTRACT(PRCN,1,20)
- +36 QUIT
- +37 ;
- 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