SCMCMHTC ;BP/DMR,MJE - PCMM/MH API ;04/01/2024
;;5.3;Scheduling;**575,603,877**;AUG 13, 1993;Build 14
;;Per VHA Directive 6402, this routine should not be modified
;
;This API provides the Mental Health Treatment Coordinator
;from PCMM for display in CPRS, or used as a stand alone API.
;ICR #5697 - PCMM MHTC API's for CPRS
;
;Input - DFN
;Output - IEN^MHTC^Team Position^Role^Team
;
START(DFN) ; Get patient MHTC info.
Q:'$G(DFN) 0
N ACT,IEN,PNAM,PRO,TIEM,TPUR,TEAM
N TP,TPR,TPRIEN,ADATE,UDATE,SAVE,NP,TNAM,SCNOW
S MHTC="",SAVE=""
;
S IEN="" F S IEN=$O(^SCPT(404.42,"B",DFN,IEN)) Q:IEN=""!(SAVE=1) D
.S TIEM="" S TIEM=$P($G(^SCPT(404.42,IEN,0)),"^",3) Q:TIEM=""
.Q:$$GET1^DIQ(404.51,TIEM,.03)'="MENTAL HEALTH TREATMENT"
.S TPIEN="" F S TPIEN=$O(^SCPT(404.43,"B",IEN,TPIEN)) Q:TPIEN=""!(SAVE=1) D
..S TPRIEN="",TPRIEN=$$GET1^DIQ(404.43,TPIEN,.02,"I") Q:TPRIEN=""
..S TPR="",TPR=$$GET1^DIQ(404.57,TPRIEN,.03) Q:TPR=""
..Q:TPR'["(MHTC)" S TP="",TP=$$GET1^DIQ(404.57,TPRIEN,.01) Q:TP=""
..S PRO="",PRO=$O(^SCTM(404.52,"B",TPRIEN,PRO),-1) Q:PRO=""
..S ACT="",ACT=$$GET1^DIQ(404.52,PRO,.04,"I") Q:ACT'=1
..S PNAM="",PNAM=$$GET1^DIQ(404.52,PRO,.03) Q:PNAM=""
..S ADATE="",ADATE=$$GET1^DIQ(404.43,TPIEN,.03,"I")
..S UDATE="",UDATE=$$GET1^DIQ(404.43,TPIEN,.04,"I")
..;Q:ADATE>DT Q:UDATE>ADATE&(UDATE<DT) Q:UDATE=ADATE&(UDATE<DT) D SAVE
..S SCNOW=$$NOW^XLFDT() ;603
..Q:ADATE>SCNOW ;603
..Q:UDATE>ADATE&(UDATE<SCNOW) ;603
..Q:UDATE=ADATE&(UDATE<SCNOW) ;603
..D SAVE
I $G(CPRSGUI) D PRINT Q
Q MHTC
;
SAVE ;Save MHTC info.
;
S MHTC="",SAVE="",NP="",TNAM=""
S NP=$$GET1^DIQ(404.52,PRO,.03,"I")
S TNAM=$$GET1^DIQ(404.51,TIEM,.01)
S $P(MHTC,"^",1)=NP
S $P(MHTC,"^",2)=PNAM
S $P(MHTC,"^",3)=TP
S $P(MHTC,"^",4)=TPR
S $P(MHTC,"^",5)=TNAM
S SAVE=1
Q
;
PRINT ;Display in CPRS Patient Inquiry.
;
Q:'$G(CPRSGUI)
N PH,PAG,DPAG
Q:'+$G(NP)
Q:PNAM=""
Q:TP=""
S PH=$$GET1^DIQ(200,NP,.132),PAG=$$GET1^DIQ(200,NP,.137),DPAG=$$GET1^DIQ(200,NP,.138)
W !!," MH Treatment Team: ",TNAM
W !,"MH Treatment Coord: ",$E(PNAM,1,28),?52,"Position: ",$E(TP,1,18)
W !," Analog Pager: ",PAG,?55,"Phone: ",PH
W !," Digital Pager: ",DPAG
Q
;
LIST ;List of all active MHTC's from PCMM to CPRS.
;
;Output Fields - PIEN^MHTC^Role^Team Position^Team
;Output Global - ^TMP("SCMCMHTC",$J,MHTC,CC)
;
S MHTC="",PIEN="",IEN="",ROLE="",PAIEN="",TPIEN="",TP="",TEAM="",CC=""
K ^TMP("SCMCMHTC",$J)
;
S IEN="" F S IEN=$O(^SCTM(404.52,"B",IEN)) Q:IEN="" D
.S PAIEN="" F S PAIEN=$O(^SCTM(404.52,"B",IEN,PAIEN)) Q:PAIEN="" D
..Q:$$GET1^DIQ(404.52,PAIEN,.04,"I")'=1
..S TPIEN="",TPIEN=$$GET1^DIQ(404.52,PAIEN,.01,"I") Q:TPIEN=""
..S ROLE="",ROLE=$$GET1^DIQ(404.57,TPIEN,.03) Q:ROLE'["(MHTC)"
..S MHTC="",MHTC=$$GET1^DIQ(404.52,PAIEN,.03) Q:MHTC=""
..S PIEN="",PIEN=$$GET1^DIQ(404.52,PAIEN,.03,"I")
..S TP="",TP=$$GET1^DIQ(404.57,TPIEN,.01)
..S TEAM="",TEAM=$$GET1^DIQ(404.57,TPIEN,.02)
..S CC=CC+1 S ^TMP("SCMCMHTC",$J,MHTC,CC)=PIEN_"^"_MHTC_"^"_ROLE_"^"_TP_"^"_TEAM
..Q
D EXIT
Q
;
EXIT ;
K PIEN,ROLE,PAIEN,TP,TEAM,CC,MHTC,IEN,TPIEN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMHTC 3200 printed Sep 23, 2025@20:17:17 Page 2
SCMCMHTC ;BP/DMR,MJE - PCMM/MH API ;04/01/2024
+1 ;;5.3;Scheduling;**575,603,877**;AUG 13, 1993;Build 14
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ;This API provides the Mental Health Treatment Coordinator
+5 ;from PCMM for display in CPRS, or used as a stand alone API.
+6 ;ICR #5697 - PCMM MHTC API's for CPRS
+7 ;
+8 ;Input - DFN
+9 ;Output - IEN^MHTC^Team Position^Role^Team
+10 ;
START(DFN) ; Get patient MHTC info.
+1 if '$GET(DFN)
QUIT 0
+2 NEW ACT,IEN,PNAM,PRO,TIEM,TPUR,TEAM
+3 NEW TP,TPR,TPRIEN,ADATE,UDATE,SAVE,NP,TNAM,SCNOW
+4 SET MHTC=""
SET SAVE=""
+5 ;
+6 SET IEN=""
FOR
SET IEN=$ORDER(^SCPT(404.42,"B",DFN,IEN))
if IEN=""!(SAVE=1)
QUIT
Begin DoDot:1
+7 SET TIEM=""
SET TIEM=$PIECE($GET(^SCPT(404.42,IEN,0)),"^",3)
if TIEM=""
QUIT
+8 if $$GET1^DIQ(404.51,TIEM,.03)'="MENTAL HEALTH TREATMENT"
QUIT
+9 SET TPIEN=""
FOR
SET TPIEN=$ORDER(^SCPT(404.43,"B",IEN,TPIEN))
if TPIEN=""!(SAVE=1)
QUIT
Begin DoDot:2
+10 SET TPRIEN=""
SET TPRIEN=$$GET1^DIQ(404.43,TPIEN,.02,"I")
if TPRIEN=""
QUIT
+11 SET TPR=""
SET TPR=$$GET1^DIQ(404.57,TPRIEN,.03)
if TPR=""
QUIT
+12 if TPR'["(MHTC)"
QUIT
SET TP=""
SET TP=$$GET1^DIQ(404.57,TPRIEN,.01)
if TP=""
QUIT
+13 SET PRO=""
SET PRO=$ORDER(^SCTM(404.52,"B",TPRIEN,PRO),-1)
if PRO=""
QUIT
+14 SET ACT=""
SET ACT=$$GET1^DIQ(404.52,PRO,.04,"I")
if ACT'=1
QUIT
+15 SET PNAM=""
SET PNAM=$$GET1^DIQ(404.52,PRO,.03)
if PNAM=""
QUIT
+16 SET ADATE=""
SET ADATE=$$GET1^DIQ(404.43,TPIEN,.03,"I")
+17 SET UDATE=""
SET UDATE=$$GET1^DIQ(404.43,TPIEN,.04,"I")
+18 ;Q:ADATE>DT Q:UDATE>ADATE&(UDATE<DT) Q:UDATE=ADATE&(UDATE<DT) D SAVE
+19 ;603
SET SCNOW=$$NOW^XLFDT()
+20 ;603
if ADATE>SCNOW
QUIT
+21 ;603
if UDATE>ADATE&(UDATE<SCNOW)
QUIT
+22 ;603
if UDATE=ADATE&(UDATE<SCNOW)
QUIT
+23 DO SAVE
End DoDot:2
End DoDot:1
+24 IF $GET(CPRSGUI)
DO PRINT
QUIT
+25 QUIT MHTC
+26 ;
SAVE ;Save MHTC info.
+1 ;
+2 SET MHTC=""
SET SAVE=""
SET NP=""
SET TNAM=""
+3 SET NP=$$GET1^DIQ(404.52,PRO,.03,"I")
+4 SET TNAM=$$GET1^DIQ(404.51,TIEM,.01)
+5 SET $PIECE(MHTC,"^",1)=NP
+6 SET $PIECE(MHTC,"^",2)=PNAM
+7 SET $PIECE(MHTC,"^",3)=TP
+8 SET $PIECE(MHTC,"^",4)=TPR
+9 SET $PIECE(MHTC,"^",5)=TNAM
+10 SET SAVE=1
+11 QUIT
+12 ;
PRINT ;Display in CPRS Patient Inquiry.
+1 ;
+2 if '$GET(CPRSGUI)
QUIT
+3 NEW PH,PAG,DPAG
+4 if '+$GET(NP)
QUIT
+5 if PNAM=""
QUIT
+6 if TP=""
QUIT
+7 SET PH=$$GET1^DIQ(200,NP,.132)
SET PAG=$$GET1^DIQ(200,NP,.137)
SET DPAG=$$GET1^DIQ(200,NP,.138)
+8 WRITE !!," MH Treatment Team: ",TNAM
+9 WRITE !,"MH Treatment Coord: ",$EXTRACT(PNAM,1,28),?52,"Position: ",$EXTRACT(TP,1,18)
+10 WRITE !," Analog Pager: ",PAG,?55,"Phone: ",PH
+11 WRITE !," Digital Pager: ",DPAG
+12 QUIT
+13 ;
LIST ;List of all active MHTC's from PCMM to CPRS.
+1 ;
+2 ;Output Fields - PIEN^MHTC^Role^Team Position^Team
+3 ;Output Global - ^TMP("SCMCMHTC",$J,MHTC,CC)
+4 ;
+5 SET MHTC=""
SET PIEN=""
SET IEN=""
SET ROLE=""
SET PAIEN=""
SET TPIEN=""
SET TP=""
SET TEAM=""
SET CC=""
+6 KILL ^TMP("SCMCMHTC",$JOB)
+7 ;
+8 SET IEN=""
FOR
SET IEN=$ORDER(^SCTM(404.52,"B",IEN))
if IEN=""
QUIT
Begin DoDot:1
+9 SET PAIEN=""
FOR
SET PAIEN=$ORDER(^SCTM(404.52,"B",IEN,PAIEN))
if PAIEN=""
QUIT
Begin DoDot:2
+10 if $$GET1^DIQ(404.52,PAIEN,.04,"I")'=1
QUIT
+11 SET TPIEN=""
SET TPIEN=$$GET1^DIQ(404.52,PAIEN,.01,"I")
if TPIEN=""
QUIT
+12 SET ROLE=""
SET ROLE=$$GET1^DIQ(404.57,TPIEN,.03)
if ROLE'["(MHTC)"
QUIT
+13 SET MHTC=""
SET MHTC=$$GET1^DIQ(404.52,PAIEN,.03)
if MHTC=""
QUIT
+14 SET PIEN=""
SET PIEN=$$GET1^DIQ(404.52,PAIEN,.03,"I")
+15 SET TP=""
SET TP=$$GET1^DIQ(404.57,TPIEN,.01)
+16 SET TEAM=""
SET TEAM=$$GET1^DIQ(404.57,TPIEN,.02)
+17 SET CC=CC+1
SET ^TMP("SCMCMHTC",$JOB,MHTC,CC)=PIEN_"^"_MHTC_"^"_ROLE_"^"_TP_"^"_TEAM
+18 QUIT
End DoDot:2
End DoDot:1
+19 DO EXIT
+20 QUIT
+21 ;
EXIT ;
+1 KILL PIEN,ROLE,PAIEN,TP,TEAM,CC,MHTC,IEN,TPIEN
+2 QUIT
