- 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 Jan 18, 2025@03:42:04 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