Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCRPRAC2

SCRPRAC2.m

Go to the documentation of this file.
  1. SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM
  1. ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
  1. ;
  1. ;Practitioner Demographics Report
  1. ;
  1. GATHER(PARRAY,PRAC) ;
  1. ;get practitioner data
  1. N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV
  1. N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS
  1. N PRCPTE,SCDT,SCRATCH
  1. S NXT=0
  1. F S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N) D
  1. .S (PNAME,PHONE,SERV,ROOM)=""
  1. .D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV)
  1. .;get provider name, office phone, room, service/section, person class
  1. .;
  1. .S ANODE=$G(@PARRAY@(NXT))
  1. .Q:ANODE=""
  1. .S PIEN=+$P(ANODE,"^") ;position ien
  1. .;
  1. .;Get precepted provider information
  1. .S PRCPCNT=0
  1. .S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0
  1. .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)"
  1. .S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0
  1. .F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D
  1. ..N SCPRCD,SCTP
  1. ..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3)
  1. ..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]"
  1. ..S PRCPOS=$P($G(SCRATCH(1)),U,4)
  1. ..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0)
  1. ..S PRCPCNT=PRCPCNT+PRCPCT
  1. ..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT
  1. ..Q
  1. .;
  1. .S POS=$P(ANODE,"^",2) ;position name
  1. .S STROL=$P(ANODE,"^",8) ;standard role name
  1. .S USCL=$P(ANODE,"^",10) ;user class name
  1. .S NODE=$G(^SCTM(404.57,PIEN,0))
  1. .S MAX=$P(NODE,"^",8) ;max patient assignments to position
  1. .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients
  1. .N CNAME,SCCLIEN
  1. .D SETASCL(PIEN,.CNAME,.SCCLIEN) ;associated clinics
  1. .;
  1. .;Get preceptor
  1. .S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2)
  1. .;
  1. .S TIEN=+$P(ANODE,"^",3) ;team ien
  1. .S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
  1. .;
  1. .;Set array for output
  1. .S SCLN=0
  1. .D SET1("Name",PNAME),SET2("Serv./Sect.",SERV)
  1. .D SET1("Team",TNAME),SET2("Position",POS)
  1. .D SET1("Role",STROL),SET2("User Class",USCL)
  1. .D SET1("Room",ROOM),SET2("Pts. Allowed",MAX)
  1. .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN)
  1. .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP)
  1. .D SET3(4,"Assoc. Clinic: ")
  1. .D SETCNAME(.CNAME)
  1. .I $L(PCLASS(1)) D
  1. ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D
  1. ..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D
  1. ...I $L(PCLASS(3)) D SET3(18,PCLASS(3))
  1. ...Q
  1. ..Q
  1. .Q:'$D(^TMP("SCRATCH",$J))
  1. .D SET3(1,"")
  1. .D SET4("Precepted Provider","Precepted Position","Pts. Precepted")
  1. .S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14))
  1. .S PRCPTE="" F S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE="" D
  1. ..S SCTP=0 F S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP D
  1. ...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP)
  1. ...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U)
  1. ...D SET4(PRCPTE,PRCPOS,PRCPCT_" ")
  1. ...Q
  1. ..Q
  1. .D SET3(1,"") S SCI=" Total precepted patients: "_PRCPCNT
  1. .S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42)
  1. .D SET3(1,SCI)
  1. .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J)
  1. .Q
  1. Q
  1. ;
  1. SETASCL(PIEN,CNAME,SCCLIEN) ;SET ASSOCIATED CLINICS
  1. N I,CNT1
  1. S CNT1=0,I=0
  1. F S I=$O(^SCTM(404.57,PIEN,5,I)) Q:'I D
  1. .S SCCLIEN(CNT1)=I,CNAME(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+1
  1. Q
  1. SET1(LABEL,VALUE) ;Set output line
  1. S SCLN=SCLN+1
  1. S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26)
  1. Q
  1. ;
  1. SET2(LABEL,VALUE) ;Set second column of output line
  1. S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26)
  1. Q
  1. ;
  1. SET3(COL,VALUE) ;Set output line
  1. N SCX
  1. S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1)))
  1. S @STORE@(PNAME,PIEN,SCLN)=SCX
  1. Q
  1. ;
  1. SET4(V1,V2,V3) ;Set output line
  1. S SCLN=SCLN+1,V1=" "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14)
  1. S @STORE@(PNAME,PIEN,SCLN)=V1
  1. Q
  1. ;
  1. SETCNAME(CNAME) ;associated clinics
  1. N A
  1. S A="" F S A=$O(CNAME(A)) Q:A="" D SET3(12,CNAME(A))
  1. Q
  1. ;
  1. PINFO(VAE,PRACT,OPH,ROOM,SERV) ;
  1. ;practitioner information from new person file
  1. S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
  1. S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone
  1. S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room
  1. S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien
  1. S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name
  1. S PCLASS=$$GET^XUA4A72(VAE) ;Person class
  1. N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1))
  1. Q