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,MJE - PCMM/MH API ;04/01/2024
  1. ;;5.3;Scheduling;**575,603,877**;AUG 13, 1993;Build 14
  1. ;;Per VHA Directive 6402, this routine should not be modified
  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. ;ICR #5697 - PCMM MHTC API's for CPRS
  1. ;
  1. ;Input - DFN
  1. ;Output - IEN^MHTC^Team Position^Role^Team
  1. ;
  1. START(DFN) ; Get patient MHTC info.
  1. Q:'$G(DFN) 0
  1. N ACT,IEN,PNAM,PRO,TIEM,TPUR,TEAM
  1. N TP,TPR,TPRIEN,ADATE,UDATE,SAVE,NP,TNAM,SCNOW
  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. ..S SCNOW=$$NOW^XLFDT() ;603
  1. ..Q:ADATE>SCNOW ;603
  1. ..Q:UDATE>ADATE&(UDATE<SCNOW) ;603
  1. ..Q:UDATE=ADATE&(UDATE<SCNOW) ;603
  1. ..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("SCMCMHTC",$J,MHTC,CC)
  1. ;
  1. S MHTC="",PIEN="",IEN="",ROLE="",PAIEN="",TPIEN="",TP="",TEAM="",CC=""
  1. K ^TMP("SCMCMHTC",$J)
  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("SCMCMHTC",$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