SCMCMHE ;BP/DMR - PCMM Mental Health Report; 8 FEB 12
;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
;
;Report to identify MH patients to load into PCMM. The report
;uses the Outpatient Encounter file and CPT codes to identify the
;MH patients.
;
;Input - Beginning & Ending Date
; Institution (1 or all (all being 3 digit parent station)
; Number of Mental Health Stop Codes to search for in the given timeframe
;
;Output - Pat.Name^SSN(Last4)^days since last encounter^Future Appointment date/location
; ^Encounter Date^Clinic Name^ Location of Encounter
INIT ;
K ^TMP("MHEN",$J)
K ^TMP("MHEN1",$J)
;
DATE ;
S (BEG,END,DATE)=""
;
W !!,"This report should be run during non peak hours and can take hours to run!",!!
;
S %DT="AE",%DT("A")="Enter BEGINNING Date: " D ^%DT G EXIT:Y<0 S BEG=Y
S %DT="AE",%DT("A")="Enter ENDING Date: " D ^%DT G EXIT:Y<0 S END=Y
I BEG>END W !,"Beginning date must be before end date!" G DATE
;
INST ;
S (INST,DEF,IN)=""
S DIC=4,DIC(0)="AQMEZ",DIC("A")="Select Institution: " D ^DIC
I Y=-1 G EXIT
S IN=$P(Y,"^") S INST=$$GET1^DIQ(4,IN,99) I $L(INST)=3 S INST="ALL"
I $L(INST)>3 S INST=$P(Y,"^",2)
EN ;
S DEF=3
R !!,"Enter number of Outpatient Encounters (1 to 10): 3// ",DEF:30
S:DEF="" DEF=3 I DEF="^" G EXIT
I DEF>10!(DEF<1) W !,"Enter Number from 1 to 10 or '^' to Exit!" G EN
;
S %ZIS="Q" D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="PRT^SCMCMHE",ZTSAVE("*")="" D ^%ZTLOAD K ZTRTN,ZTSAVE G EXIT
I '$D(IO("Q")) U IO
;
PRT ;
D LOOP
D SAVE
;
W "Patient^SSN(Last4)^Days Since Last Encounter^Future Appointment Date^Location^Encounter Date^Clinic Name^Location of Encounter"
;
S (DTE,DTE2,IEN,DFN,CC)=""
S DTE="" F S DTE=$O(^TMP("MHEN",$J,DTE)) Q:DTE="" D
.S DFN="" F S DFN=$O(^TMP("MHEN",$J,DTE,DFN)) Q:DFN="" D
..W !,^TMP("MHEN",$J,DTE,DFN)
..S DTE2="" F S DTE2=$O(^TMP("MHEN1",$J,DFN,DTE2)) Q:DTE2="" D
...S CC="" F S CC=$O(^TMP("MHEN1",$J,DFN,DTE2,CC)) Q:CC="" D
....W ^TMP("MHEN1",$J,DFN,DTE2,CC)
....Q
D ^%ZISC
G EXIT
Q
;
LOOP ;
S (EN,ENC,ESC,ECL,JJ,CSC,CLIN,SC,SCIEN,EIEN,IEN,DFN,MHSC,MHTC,FAC,HOLD,HDT,HDT2,CODE,SCODE,SSTOP)=""
S CC=0,END=END+.999999
S DFN="" F S DFN=$O(^SCE("C",DFN)) Q:DFN="" D
.Q:$$GET1^DIQ(2,DFN,.351)'=""
.S MHTC="" S MHTC=$$START^SCMCMHTC(DFN) Q:MHTC'=""
.I CC'=DEF&(DFN'=HOLD) D FORMAT
.S CC=0,EIEN="" F S EIEN=$O(^SCE("C",DFN,EIEN)) Q:EIEN=""!(CC=DEF) D
..S DATE="",DATE=$$GET1^DIQ(409.68,EIEN,.01,"I") Q:DATE=""
..Q:DATE<BEG!(DATE>END)
..Q:$E(HDT2,1,7)=$E(DATE,1,7)&(DFN=HOLD)
..Q:$$GET1^DIQ(409.68,EIEN,.12,"I")'=2
..S FAC="" S FAC=$$GET1^DIQ(409.68,EIEN,.11)
..Q:INST'="ALL"&(FAC'=INST)
..S SCIEN="",SCIEN=$$GET1^DIQ(409.68,EIEN,.03,"I") Q:SCIEN=""
..S MHSC="" F S MHSC=$O(^SCTM(404.61,"B",SCIEN,MHSC)) Q:MHSC="" D
...Q:$D(^SCTM(404.61,"AC","1",MHSC))
...S (ECL,SSTOP)="" S ECL=$$GET1^DIQ(409.68,EIEN,.04,"I")
...I ECL'="" S CSC="" S CSC=$$GET1^DIQ(44,ECL,2503,"I")
...I CSC'="" S SSC="" F S SSC=$O(^SCTM(404.61,"B",CSC,SSC)) Q:SSC=""!(SSTOP=1) D
....I $D(^SCTM(404.61,"AC","1",SSC)) S SSTOP=1
...Q:SSTOP=1
...S CLIN="" S CLIN=$$GET1^DIQ(409.68,EIEN,.04)
...S CC=CC+1
...I CC=1 S (HDT,HDT2)="" S HDT=DATE D
....S ^TMP("MHEN",$J,DATE,DFN)=""
....S ^TMP("MHEN1",$J,DFN,DATE,CC)="^"_CLIN_"^"_FAC_"^"
...I CC>1 S ^TMP("MHEN1",$J,DFN,DATE,CC)="^"_CLIN_"^"_FAC_"^"
...S HOLD=DFN,HDT2=DATE
...Q
Q
FORMAT ;
Q:HOLD=""!(CC=0)
Q:HDT=""
K ^TMP("MHEN",$J,HDT,HOLD)
K ^TMP("MHEN1",$J,HOLD)
Q
SAVE ;
S (DFN,IEN,EN,LEN,PN,SSN,DTE,DTE2,EDT,LTE,CC,DAYS)=""
S DTE="" F S DTE=$O(^TMP("MHEN",$J,DTE)) Q:DTE="" D
.S DFN="" F S DFN=$O(^TMP("MHEN",$J,DTE,DFN)) Q:DFN="" D
..S PN="" S PN=$$GET1^DIQ(2,DFN,.01)
..S SSN="" S SSN=$$GET1^DIQ(2,DFN,.09,"I") I SSN'="" S SSN=$E(SSN,6,9)
..S Y=DTE X ^DD("DD") S EDT=Y
..S $P(^TMP("MHEN",$J,DTE,DFN),"^",6)=""
..S $P(^TMP("MHEN",$J,DTE,DFN),"^",1)=PN
..S $P(^TMP("MHEN",$J,DTE,DFN),"^",2)=SSN
..S DTE2="" F S DTE2=$O(^TMP("MHEN1",$J,DFN,DTE2)) Q:DTE2="" D
...S CC="" F S CC=$O(^TMP("MHEN1",$J,DFN,DTE2,CC)) Q:CC="" D
....S Y=DTE2 X ^DD("DD") S EDT=Y
....S $P(^TMP("MHEN1",$J,DFN,DTE2,CC),"^",1)=EDT
....I CC=DEF S X1=DT,X2=DTE D ^%DTC S DAYS=X
....S $P(^TMP("MHEN",$J,DTE,DFN),"^",3)=DAYS
....D FUT
....Q
Q
FUT ;
S (SC,ST,ADT,DTT,CL)="" S DTT=DT
F S DTT=$O(^DPT(DFN,"S",DTT)) Q:DTT=""!(ADT'="") D
.I DTT>DT S ST="" S ST=$$GET1^DIQ(2.98,DTT_","_DFN_",",3)
.Q:ST'="" S ADT="" S Y=DTT X ^DD("DD") S ADT=Y
.S CL="" S CL=$$GET1^DIQ(2.98,DTT_","_DFN_",",.01)
.S $P(^TMP("MHEN",$J,DTE,DFN),"^",4)=ADT
.S $P(^TMP("MHEN",$J,DTE,DFN),"^",5)=CL
.Q
Q
EXIT ;
K BEG,CC,CH,CL,END,DATE,SC,SCIEN,INST,DEF,IN,EN,ENC,JJ,PAT,DEF,DTE,DTE2,LEN
K APP,ADT,CLIN,SC,EIEN,IEN,DFN,MHSC,MHTC,FAC,ST,DTT,DATE,DAYS,EDT,HDT,SSTOP
K PN,SSN,X,X1,POP,LTE,HOLD,X2,Y,HDT2,DIC,ENC,ECL,CSC,CODE,SCODE,ESC,SSC
K ^TMP("MHEN",$J)
K ^TMP("MHEN1",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMHE 4992 printed Apr 09, 2024@21:52:46 Page 2
SCMCMHE ;BP/DMR - PCMM Mental Health Report; 8 FEB 12
+1 ;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
+2 ;
+3 ;Report to identify MH patients to load into PCMM. The report
+4 ;uses the Outpatient Encounter file and CPT codes to identify the
+5 ;MH patients.
+6 ;
+7 ;Input - Beginning & Ending Date
+8 ; Institution (1 or all (all being 3 digit parent station)
+9 ; Number of Mental Health Stop Codes to search for in the given timeframe
+10 ;
+11 ;Output - Pat.Name^SSN(Last4)^days since last encounter^Future Appointment date/location
+12 ; ^Encounter Date^Clinic Name^ Location of Encounter
INIT ;
+1 KILL ^TMP("MHEN",$JOB)
+2 KILL ^TMP("MHEN1",$JOB)
+3 ;
DATE ;
+1 SET (BEG,END,DATE)=""
+2 ;
+3 WRITE !!,"This report should be run during non peak hours and can take hours to run!",!!
+4 ;
+5 SET %DT="AE"
SET %DT("A")="Enter BEGINNING Date: "
DO ^%DT
if Y<0
GOTO EXIT
SET BEG=Y
+6 SET %DT="AE"
SET %DT("A")="Enter ENDING Date: "
DO ^%DT
if Y<0
GOTO EXIT
SET END=Y
+7 IF BEG>END
WRITE !,"Beginning date must be before end date!"
GOTO DATE
+8 ;
INST ;
+1 SET (INST,DEF,IN)=""
+2 SET DIC=4
SET DIC(0)="AQMEZ"
SET DIC("A")="Select Institution: "
DO ^DIC
+3 IF Y=-1
GOTO EXIT
+4 SET IN=$PIECE(Y,"^")
SET INST=$$GET1^DIQ(4,IN,99)
IF $LENGTH(INST)=3
SET INST="ALL"
+5 IF $LENGTH(INST)>3
SET INST=$PIECE(Y,"^",2)
EN ;
+1 SET DEF=3
+2 READ !!,"Enter number of Outpatient Encounters (1 to 10): 3// ",DEF:30
+3 if DEF=""
SET DEF=3
IF DEF="^"
GOTO EXIT
+4 IF DEF>10!(DEF<1)
WRITE !,"Enter Number from 1 to 10 or '^' to Exit!"
GOTO EN
+5 ;
+6 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+7 IF $DATA(IO("Q"))
SET ZTRTN="PRT^SCMCMHE"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
KILL ZTRTN,ZTSAVE
GOTO EXIT
+8 IF '$DATA(IO("Q"))
USE IO
+9 ;
PRT ;
+1 DO LOOP
+2 DO SAVE
+3 ;
+4 WRITE "Patient^SSN(Last4)^Days Since Last Encounter^Future Appointment Date^Location^Encounter Date^Clinic Name^Location of Encounter"
+5 ;
+6 SET (DTE,DTE2,IEN,DFN,CC)=""
+7 SET DTE=""
FOR
SET DTE=$ORDER(^TMP("MHEN",$JOB,DTE))
if DTE=""
QUIT
Begin DoDot:1
+8 SET DFN=""
FOR
SET DFN=$ORDER(^TMP("MHEN",$JOB,DTE,DFN))
if DFN=""
QUIT
Begin DoDot:2
+9 WRITE !,^TMP("MHEN",$JOB,DTE,DFN)
+10 SET DTE2=""
FOR
SET DTE2=$ORDER(^TMP("MHEN1",$JOB,DFN,DTE2))
if DTE2=""
QUIT
Begin DoDot:3
+11 SET CC=""
FOR
SET CC=$ORDER(^TMP("MHEN1",$JOB,DFN,DTE2,CC))
if CC=""
QUIT
Begin DoDot:4
+12 WRITE ^TMP("MHEN1",$JOB,DFN,DTE2,CC)
+13 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 DO ^%ZISC
+15 GOTO EXIT
+16 QUIT
+17 ;
LOOP ;
+1 SET (EN,ENC,ESC,ECL,JJ,CSC,CLIN,SC,SCIEN,EIEN,IEN,DFN,MHSC,MHTC,FAC,HOLD,HDT,HDT2,CODE,SCODE,SSTOP)=""
+2 SET CC=0
SET END=END+.999999
+3 SET DFN=""
FOR
SET DFN=$ORDER(^SCE("C",DFN))
if DFN=""
QUIT
Begin DoDot:1
+4 if $$GET1^DIQ(2,DFN,.351)'=""
QUIT
+5 SET MHTC=""
SET MHTC=$$START^SCMCMHTC(DFN)
if MHTC'=""
QUIT
+6 IF CC'=DEF&(DFN'=HOLD)
DO FORMAT
+7 SET CC=0
SET EIEN=""
FOR
SET EIEN=$ORDER(^SCE("C",DFN,EIEN))
if EIEN=""!(CC=DEF)
QUIT
Begin DoDot:2
+8 SET DATE=""
SET DATE=$$GET1^DIQ(409.68,EIEN,.01,"I")
if DATE=""
QUIT
+9 if DATE<BEG!(DATE>END)
QUIT
+10 if $EXTRACT(HDT2,1,7)=$EXTRACT(DATE,1,7)&(DFN=HOLD)
QUIT
+11 if $$GET1^DIQ(409.68,EIEN,.12,"I")'=2
QUIT
+12 SET FAC=""
SET FAC=$$GET1^DIQ(409.68,EIEN,.11)
+13 if INST'="ALL"&(FAC'=INST)
QUIT
+14 SET SCIEN=""
SET SCIEN=$$GET1^DIQ(409.68,EIEN,.03,"I")
if SCIEN=""
QUIT
+15 SET MHSC=""
FOR
SET MHSC=$ORDER(^SCTM(404.61,"B",SCIEN,MHSC))
if MHSC=""
QUIT
Begin DoDot:3
+16 if $DATA(^SCTM(404.61,"AC","1",MHSC))
QUIT
+17 SET (ECL,SSTOP)=""
SET ECL=$$GET1^DIQ(409.68,EIEN,.04,"I")
+18 IF ECL'=""
SET CSC=""
SET CSC=$$GET1^DIQ(44,ECL,2503,"I")
+19 IF CSC'=""
SET SSC=""
FOR
SET SSC=$ORDER(^SCTM(404.61,"B",CSC,SSC))
if SSC=""!(SSTOP=1)
QUIT
Begin DoDot:4
+20 IF $DATA(^SCTM(404.61,"AC","1",SSC))
SET SSTOP=1
End DoDot:4
+21 if SSTOP=1
QUIT
+22 SET CLIN=""
SET CLIN=$$GET1^DIQ(409.68,EIEN,.04)
+23 SET CC=CC+1
+24 IF CC=1
SET (HDT,HDT2)=""
SET HDT=DATE
Begin DoDot:4
+25 SET ^TMP("MHEN",$JOB,DATE,DFN)=""
+26 SET ^TMP("MHEN1",$JOB,DFN,DATE,CC)="^"_CLIN_"^"_FAC_"^"
End DoDot:4
+27 IF CC>1
SET ^TMP("MHEN1",$JOB,DFN,DATE,CC)="^"_CLIN_"^"_FAC_"^"
+28 SET HOLD=DFN
SET HDT2=DATE
+29 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
FORMAT ;
+1 if HOLD=""!(CC=0)
QUIT
+2 if HDT=""
QUIT
+3 KILL ^TMP("MHEN",$JOB,HDT,HOLD)
+4 KILL ^TMP("MHEN1",$JOB,HOLD)
+5 QUIT
SAVE ;
+1 SET (DFN,IEN,EN,LEN,PN,SSN,DTE,DTE2,EDT,LTE,CC,DAYS)=""
+2 SET DTE=""
FOR
SET DTE=$ORDER(^TMP("MHEN",$JOB,DTE))
if DTE=""
QUIT
Begin DoDot:1
+3 SET DFN=""
FOR
SET DFN=$ORDER(^TMP("MHEN",$JOB,DTE,DFN))
if DFN=""
QUIT
Begin DoDot:2
+4 SET PN=""
SET PN=$$GET1^DIQ(2,DFN,.01)
+5 SET SSN=""
SET SSN=$$GET1^DIQ(2,DFN,.09,"I")
IF SSN'=""
SET SSN=$EXTRACT(SSN,6,9)
+6 SET Y=DTE
XECUTE ^DD("DD")
SET EDT=Y
+7 SET $PIECE(^TMP("MHEN",$JOB,DTE,DFN),"^",6)=""
+8 SET $PIECE(^TMP("MHEN",$JOB,DTE,DFN),"^",1)=PN
+9 SET $PIECE(^TMP("MHEN",$JOB,DTE,DFN),"^",2)=SSN
+10 SET DTE2=""
FOR
SET DTE2=$ORDER(^TMP("MHEN1",$JOB,DFN,DTE2))
if DTE2=""
QUIT
Begin DoDot:3
+11 SET CC=""
FOR
SET CC=$ORDER(^TMP("MHEN1",$JOB,DFN,DTE2,CC))
if CC=""
QUIT
Begin DoDot:4
+12 SET Y=DTE2
XECUTE ^DD("DD")
SET EDT=Y
+13 SET $PIECE(^TMP("MHEN1",$JOB,DFN,DTE2,CC),"^",1)=EDT
+14 IF CC=DEF
SET X1=DT
SET X2=DTE
DO ^%DTC
SET DAYS=X
+15 SET $PIECE(^TMP("MHEN",$JOB,DTE,DFN),"^",3)=DAYS
+16 DO FUT
+17 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
FUT ;
+1 SET (SC,ST,ADT,DTT,CL)=""
SET DTT=DT
+2 FOR
SET DTT=$ORDER(^DPT(DFN,"S",DTT))
if DTT=""!(ADT'="")
QUIT
Begin DoDot:1
+3 IF DTT>DT
SET ST=""
SET ST=$$GET1^DIQ(2.98,DTT_","_DFN_",",3)
+4 if ST'=""
QUIT
SET ADT=""
SET Y=DTT
XECUTE ^DD("DD")
SET ADT=Y
+5 SET CL=""
SET CL=$$GET1^DIQ(2.98,DTT_","_DFN_",",.01)
+6 SET $PIECE(^TMP("MHEN",$JOB,DTE,DFN),"^",4)=ADT
+7 SET $PIECE(^TMP("MHEN",$JOB,DTE,DFN),"^",5)=CL
+8 QUIT
End DoDot:1
+9 QUIT
EXIT ;
+1 KILL BEG,CC,CH,CL,END,DATE,SC,SCIEN,INST,DEF,IN,EN,ENC,JJ,PAT,DEF,DTE,DTE2,LEN
+2 KILL APP,ADT,CLIN,SC,EIEN,IEN,DFN,MHSC,MHTC,FAC,ST,DTT,DATE,DAYS,EDT,HDT,SSTOP
+3 KILL PN,SSN,X,X1,POP,LTE,HOLD,X2,Y,HDT2,DIC,ENC,ECL,CSC,CODE,SCODE,ESC,SSC
+4 KILL ^TMP("MHEN",$JOB)
+5 KILL ^TMP("MHEN1",$JOB)
+6 QUIT
