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

SCMCMHTC.m

Go to the documentation of this file. 
  1. SCMCMHTC ;BP/DMR - PCMM/MH API; 4 JAN 11
  1.  ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
  1.  ;
  1.  ;This API provides the Mental Health Treatment Coordinator
  1.  ;from PCMM for display in CPRS, or used as a stand alone API.
  1.  ;
  1.  ;Input  - DFN
  1.  ;Output - IEN^MHTC^Team Position^Role^Team
  1.  ;
  1. START(DFN) ; Get patient MHTC info.
  1.  Q:'$G(DFN)
  1.  N ACT,IEN,PNAM,PRO,TIEM,TPUR,TEAM
  1.  N TP,TPR,TPRIEN,ADATE,UDATE,SAVE,NP,TNAM
  1.  S MHTC="",SAVE=""
  1.  ;
  1.  S IEN="" F  S IEN=$O(^SCPT(404.42,"B",DFN,IEN)) Q:IEN=""!(SAVE=1)  D
  1.  .S TIEM="" S TIEM=$P($G(^SCPT(404.42,IEN,0)),"^",3) Q:TIEM=""
  1.  .Q:$$GET1^DIQ(404.51,TIEM,.03)'="MENTAL HEALTH TREATMENT"
  1.  .S TPIEN="" F  S TPIEN=$O(^SCPT(404.43,"B",IEN,TPIEN)) Q:TPIEN=""!(SAVE=1)  D
  1.  ..S TPRIEN="",TPRIEN=$$GET1^DIQ(404.43,TPIEN,.02,"I") Q:TPRIEN=""
  1.  ..S TPR="",TPR=$$GET1^DIQ(404.57,TPRIEN,.03) Q:TPR=""
  1.  ..Q:TPR'["(MHTC)"  S TP="",TP=$$GET1^DIQ(404.57,TPRIEN,.01) Q:TP=""
  1.  ..S PRO="",PRO=$O(^SCTM(404.52,"B",TPRIEN,PRO),-1) Q:PRO=""
  1.  ..S ACT="",ACT=$$GET1^DIQ(404.52,PRO,.04,"I") Q:ACT'=1
  1.  ..S PNAM="",PNAM=$$GET1^DIQ(404.52,PRO,.03) Q:PNAM=""
  1.  ..S ADATE="",ADATE=$$GET1^DIQ(404.43,TPIEN,.03,"I")
  1.  ..S UDATE="",UDATE=$$GET1^DIQ(404.43,TPIEN,.04,"I")
  1.  ..Q:ADATE>DT  Q:UDATE>ADATE&(UDATE<DT)  Q:UDATE=ADATE&(UDATE<DT)  D SAVE
  1.  I $G(CPRSGUI) D PRINT Q
  1.  Q MHTC
  1.  ;
  1. SAVE ;Save MHTC info.
  1.  ;
  1.  S MHTC="",SAVE="",NP="",TNAM=""
  1.  S NP=$$GET1^DIQ(404.52,PRO,.03,"I")
  1.  S TNAM=$$GET1^DIQ(404.51,TIEM,.01)
  1.  S $P(MHTC,"^",1)=NP
  1.  S $P(MHTC,"^",2)=PNAM
  1.  S $P(MHTC,"^",3)=TP
  1.  S $P(MHTC,"^",4)=TPR
  1.  S $P(MHTC,"^",5)=TNAM
  1.  S SAVE=1
  1.  Q
  1.  ;
  1. PRINT ;Display in CPRS Patient Inquiry.
  1.  ;
  1.  Q:'$G(CPRSGUI)
  1.  N PH,PAG,DPAG
  1.  Q:'+$G(NP)
  1.  Q:PNAM=""
  1.  Q:TP=""
  1.  S PH=$$GET1^DIQ(200,NP,.132),PAG=$$GET1^DIQ(200,NP,.137),DPAG=$$GET1^DIQ(200,NP,.138)
  1.  W !!," MH Treatment Team: ",TNAM
  1.  W !,"MH Treatment Coord: ",$E(PNAM,1,28),?52,"Position: ",$E(TP,1,18)
  1.  W !,"                  Analog Pager: ",PAG,?55,"Phone: ",PH
  1.  W !,"                 Digital Pager: ",DPAG
  1.  Q
  1.  ;
  1. LIST ;List of all active MHTC's from PCMM to CPRS.
  1.  ;
  1.  ;Output Fields - PIEN^MHTC^Role^Team Position^Team
  1.  ;Output Global - ^TMP("MHTC",$J,MHTC,CC)
  1.  ;
  1.  S MHTC="",PIEN="",IEN="",ROLE="",PAIEN="",TPIEN="",TP="",TEAM="",CC=""
  1.  K ^TMP("MHTC")
  1.  ;
  1.  S IEN="" F  S IEN=$O(^SCTM(404.52,"B",IEN)) Q:IEN=""  D
  1.  .S PAIEN="" F  S PAIEN=$O(^SCTM(404.52,"B",IEN,PAIEN)) Q:PAIEN=""  D
  1.  ..Q:$$GET1^DIQ(404.52,PAIEN,.04,"I")'=1
  1.  ..S TPIEN="",TPIEN=$$GET1^DIQ(404.52,PAIEN,.01,"I") Q:TPIEN=""
  1.  ..S ROLE="",ROLE=$$GET1^DIQ(404.57,TPIEN,.03) Q:ROLE'["(MHTC)"
  1.  ..S MHTC="",MHTC=$$GET1^DIQ(404.52,PAIEN,.03) Q:MHTC="" 
  1.  ..S PIEN="",PIEN=$$GET1^DIQ(404.52,PAIEN,.03,"I")
  1.  ..S TP="",TP=$$GET1^DIQ(404.57,TPIEN,.01)
  1.  ..S TEAM="",TEAM=$$GET1^DIQ(404.57,TPIEN,.02)
  1.  ..S CC=CC+1 S ^TMP("MHTC",$J,MHTC,CC)=PIEN_"^"_MHTC_"^"_ROLE_"^"_TP_"^"_TEAM
  1.  ..Q
  1.  D EXIT
  1.  Q
  1.  ;
  1. EXIT ;
  1.  K PIEN,ROLE,PAIEN,TP,TEAM,CC,MHTC,IEN,TPIEN
  1.  Q