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

SCRPTP3.m

Go to the documentation of this file. 
  1. SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
  1.  ;;5.3;Scheduling;**41,48,98,177,231,433,526,520**;AUG 13, 1993;Build 26
  1.  ;;DMR BP-OIFO Patch SD*5.3*526
  1.  ;
  1.  ;List of Team's Patients Report
  1.  ;
  1. HITS(ARRY,TIEN) ;
  1.  ;ARRY - list of patients for a given team
  1.  ;TIEN - team ien
  1.  ;
  1.  N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT
  1.  N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE
  1.  N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN
  1.  S INACTIVE=0
  1.  S NXT=0
  1.  F  S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N)  D
  1.  .S NODE=$G(@ARRY@(NXT))
  1.  .Q:NODE=""
  1.  .S PTIEN=+$P(NODE,"^") ;patient ien
  1.  .S PTNAME=$P(NODE,"^",2) ;patient name
  1.  .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42)
  1.  .;
  1.  .S PNODE=$G(^DPT(PTIEN,0))
  1.  .Q:PNODE=""
  1.  .S DFN=PTIEN
  1.  .D PID^VADPT6
  1.  .;S PID=VA("BID")
  1.  .S PID=$E(VA("PID"),1,3)_$E(VA("PID"),5,6)_$E(VA("PID"),8,12)
  1.  .;
  1.  .N CNAME,PINF,CLIEN
  1.  .S CNT=""
  1.  .F  S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N)  D
  1.  ..D TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP)
  1.  Q
  1.  ;
  1. TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ;
  1.  N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN
  1.  I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]"
  1.  ; ^ no patient team position assignment
  1.  IF START="" D
  1.  .S PTPA=$O(^SCPT(404.43,"B",PTAI,START))
  1.  ELSE  D
  1.  .S PTPA=START
  1.  I PTPA="" Q "0^[Not Assigned]"
  1.  S PTPAN=$G(^SCPT(404.43,PTPA,0))  ;patient team assignment
  1.  I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]"
  1.  I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1
  1.  S TPIEN=+$P(PTPAN,"^",2) ;team position ien (#404.57)
  1.  I '$D(^SCTM(404.57,TPIEN,0)) Q "0^[Not Assigned]"
  1.  S TPNODE=$G(^SCTM(404.57,TPIEN,0))
  1.  I TPNODE="" Q "0^[Not Assigned]"
  1.  S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
  1.  Q:'$D(ROLE(ROL))&(ROLE'=1) -1
  1.  ; ^ not a selected role
  1.  S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
  1.  ;
  1.  S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC?
  1.  ;
  1.  D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN)
  1.  ;next two lines commented off - SD*5.3*433
  1.  ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
  1.  ;I 'ENROLL S CNAME="",CIEN=0
  1.  ;
  1.  S PAIEN=$$CHK(TPIEN)
  1.  I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name
  1.  ;SD*5.3*231
  1.  I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]"
  1.  ;
  1.  D GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF)  ;get patient info
  1.  S CNAME=$G(CNAME(0))
  1.  S PINF=$G(PINF(0))
  1.  I PINF="" D
  1.  .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
  1.  I INACTIVE S @STORE@(INS,TIEN,"INACT")=""
  1.  S FLAG="Y"
  1.  S TINFO=$$TINF^SCRPTP(TIEN) ;team information
  1.  S INST=+$P(TINFO,"^") ;institution ien
  1.  S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
  1.  S PHONE=$P(TINFO,"^",4) ;team phone
  1.  S PC=$P(TINFO,"^",3) ;primary care?
  1.  S TNAME=$P(TINFO,"^",2) ;team name
  1.  D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
  1.  D FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP)
  1.  N SCCNT
  1.  S SCCNT=0 F  S SCCNT=$O(CNAME(SCCNT)) Q:SCCNT=""  D FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP)
  1.  Q
  1.  ;
  1. ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED
  1.  ;
  1.  ;N FOUND,ENODE,EN,NXT
  1.  ;S FOUND=0
  1.  ;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
  1.  ;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
  1.  ;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
  1.  ;S NXT=""
  1.  ;F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D
  1.  ;check if active enrollment
  1.  ;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
  1.  ;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment
  1.  ;;                      ^ discharge date     ^ enrollment date
  1.  S FOUND=0
  1.  Q FOUND
  1.  ;
  1. CHK(TPIEN) ;assigned to a position
  1.  ;TPIEN - ien of 404.57 Team Position file
  1.  ;returns:  ien of 200 New Person file
  1.  N EN,PLIST,PERR,ERR,NAME
  1.  S PLIST="PLST",PERR="PRR"
  1.  K @PLIST,@PERR
  1.  S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR)
  1.  I '$D(@PERR) D
  1.  .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file
  1.  .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name
  1.  K @PLIST,@PERR
  1.  Q EN_"^"_NAME
  1.  ;