SCMCMHHP ;BP-CIOFO/KEITH - Historical Patient Assignment Detail ; 23 Feb 12 3:30 PM
;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
;
; llh - copy of SCRPO5 with changes for Mental Health patients
;
PTDET N DIC,SC,DFN,SCPT0,X,Y,SCDT,DTOUT,DUOUT
D TITL^SCRPW50("Mental Health Historical Patient Assignment Detail")
S DIC="^DPT(",DIC(0)="AEMQZ" D ^DIC I $D(DTOUT)!$D(DUOUT) G EXIT
G:Y<1 EXIT S DFN=+Y,SCPT0=Y(0),SC="SC",SCDT("B")="TODAY"
G:'$$DTR^SCRPO(.SC,.SCDT,.SCDT) EXIT
; Patch 589 - added screen to allow only Patients assigned on a team whose
; TEAM PURPOSE equals "MENTAL HEALTH TREATMENT" to be selected.
I '$$MHTEAM(DFN) D G PTDET
.K DIR S DIR(0)="FO^1^1"
.S DIR("A",1)="No Mental Health Team Assignments for this patient during"
.S DIR("A")="this time period. Press the return key to continue"
.W ! D ^DIR K DIR
;
N ZTSAVE F X="DFN","SCPT0","SC(" S ZTSAVE(X)=""
W ! D EN^XUTMDEVQ("RUN^SCMCMHHP","Historical Patient Assignment Detail",.ZTSAVE)
EXIT D DISP0^SCRPW23,END^SCRPW50 Q
;
RUN ;Print report
N SCI,SCPNOW,SCLINE,SCPAGE,SCSUB,SCFF,SCFOUND,SCLN,SCAGE,SCDATA
N SCDOB,SCGEND,SCIFN,SCOUT,SCPNAME,SCREC,SCSH,SCSSN,SCTITL,SCDT
N SCEU,SCEUNM,SCLEBNM,SCLEDT,SCSTAT,SCSTNM,SCX,SCY
K ^TMP("SCRPT",$J) M SCDT=SC("DTR") S SCDT="SCDT"
S SCI=$$GETALL^SCAPMCA(DFN,.SCDT),SCSUB="",(SCFF,SCLN,SCFOUND,SCOUT)=0
F S SCSUB=$O(^TMP("SC",$J,DFN,SCSUB)) Q:SCSUB=""!(SCSUB]"PCTM") D
.S SCX=$P($T(@SCSUB),";;",2) F SCI=1:1:9 S SCX(SCI)=$P(SCX,U,SCI)
.S ^TMP("SCRPT",$J,SCX(1))=SCX(2),SCX(3)=U_SCX(3)
.S SCI=0 F S SCI=$O(^TMP("SC",$J,DFN,SCSUB,SCI)) Q:'SCI D
..S SCDATA=^TMP("SC",$J,DFN,SCSUB,SCI)
..S SCNAME=$P(SCDATA,U,SCX(8)) ;provider/position/team name
..S SCIFN=$P(SCDATA,U,SCX(4)) ;history record ifn
..S SCACT=$P(SCDATA,U,SCX(5)) ;active date
..Q:'SCACT
..S SCINAC=$P(SCDATA,U,SCX(6)) ;inactive date
..S SCREC=$G(@SCX(3)@(SCIFN,0)) ;history record
..Q:'$L(SCREC)
..S SCUSER=$P(SCREC,U,SCX(7)) ;user duz
..S SCDENT=$P(SCREC,U,SCX(9)) ;date entered
..S SCEU=$P(SCREC,U,6),SCEUNM=$$GET1^DIQ(200,SCEU_",",.01) ;editing user
..S SCSTAT=$P(SCREC,U,12),SCSTNM=$$GET1^DIQ(404.43,SCIFN_",",.12) ;status
..S SCLEDT=$P(SCREC,U,8),SCLEBNM=$$GET1^DIQ(200,SCLEDT_",",.01) ;last edited by
..D SLINE(SCX(1),SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SCEUNM,SCSTNM,SCLEBNM,.SCLN)
..Q
.Q
S SCTITL(1)="<*> HISTORICAL PATIENT ASSIGNMENT DETAIL <*>"
S SCTITL(2)="For assignments effective "_SC("DTR","PBDT")_" to "_SC("DTR","PEDT")
S SCLINE="",$P(SCLINE,"-",81)="",SCPAGE=1
S Y=$$NOW^XLFDT() X ^DD("DD") S SCPNOW=$P(Y,":",1,2)
S SCPNAME=$P(SCPT0,U),SCSSN=$P(SCPT0,U,9)
S SCGEND=$S($P(SCPT0,U,2)="M":"MALE",1:"FEMALE")
S (Y,SCAGE)=$P(SCPT0,U,3) X ^DD("DD") S SCDOB=Y
S SCAGE=$E(DT,1,3)-$E(SCAGE,1,3)-($E(DT,4,7)<$E(SCAGE,4,7))
D:$E(IOST)="C" DISP0^SCRPW23 D HDR^SCRPO(.SCTITL,80),SHDR
W:'SCFOUND !!?21,"No assignments found for this patient."
I SCFOUND S SCSUB=0 F S SCSUB=$O(^TMP("SCRPT",$J,SCSUB)) Q:'SCSUB!SCOUT D
.D:$Y>(IOSL-5) HDR^SCRPO(.SCTITL,80),SHDR Q:SCOUT
.S SCSH=^TMP("SCRPT",$J,SCSUB)
.W:SCSUB>1 ! D SSHDR(SCSH) S SCACT=""
.I '$O(^TMP("SCRPT",$J,SCSUB,"")) W " (none found)" Q
.F S SCACT=$O(^TMP("SCRPT",$J,SCSUB,SCACT)) Q:SCACT=""!SCOUT D
..S SCI=0 F S SCI=$O(^TMP("SCRPT",$J,SCSUB,SCACT,SCI)) Q:'SCI!SCOUT D
...D:$Y>(IOSL-3) HDR^SCRPO(.SCTITL,80),SHDR,SSHDR(SCSH,1) Q:SCOUT
...S SCX=^TMP("SCRPT",$J,SCSUB,SCACT,SCI)
...W !,$P(SCX,U),?28,$P(SCX,U,2),?40,$P(SCX,U,3),?52,$P(SCX,U,4)
...I SCSUB=3 D
....W !,"User Entering: ",$P(SCX,U,6)
....W !,"Last Edited By: ",$P(SCX,U,7)
....W !,"Status: ",$P(SCX,U,5)
...Q
..Q
.Q
I 'SCOUT,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
K ^TMP("SCRPT",$J) Q
;
SHDR ;Subheader
Q:SCOUT
W !,"Patient: ",$E(SCPNAME,1,18),?29,"SSN: ",SCSSN,?46,"DOB: ",SCDOB
W ?64,"AGE: ",SCAGE,?74,$J(SCGEND,6),!,SCLINE
Q:'SCFOUND
W !,"Assignment",?28,"Active",?40,"Inactive",?52,"Assigned by/date"
W !,"-------------------------- ---------- ---------- ----------------------------"
Q
;
SSHDR(X,CONT) ;Subheader
;Input: X=category
;Input: CONT='1' for continuation (optional)
W !,X,$S($G(CONT):" (cont.)",1:""),":"
Q
;
SLINE(SCORD,SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SUNM,SCTNM,SCBNM,SCLN) ;Set report global
;Input: SCORD=output order
;Input: SCNAME=provider/position/team name
;Input: SCACT=active date
;Input: SCINAC=inactive date
;Input: SCUSER=user duz
;Input: SCDENT=date entered
;Input: SUNM=entered by
;Input: SCTNM=status
;Input: SCBNM=last edited by
;
;N SCX,SCY
S SCFOUND=1,SCLN=SCLN+1
S SCX=$E(SCNAME,1,25)_U_$$SDT(SCACT)_U_$$SDT(SCINAC),SCY=$$SDT(SCDENT)
S:$L(SCY) SCY=" ("_SCY_")"
S SCX=SCX_U_$E($P($G(^VA(200,+SCUSER,0)),U),1,(28-$L(SCY)))_SCY_U_SCTNM_U_SUNM_U_SCBNM
S ^TMP("SCRPT",$J,SCORD,-SCACT,SCLN)=SCX
Q
;
CODE ;Data handling instructions
; The following $TEXT lines contain data handling instructions
; in the format: $PIECE 1 = output order
; 2 = subtitle
; 3 = global reference of history record
; 4 = $piece of history record ifn
; 5 = $piece of active date
; 6 = $piece of inactive date
; 7 = $piece of user (in history record)
; 8 = $piece of provider/position/team name
; 9 = $piece of date entered
;
NPCPOS ;;7^Non-PC Position^SCPT(404.43)^4^5^6^6^2^7
NPCPPOS ;;9^Non-PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
NPCPPR ;;8^Non-PC Preceptor Provider^SCTM(404.52)^11^9^10^7^2^8
NPCPR ;;6^Non-PC Provider^SCTM(404.52)^11^9^10^7^2^8
NPCTM ;;10^Non-PC Team^SCPT(404.42)^3^4^5^11^2^12
PCAP ;;2^PC Associate Provider^SCTM(404.52)^11^9^10^7^2^8
PCPOS ;;3^PC Position^SCPT(404.43)^4^5^6^6^2^7
PCPPOS ;;4^PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
PCPR ;;1^PC Provider^SCTM(404.52)^11^9^10^7^2^8
PCTM ;;5^PC Team^SCPT(404.42)^3^4^5^11^2^12
;
SDT(X) ;Slashed date
S X=$E(X,1,7) Q:X'?7N ""
Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(17+$E(X))_$E(X,2,3)
;
MHTEAM(DFN) ;Patch 589 used to exclude all teams that are not Mental Health
; Input
; DFN = Patient DFN
;
;Output
; 1 = Team Purpose is "MENTAL HEALTH TREATMENT"
; 0 = Team Purpose not "MENTAL HEALTH TREATMENT"
;
; need to filter on Team Purpose = Mental Health Treatment, IEN = 4
N TPIEN,TP,TPDT,SCARR,SCI
S TPIEN=$O(^SD(403.47,"B","MENTAL HEALTH TREATMENT",""))
I '$G(TPIEN) Q 0
S TP="TP",TP(TPIEN)=""
M TPDT=SC("DTR") S TPDT="TPDT"
S SCARR="^TMP(""SCARR"",$J)" K @SCARR
S SCI=$$TMPT^SCAPMC(DFN,.TPDT,.TP,SCARR)
I '$D(@SCARR@(0)) Q 0
K @SCARR
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMHHP 6733 printed Sep 23, 2025@20:17:12 Page 2
SCMCMHHP ;BP-CIOFO/KEITH - Historical Patient Assignment Detail ; 23 Feb 12 3:30 PM
+1 ;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
+2 ;
+3 ; llh - copy of SCRPO5 with changes for Mental Health patients
+4 ;
PTDET NEW DIC,SC,DFN,SCPT0,X,Y,SCDT,DTOUT,DUOUT
+1 DO TITL^SCRPW50("Mental Health Historical Patient Assignment Detail")
+2 SET DIC="^DPT("
SET DIC(0)="AEMQZ"
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+3 if Y<1
GOTO EXIT
SET DFN=+Y
SET SCPT0=Y(0)
SET SC="SC"
SET SCDT("B")="TODAY"
+4 if '$$DTR^SCRPO(.SC,.SCDT,.SCDT)
GOTO EXIT
+5 ; Patch 589 - added screen to allow only Patients assigned on a team whose
+6 ; TEAM PURPOSE equals "MENTAL HEALTH TREATMENT" to be selected.
+7 IF '$$MHTEAM(DFN)
Begin DoDot:1
+8 KILL DIR
SET DIR(0)="FO^1^1"
+9 SET DIR("A",1)="No Mental Health Team Assignments for this patient during"
+10 SET DIR("A")="this time period. Press the return key to continue"
+11 WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO PTDET
+12 ;
+13 NEW ZTSAVE
FOR X="DFN","SCPT0","SC("
SET ZTSAVE(X)=""
+14 WRITE !
DO EN^XUTMDEVQ("RUN^SCMCMHHP","Historical Patient Assignment Detail",.ZTSAVE)
EXIT DO DISP0^SCRPW23
DO END^SCRPW50
QUIT
+1 ;
RUN ;Print report
+1 NEW SCI,SCPNOW,SCLINE,SCPAGE,SCSUB,SCFF,SCFOUND,SCLN,SCAGE,SCDATA
+2 NEW SCDOB,SCGEND,SCIFN,SCOUT,SCPNAME,SCREC,SCSH,SCSSN,SCTITL,SCDT
+3 NEW SCEU,SCEUNM,SCLEBNM,SCLEDT,SCSTAT,SCSTNM,SCX,SCY
+4 KILL ^TMP("SCRPT",$JOB)
MERGE SCDT=SC("DTR")
SET SCDT="SCDT"
+5 SET SCI=$$GETALL^SCAPMCA(DFN,.SCDT)
SET SCSUB=""
SET (SCFF,SCLN,SCFOUND,SCOUT)=0
+6 FOR
SET SCSUB=$ORDER(^TMP("SC",$JOB,DFN,SCSUB))
if SCSUB=""!(SCSUB]"PCTM")
QUIT
Begin DoDot:1
+7 SET SCX=$PIECE($TEXT(@SCSUB),";;",2)
FOR SCI=1:1:9
SET SCX(SCI)=$PIECE(SCX,U,SCI)
+8 SET ^TMP("SCRPT",$JOB,SCX(1))=SCX(2)
SET SCX(3)=U_SCX(3)
+9 SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SC",$JOB,DFN,SCSUB,SCI))
if 'SCI
QUIT
Begin DoDot:2
+10 SET SCDATA=^TMP("SC",$JOB,DFN,SCSUB,SCI)
+11 ;provider/position/team name
SET SCNAME=$PIECE(SCDATA,U,SCX(8))
+12 ;history record ifn
SET SCIFN=$PIECE(SCDATA,U,SCX(4))
+13 ;active date
SET SCACT=$PIECE(SCDATA,U,SCX(5))
+14 if 'SCACT
QUIT
+15 ;inactive date
SET SCINAC=$PIECE(SCDATA,U,SCX(6))
+16 ;history record
SET SCREC=$GET(@SCX(3)@(SCIFN,0))
+17 if '$LENGTH(SCREC)
QUIT
+18 ;user duz
SET SCUSER=$PIECE(SCREC,U,SCX(7))
+19 ;date entered
SET SCDENT=$PIECE(SCREC,U,SCX(9))
+20 ;editing user
SET SCEU=$PIECE(SCREC,U,6)
SET SCEUNM=$$GET1^DIQ(200,SCEU_",",.01)
+21 ;status
SET SCSTAT=$PIECE(SCREC,U,12)
SET SCSTNM=$$GET1^DIQ(404.43,SCIFN_",",.12)
+22 ;last edited by
SET SCLEDT=$PIECE(SCREC,U,8)
SET SCLEBNM=$$GET1^DIQ(200,SCLEDT_",",.01)
+23 DO SLINE(SCX(1),SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SCEUNM,SCSTNM,SCLEBNM,.SCLN)
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 SET SCTITL(1)="<*> HISTORICAL PATIENT ASSIGNMENT DETAIL <*>"
+27 SET SCTITL(2)="For assignments effective "_SC("DTR","PBDT")_" to "_SC("DTR","PEDT")
+28 SET SCLINE=""
SET $PIECE(SCLINE,"-",81)=""
SET SCPAGE=1
+29 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET SCPNOW=$PIECE(Y,":",1,2)
+30 SET SCPNAME=$PIECE(SCPT0,U)
SET SCSSN=$PIECE(SCPT0,U,9)
+31 SET SCGEND=$SELECT($PIECE(SCPT0,U,2)="M":"MALE",1:"FEMALE")
+32 SET (Y,SCAGE)=$PIECE(SCPT0,U,3)
XECUTE ^DD("DD")
SET SCDOB=Y
+33 SET SCAGE=$EXTRACT(DT,1,3)-$EXTRACT(SCAGE,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(SCAGE,4,7))
+34 if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
DO HDR^SCRPO(.SCTITL,80)
DO SHDR
+35 if 'SCFOUND
WRITE !!?21,"No assignments found for this patient."
+36 IF SCFOUND
SET SCSUB=0
FOR
SET SCSUB=$ORDER(^TMP("SCRPT",$JOB,SCSUB))
if 'SCSUB!SCOUT
QUIT
Begin DoDot:1
+37 if $Y>(IOSL-5)
DO HDR^SCRPO(.SCTITL,80)
DO SHDR
if SCOUT
QUIT
+38 SET SCSH=^TMP("SCRPT",$JOB,SCSUB)
+39 if SCSUB>1
WRITE !
DO SSHDR(SCSH)
SET SCACT=""
+40 IF '$ORDER(^TMP("SCRPT",$JOB,SCSUB,""))
WRITE " (none found)"
QUIT
+41 FOR
SET SCACT=$ORDER(^TMP("SCRPT",$JOB,SCSUB,SCACT))
if SCACT=""!SCOUT
QUIT
Begin DoDot:2
+42 SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SCRPT",$JOB,SCSUB,SCACT,SCI))
if 'SCI!SCOUT
QUIT
Begin DoDot:3
+43 if $Y>(IOSL-3)
DO HDR^SCRPO(.SCTITL,80)
DO SHDR
DO SSHDR(SCSH,1)
if SCOUT
QUIT
+44 SET SCX=^TMP("SCRPT",$JOB,SCSUB,SCACT,SCI)
+45 WRITE !,$PIECE(SCX,U),?28,$PIECE(SCX,U,2),?40,$PIECE(SCX,U,3),?52,$PIECE(SCX,U,4)
+46 IF SCSUB=3
Begin DoDot:4
+47 WRITE !,"User Entering: ",$PIECE(SCX,U,6)
+48 WRITE !,"Last Edited By: ",$PIECE(SCX,U,7)
+49 WRITE !,"Status: ",$PIECE(SCX,U,5)
End DoDot:4
+50 QUIT
End DoDot:3
+51 QUIT
End DoDot:2
+52 QUIT
End DoDot:1
+53 IF 'SCOUT
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+54 KILL ^TMP("SCRPT",$JOB)
QUIT
+55 ;
SHDR ;Subheader
+1 if SCOUT
QUIT
+2 WRITE !,"Patient: ",$EXTRACT(SCPNAME,1,18),?29,"SSN: ",SCSSN,?46,"DOB: ",SCDOB
+3 WRITE ?64,"AGE: ",SCAGE,?74,$JUSTIFY(SCGEND,6),!,SCLINE
+4 if 'SCFOUND
QUIT
+5 WRITE !,"Assignment",?28,"Active",?40,"Inactive",?52,"Assigned by/date"
+6 WRITE !,"-------------------------- ---------- ---------- ----------------------------"
+7 QUIT
+8 ;
SSHDR(X,CONT) ;Subheader
+1 ;Input: X=category
+2 ;Input: CONT='1' for continuation (optional)
+3 WRITE !,X,$SELECT($GET(CONT):" (cont.)",1:""),":"
+4 QUIT
+5 ;
SLINE(SCORD,SCNAME,SCACT,SCINAC,SCUSER,SCDENT,SUNM,SCTNM,SCBNM,SCLN) ;Set report global
+1 ;Input: SCORD=output order
+2 ;Input: SCNAME=provider/position/team name
+3 ;Input: SCACT=active date
+4 ;Input: SCINAC=inactive date
+5 ;Input: SCUSER=user duz
+6 ;Input: SCDENT=date entered
+7 ;Input: SUNM=entered by
+8 ;Input: SCTNM=status
+9 ;Input: SCBNM=last edited by
+10 ;
+11 ;N SCX,SCY
+12 SET SCFOUND=1
SET SCLN=SCLN+1
+13 SET SCX=$EXTRACT(SCNAME,1,25)_U_$$SDT(SCACT)_U_$$SDT(SCINAC)
SET SCY=$$SDT(SCDENT)
+14 if $LENGTH(SCY)
SET SCY=" ("_SCY_")"
+15 SET SCX=SCX_U_$EXTRACT($PIECE($GET(^VA(200,+SCUSER,0)),U),1,(28-$LENGTH(SCY)))_SCY_U_SCTNM_U_SUNM_U_SCBNM
+16 SET ^TMP("SCRPT",$JOB,SCORD,-SCACT,SCLN)=SCX
+17 QUIT
+18 ;
CODE ;Data handling instructions
+1 ; The following $TEXT lines contain data handling instructions
+2 ; in the format: $PIECE 1 = output order
+3 ; 2 = subtitle
+4 ; 3 = global reference of history record
+5 ; 4 = $piece of history record ifn
+6 ; 5 = $piece of active date
+7 ; 6 = $piece of inactive date
+8 ; 7 = $piece of user (in history record)
+9 ; 8 = $piece of provider/position/team name
+10 ; 9 = $piece of date entered
+11 ;
NPCPOS ;;7^Non-PC Position^SCPT(404.43)^4^5^6^6^2^7
NPCPPOS ;;9^Non-PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
NPCPPR ;;8^Non-PC Preceptor Provider^SCTM(404.52)^11^9^10^7^2^8
NPCPR ;;6^Non-PC Provider^SCTM(404.52)^11^9^10^7^2^8
NPCTM ;;10^Non-PC Team^SCPT(404.42)^3^4^5^11^2^12
PCAP ;;2^PC Associate Provider^SCTM(404.52)^11^9^10^7^2^8
PCPOS ;;3^PC Position^SCPT(404.43)^4^5^6^6^2^7
PCPPOS ;;4^PC Preceptor Position^SCTM(404.53)^16^14^15^7^2^8
PCPR ;;1^PC Provider^SCTM(404.52)^11^9^10^7^2^8
PCTM ;;5^PC Team^SCPT(404.42)^3^4^5^11^2^12
+1 ;
SDT(X) ;Slashed date
+1 SET X=$EXTRACT(X,1,7)
if X'?7N
QUIT ""
+2 QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(17+$EXTRACT(X))_$EXTRACT(X,2,3)
+3 ;
MHTEAM(DFN) ;Patch 589 used to exclude all teams that are not Mental Health
+1 ; Input
+2 ; DFN = Patient DFN
+3 ;
+4 ;Output
+5 ; 1 = Team Purpose is "MENTAL HEALTH TREATMENT"
+6 ; 0 = Team Purpose not "MENTAL HEALTH TREATMENT"
+7 ;
+8 ; need to filter on Team Purpose = Mental Health Treatment, IEN = 4
+9 NEW TPIEN,TP,TPDT,SCARR,SCI
+10 SET TPIEN=$ORDER(^SD(403.47,"B","MENTAL HEALTH TREATMENT",""))
+11 IF '$GET(TPIEN)
QUIT 0
+12 SET TP="TP"
SET TP(TPIEN)=""
+13 MERGE TPDT=SC("DTR")
SET TPDT="TPDT"
+14 SET SCARR="^TMP(""SCARR"",$J)"
KILL @SCARR
+15 SET SCI=$$TMPT^SCAPMC(DFN,.TPDT,.TP,SCARR)
+16 IF '$DATA(@SCARR@(0))
QUIT 0
+17 KILL @SCARR
+18 QUIT 1
