SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
;
;Practitioner Demographics Report
;
GATHER(PARRAY,PRAC) ;
;get practitioner data
N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV
N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS
N PRCPTE,SCDT,SCRATCH
S NXT=0
F S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N) D
.S (PNAME,PHONE,SERV,ROOM)=""
.D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV)
.;get provider name, office phone, room, service/section, person class
.;
.S ANODE=$G(@PARRAY@(NXT))
.Q:ANODE=""
.S PIEN=+$P(ANODE,"^") ;position ien
.;
.;Get precepted provider information
.S PRCPCNT=0
.S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0
.K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)"
.S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0
.F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D
..N SCPRCD,SCTP
..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3)
..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]"
..S PRCPOS=$P($G(SCRATCH(1)),U,4)
..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0)
..S PRCPCNT=PRCPCNT+PRCPCT
..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT
..Q
.;
.S POS=$P(ANODE,"^",2) ;position name
.S STROL=$P(ANODE,"^",8) ;standard role name
.S USCL=$P(ANODE,"^",10) ;user class name
.S NODE=$G(^SCTM(404.57,PIEN,0))
.S MAX=$P(NODE,"^",8) ;max patient assignments to position
.S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients
.N CNAME,SCCLIEN
.D SETASCL(PIEN,.CNAME,.SCCLIEN) ;associated clinics
.;
.;Get preceptor
.S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2)
.;
.S TIEN=+$P(ANODE,"^",3) ;team ien
.S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
.;
.;Set array for output
.S SCLN=0
.D SET1("Name",PNAME),SET2("Serv./Sect.",SERV)
.D SET1("Team",TNAME),SET2("Position",POS)
.D SET1("Role",STROL),SET2("User Class",USCL)
.D SET1("Room",ROOM),SET2("Pts. Allowed",MAX)
.D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN)
.I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP)
.D SET3(4,"Assoc. Clinic: ")
.D SETCNAME(.CNAME)
.I $L(PCLASS(1)) D
..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D
..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D
...I $L(PCLASS(3)) D SET3(18,PCLASS(3))
...Q
..Q
.Q:'$D(^TMP("SCRATCH",$J))
.D SET3(1,"")
.D SET4("Precepted Provider","Precepted Position","Pts. Precepted")
.S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14))
.S PRCPTE="" F S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE="" D
..S SCTP=0 F S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP D
...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP)
...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U)
...D SET4(PRCPTE,PRCPOS,PRCPCT_" ")
...Q
..Q
.D SET3(1,"") S SCI=" Total precepted patients: "_PRCPCNT
.S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42)
.D SET3(1,SCI)
.K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J)
.Q
Q
;
SETASCL(PIEN,CNAME,SCCLIEN) ;SET ASSOCIATED CLINICS
N I,CNT1
S CNT1=0,I=0
F S I=$O(^SCTM(404.57,PIEN,5,I)) Q:'I D
.S SCCLIEN(CNT1)=I,CNAME(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+1
Q
SET1(LABEL,VALUE) ;Set output line
S SCLN=SCLN+1
S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26)
Q
;
SET2(LABEL,VALUE) ;Set second column of output line
S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26)
Q
;
SET3(COL,VALUE) ;Set output line
N SCX
S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1)))
S @STORE@(PNAME,PIEN,SCLN)=SCX
Q
;
SET4(V1,V2,V3) ;Set output line
S SCLN=SCLN+1,V1=" "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14)
S @STORE@(PNAME,PIEN,SCLN)=V1
Q
;
SETCNAME(CNAME) ;associated clinics
N A
S A="" F S A=$O(CNAME(A)) Q:A="" D SET3(12,CNAME(A))
Q
;
PINFO(VAE,PRACT,OPH,ROOM,SERV) ;
;practitioner information from new person file
S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone
S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room
S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien
S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name
S PCLASS=$$GET^XUA4A72(VAE) ;Person class
N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPRAC2 4333 printed Apr 09, 2024@21:51:26 Page 2
SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
+2 ;
+3 ;Practitioner Demographics Report
+4 ;
GATHER(PARRAY,PRAC) ;
+1 ;get practitioner data
+2 NEW ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV
+3 NEW NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS
+4 NEW PRCPTE,SCDT,SCRATCH
+5 SET NXT=0
+6 FOR
SET NXT=$ORDER(@PARRAY@(NXT))
if NXT=""!(NXT'?.N)
QUIT
Begin DoDot:1
+7 SET (PNAME,PHONE,SERV,ROOM)=""
+8 DO PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV)
+9 ;get provider name, office phone, room, service/section, person class
+10 ;
+11 SET ANODE=$GET(@PARRAY@(NXT))
+12 if ANODE=""
QUIT
+13 ;position ien
SET PIEN=+$PIECE(ANODE,"^")
+14 ;
+15 ;Get precepted provider information
+16 SET PRCPCNT=0
+17 SET SCDT="SCDT"
SET (SCDT("BEGIN"),SCDT("END"))="DT"
SET SCDT("INCL")=0
+18 KILL ^TMP("SCRATCH",$JOB),^TMP("SCRATCH1",$JOB)
SET SCI="^TMP(""SCRATCH1"",$J)"
+19 SET SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI)
SET SCI=0
+20 FOR
SET SCI=$ORDER(^TMP("SCRATCH1",$JOB,SCI))
if 'SCI
QUIT
Begin DoDot:2
+21 NEW SCPRCD,SCTP
+22 SET SCPRCD=^TMP("SCRATCH1",$JOB,SCI)
SET SCTP=$PIECE(SCPRCD,U,3)
+23 SET PRCPTE=$PIECE(SCPRCD,U,2)
if '$LENGTH(PRCPTE)
SET PRCPTE="[unknown]"
+24 SET PRCPOS=$PIECE($GET(SCRATCH(1)),U,4)
+25 SET PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0)
+26 SET PRCPCNT=PRCPCNT+PRCPCT
+27 SET ^TMP("SCRATCH",$JOB,PRCPTE,SCTP)=PRCPOS_U_PRCPCT
+28 QUIT
End DoDot:2
+29 ;
+30 ;position name
SET POS=$PIECE(ANODE,"^",2)
+31 ;standard role name
SET STROL=$PIECE(ANODE,"^",8)
+32 ;user class name
SET USCL=$PIECE(ANODE,"^",10)
+33 SET NODE=$GET(^SCTM(404.57,PIEN,0))
+34 ;max patient assignments to position
SET MAX=$PIECE(NODE,"^",8)
+35 ;assigned patients
SET ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0)
+36 NEW CNAME,SCCLIEN
+37 ;associated clinics
DO SETASCL(PIEN,.CNAME,.SCCLIEN)
+38 ;
+39 ;Get preceptor
+40 SET PRCP=$PIECE($$OKPREC2^SCMCLK(PIEN,DT),U,2)
+41 ;
+42 ;team ien
SET TIEN=+$PIECE(ANODE,"^",3)
+43 ;team name
SET TNAME=$PIECE($GET(^SCTM(404.51,TIEN,0)),"^")
+44 ;
+45 ;Set array for output
+46 SET SCLN=0
+47 DO SET1("Name",PNAME)
DO SET2("Serv./Sect.",SERV)
+48 DO SET1("Team",TNAME)
DO SET2("Position",POS)
+49 DO SET1("Role",STROL)
DO SET2("User Class",USCL)
+50 DO SET1("Room",ROOM)
DO SET2("Pts. Allowed",MAX)
+51 DO SET1("Phone",PHONE)
DO SET2("Pts. Assigned",ASSIGN)
+52 IF $LENGTH($GET(PRCP))
DO SET3(1,"Preceptor: "_PRCP)
+53 DO SET3(4,"Assoc. Clinic: ")
+54 DO SETCNAME(.CNAME)
+55 IF $LENGTH(PCLASS(1))
Begin DoDot:2
+56 DO SET3(4,"Person")
DO SET3(5,"Class: "_PCLASS(1))
Begin DoDot:3
End DoDot:3
+57 IF $LENGTH(PCLASS(2))
DO SET3(15,PCLASS(2))
Begin DoDot:3
+58 IF $LENGTH(PCLASS(3))
DO SET3(18,PCLASS(3))
+59 QUIT
End DoDot:3
+60 QUIT
End DoDot:2
+61 if '$DATA(^TMP("SCRATCH",$JOB))
QUIT
+62 DO SET3(1,"")
+63 DO SET4("Precepted Provider","Precepted Position","Pts. Precepted")
+64 SET SCI=""
SET $PIECE(SCI,"-",31)=""
DO SET4(SCI,SCI,$EXTRACT(SCI,1,14))
+65 SET PRCPTE=""
FOR
SET PRCPTE=$ORDER(^TMP("SCRATCH",$JOB,PRCPTE))
if PRCPTE=""
QUIT
Begin DoDot:2
+66 SET SCTP=0
FOR
SET SCTP=$ORDER(^TMP("SCRATCH",$JOB,PRCPTE,SCTP))
if 'SCTP
QUIT
Begin DoDot:3
+67 SET PRCPOS=^TMP("SCRATCH",$JOB,PRCPTE,SCTP)
+68 SET PRCPCT=+$PIECE(PRCPOS,U,2)
SET PRCPOS=$PIECE(PRCPOS,U)
+69 DO SET4(PRCPTE,PRCPOS,PRCPCT_" ")
+70 QUIT
End DoDot:3
+71 QUIT
End DoDot:2
+72 DO SET3(1,"")
SET SCI=" Total precepted patients: "_PRCPCNT
+73 SET $EXTRACT(SCI,37)=$JUSTIFY(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42)
+74 DO SET3(1,SCI)
+75 KILL ^TMP("SCRATCH",$JOB),^TMP("SCRATCH1",$JOB)
+76 QUIT
End DoDot:1
+77 QUIT
+78 ;
SETASCL(PIEN,CNAME,SCCLIEN) ;SET ASSOCIATED CLINICS
+1 NEW I,CNT1
+2 SET CNT1=0
SET I=0
+3 FOR
SET I=$ORDER(^SCTM(404.57,PIEN,5,I))
if 'I
QUIT
Begin DoDot:1
+4 SET SCCLIEN(CNT1)=I
SET CNAME(CNT1)=$PIECE($GET(^SC(I,0)),U)
SET CNT1=CNT1+1
End DoDot:1
+5 QUIT
SET1(LABEL,VALUE) ;Set output line
+1 SET SCLN=SCLN+1
+2 SET @STORE@(PNAME,PIEN,SCLN)=$JUSTIFY(LABEL,9)_": "_$EXTRACT(VALUE,1,26)
+3 QUIT
+4 ;
SET2(LABEL,VALUE) ;Set second column of output line
+1 SET $EXTRACT(@STORE@(PNAME,PIEN,SCLN),40)=$JUSTIFY(LABEL,13)_": "_$EXTRACT(VALUE,1,26)
+2 QUIT
+3 ;
SET3(COL,VALUE) ;Set output line
+1 NEW SCX
+2 SET SCLN=SCLN+1
SET SCX=""
SET $EXTRACT(SCX,COL)=$EXTRACT(VALUE,1,(80-(COL-1)))
+3 SET @STORE@(PNAME,PIEN,SCLN)=SCX
+4 QUIT
+5 ;
SET4(V1,V2,V3) ;Set output line
+1 SET SCLN=SCLN+1
SET V1=" "_V1
SET $EXTRACT(V1,35)=V2
SET $EXTRACT(V1,67)=$JUSTIFY(V3,14)
+2 SET @STORE@(PNAME,PIEN,SCLN)=V1
+3 QUIT
+4 ;
SETCNAME(CNAME) ;associated clinics
+1 NEW A
+2 SET A=""
FOR
SET A=$ORDER(CNAME(A))
if A=""
QUIT
DO SET3(12,CNAME(A))
+3 QUIT
+4 ;
PINFO(VAE,PRACT,OPH,ROOM,SERV) ;
+1 ;practitioner information from new person file
+2 ;practitioner name
SET PRACT=$PIECE($GET(^VA(200,VAE,0)),"^")
+3 ;office phone
SET OPH=$PIECE($GET(^VA(200,VAE,.13)),"^",2)
+4 ;room
SET ROOM=$PIECE($GET(^VA(200,VAE,.14)),"^")
+5 ;service/section ien
SET SERV=$PIECE($GET(^VA(200,VAE,5)),"^")
+6 ;service/section name
SET SERV=$PIECE($GET(^DIC(49,+SERV,0)),"^")
+7 ;Person class
SET PCLASS=$$GET^XUA4A72(VAE)
+8 NEW SCI
FOR SCI=1,2,3
SET PCLASS(SCI)=$PIECE(PCLASS,U,(SCI+1))
+9 QUIT
