- 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 Mar 13, 2025@21:45:45 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
