- 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 Jan 18, 2025@03:44:03 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