- SDMHPRO1 ;MAF/ALB,JAS - MENTAL HEALTH PROACTIVE HIGH RISK REPORT (BGJ CONT.) ; MAR 29, 2024@14:00
- ;;5.3;Scheduling;**588,877**;Aug 13,1993;Build 14
- ;;Per VHA Directive 6402, this routine should not be modified
- DATA ; Set up the data for the patient
- ; piece 1 = dfn
- ; piece 2 = Appointment Date and time
- ; piece 3 = status N(Noshow) or NA (Noshow with auto rebook)
- ; piece 4 = PID last 4 of SSN
- ; piece 5 = clinic ien ^SC(
- ; piece 6 = stop code ien ^DIC(40.7
- ;
- ;
- EN ;PRINT OF THE ^TMP
- N SDXDIV,SDXCLIN,SDXDFN,SDXSTOP,SDXREM,SDXNM,SDCOUNT,SDATE
- S (SDXDFN,SDXREM,SDCOUNT)=0
- K SDPAT
- I $D(^TMP(NAMSPC1,$J)) D TOTAL^SDMHPRO
- S SDXDIV=""
- F S SDXDIV=$O(^TMP(NAMSPC1,$J,SDXDIV)) Q:SDXDIV']""!(SDUP) D
- .S SDCOUNT=0
- .I SDTL="CLIN" D N SDX S SDX=$$SETSTR(" ",X,1,79) D SET1(SDX)
- ..S SDXNM=""
- ..F S SDXNM=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM)) Q:SDXNM']""!(SDUP) D
- ...S SDATE=0
- ...F S SDATE=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE)) Q:'SDATE!(SDUP) D
- ....S SDXCLIN=""
- ....F S SDXCLIN=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN)) Q:SDXCLIN']""!(SDUP) D
- .....S SDXSTOP=0
- .....F S SDXSTOP=$O(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP)) Q:'SDXSTOP!(SDUP) D
- ......I $D(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP)) Q:$D(SDPAT(SDXDIV,$O(^DPT("B",$E(SDXNM,1,30),0)))) D PRT
- .N SDX S SDX=$$SETSTR(" ",X,1,81) D SET1(SDX)
- Q
- ;
- ;
- PRT ;Print report
- N SDX,SDXX
- D COUNT^SDMHPRO
- I '$D(SDXFLG(SDXDIV)) D HEAD^SDMHPRO S SDXFLG(SDXDIV)=1,SDXFLG(SDXDIV,SDXCLIN)=1
- I $D(SDXFLG(SDXDIV)),'$D(SDXFLG(SDXDIV)) S SDX=$$SETSTR("",X,1,80) D SET1(SDX) D HEAD1^SDMHPRO S SDXFLG(SDXDIV)=1
- N SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDX,SDDSS
- S SDXSORT1=$S(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
- S SDXSORT2=$S(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
- S SDXNODE=$G(^TMP(NAMSPC1,$J,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
- S SDXDFN=$P(SDXNODE,"^",1) Q:SDXDFN']""
- S SDXID=$E($P(SDXNODE,"^",4),1,5)
- S SDXDT=$P(SDXNODE,"^",2)
- S SDXSTAT=$P(SDXNODE,"^",3)
- S SDXCLIEN=$P(SDXNODE,"^",5)
- S SDDSS=$P($G(^DIC(40.7,+$P(SDXNODE,"^",6),0)),"^",2)
- S SDPAT(SDXDIV,SDXDFN)=""
- I '$D(SDXFLG(SDXDIV)) D HEAD1^SDMHPRO S SDXFLG(SDXDIV)=1
- S SDXDT=$$FMTE^XLFDT(SDXDT,"5")
- D SET
- S SDXX=$$SETSTR(SDCOUNT,X,1,2)_$$SETSTR($P(^DPT(SDXDFN,0),"^",1),X,3,20)_$$SETSTR(SDXID,X,2,5) I SDCOUNT=$P($G(TOTAL(SDXDIV)),"^",1) S SDCOUNT=0
- D FUT
- Q
- ;
- ;
- SETSTR(W,X,Y,Z) ;SET UP THE STRING
- ;W= String
- ;X= Variable to set it into
- ;Y= column to set it into
- ;Z= length of the string
- S X=$$SETSTR^SDUL1(W,X,Y,Z)
- Q X
- SET1(X) ;Sets the XMTEXT global
- S SDLN=SDLN+1,^TMP("SDMHP",$J,SDLN,0)=X Q
- SET ;
- S X="" S SDLN=SDLN+1,^TMP("SDPRO1",$J,SDLN,0)=X
- Q
- ;
- ;
- FUT ; FUTURE SCHEDULED APPTS.
- N SDARRAY,SDCOUNT,SDX,X1,X2,X,SDPRODAY
- S SDPRODAY=$$GET^XPAR("SYS^PKG.SCHEDULING","SDMH PROACTIVE DAYS",1,"Q")
- S SDPRODAY=$S(SDPRODAY]"":SDPRODAY,1:30)
- ;Find Scheduled apointments for SDPRODAY days using scheduling API
- S X1=DT,X2=SDPRODAY D C^%DTC S SDX=X
- S SDARRAY(1)=DT_";"_SDX
- S SDARRAY("SORT")="P"
- S SDARRAY(3)="NT;R"
- S SDARRAY(4)=SDXDFN
- S SDARRAY("FLDS")="1;2;3;4;10;13"
- S SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
- I SDCOUNT>0 D Q:SDUP
- .;Get info on future scheduled appointments and display it
- . S SDX="",X=""
- . N SDFA,SDFNODE,SDFUTDT
- . S SDFA=0 F S SDFA=$O(^TMP($J,"SDAMA301",SDXDFN,SDFA)) Q:SDFA="" D ;!($P($G(SDFA),".",1))'=$P(SDBEG,".",1) D
- ..S (SDX,X)=""
- ..S SDFUTDT=$$FMTE^XLFDT(SDFA,"5") S SDFNODE=^TMP($J,"SDAMA301",SDXDFN,SDFA)
- ..N SDCLCD S SDCLCD=$P($P($G(SDFNODE),"^",2),";",1) I SDCLCD]"" S SDCLCD=$P($G(^SC(SDCLCD,0)),"^",15) Q:SDXDIV'=$P($G(^DG(40.8,SDCLCD,0)),"^",1)
- ..I '$D(SDXX) S SDX=$$SETSTR(SDFUTDT,X,32,16)_$$SETSTR($P($P(SDFNODE,"^",2),";",2),X,2,30)
- ..I $D(SDXX) S SDX=SDXX_$$SETSTR(SDFUTDT,X,2,16)_$$SETSTR($P($P(SDFNODE,"^",2),";",2),X,2,30) K SDXX
- ..D SET1(SDX)
- .N SDX S SDX=$$SETSTR(" ",X,1,81) D SET1(SDX)
- .Q
- I SDCOUNT'>0 D
- .S (SDX,X)=""
- .S SDX=" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN "_SDPRODAY_$S(SDPRODAY=1:" DAY",1:" DAYS")
- .S SDX=$$SETSTR(SDX,X,1,80) D SET1(SDX)
- ;.S SDX=$$SETSTR(" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN 30 DAYS",X,1,80) D SET1(SDX)
- K ^TMP($J,"SDAMA301")
- Q
- ;
- ;
- PID(DFN) ; Return PID
- ; INPUT - DFN
- ; OUTPUT - PID or 'UNKNOWN'
- N VA
- D PID^VADPT6
- Q $S(VA("BID")]"":VA("BID"),1:"UNKNOWN")
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDMHPRO1 4480 printed Apr 23, 2025@19:13:20 Page 2
- SDMHPRO1 ;MAF/ALB,JAS - MENTAL HEALTH PROACTIVE HIGH RISK REPORT (BGJ CONT.) ; MAR 29, 2024@14:00
- +1 ;;5.3;Scheduling;**588,877**;Aug 13,1993;Build 14
- +2 ;;Per VHA Directive 6402, this routine should not be modified
- DATA ; Set up the data for the patient
- +1 ; piece 1 = dfn
- +2 ; piece 2 = Appointment Date and time
- +3 ; piece 3 = status N(Noshow) or NA (Noshow with auto rebook)
- +4 ; piece 4 = PID last 4 of SSN
- +5 ; piece 5 = clinic ien ^SC(
- +6 ; piece 6 = stop code ien ^DIC(40.7
- +7 ;
- +8 ;
- EN ;PRINT OF THE ^TMP
- +1 NEW SDXDIV,SDXCLIN,SDXDFN,SDXSTOP,SDXREM,SDXNM,SDCOUNT,SDATE
- +2 SET (SDXDFN,SDXREM,SDCOUNT)=0
- +3 KILL SDPAT
- +4 IF $DATA(^TMP(NAMSPC1,$JOB))
- DO TOTAL^SDMHPRO
- +5 SET SDXDIV=""
- +6 FOR
- SET SDXDIV=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV))
- if SDXDIV']""!(SDUP)
- QUIT
- Begin DoDot:1
- +7 SET SDCOUNT=0
- +8 IF SDTL="CLIN"
- Begin DoDot:2
- +9 SET SDXNM=""
- +10 FOR
- SET SDXNM=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM))
- if SDXNM']""!(SDUP)
- QUIT
- Begin DoDot:3
- +11 SET SDATE=0
- +12 FOR
- SET SDATE=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE))
- if 'SDATE!(SDUP)
- QUIT
- Begin DoDot:4
- +13 SET SDXCLIN=""
- +14 FOR
- SET SDXCLIN=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN))
- if SDXCLIN']""!(SDUP)
- QUIT
- Begin DoDot:5
- +15 SET SDXSTOP=0
- +16 FOR
- SET SDXSTOP=$ORDER(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
- if 'SDXSTOP!(SDUP)
- QUIT
- Begin DoDot:6
- +17 IF $DATA(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
- if $DATA(SDPAT(SDXDIV,$ORDER(^DPT("B",$EXTRACT(SDXNM,1,30),0))))
- QUIT
- DO PRT
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- NEW SDX
- SET SDX=$$SETSTR(" ",X,1,79)
- DO SET1(SDX)
- +18 NEW SDX
- SET SDX=$$SETSTR(" ",X,1,81)
- DO SET1(SDX)
- End DoDot:1
- +19 QUIT
- +20 ;
- +21 ;
- PRT ;Print report
- +1 NEW SDX,SDXX
- +2 DO COUNT^SDMHPRO
- +3 IF '$DATA(SDXFLG(SDXDIV))
- DO HEAD^SDMHPRO
- SET SDXFLG(SDXDIV)=1
- SET SDXFLG(SDXDIV,SDXCLIN)=1
- +4 IF $DATA(SDXFLG(SDXDIV))
- IF '$DATA(SDXFLG(SDXDIV))
- SET SDX=$$SETSTR("",X,1,80)
- DO SET1(SDX)
- DO HEAD1^SDMHPRO
- SET SDXFLG(SDXDIV)=1
- +5 NEW SDXNODE,SDXID,SDXDT,SDXSTAT,SDXSORT1,SDXSORT2,SDXCLIEN,SDX,SDDSS
- +6 SET SDXSORT1=$SELECT(SDTL="MEN":SDXREM,SDTL="STOP":SDXSTOP,1:SDXCLIN)
- +7 SET SDXSORT2=$SELECT(SDTL="CLIN":SDXSTOP,1:SDXCLIN)
- +8 SET SDXNODE=$GET(^TMP(NAMSPC1,$JOB,SDXDIV,SDXNM,SDATE,SDXCLIN,SDXSTOP))
- +9 SET SDXDFN=$PIECE(SDXNODE,"^",1)
- if SDXDFN']""
- QUIT
- +10 SET SDXID=$EXTRACT($PIECE(SDXNODE,"^",4),1,5)
- +11 SET SDXDT=$PIECE(SDXNODE,"^",2)
- +12 SET SDXSTAT=$PIECE(SDXNODE,"^",3)
- +13 SET SDXCLIEN=$PIECE(SDXNODE,"^",5)
- +14 SET SDDSS=$PIECE($GET(^DIC(40.7,+$PIECE(SDXNODE,"^",6),0)),"^",2)
- +15 SET SDPAT(SDXDIV,SDXDFN)=""
- +16 IF '$DATA(SDXFLG(SDXDIV))
- DO HEAD1^SDMHPRO
- SET SDXFLG(SDXDIV)=1
- +17 SET SDXDT=$$FMTE^XLFDT(SDXDT,"5")
- +18 DO SET
- +19 SET SDXX=$$SETSTR(SDCOUNT,X,1,2)_$$SETSTR($PIECE(^DPT(SDXDFN,0),"^",1),X,3,20)_$$SETSTR(SDXID,X,2,5)
- IF SDCOUNT=$PIECE($GET(TOTAL(SDXDIV)),"^",1)
- SET SDCOUNT=0
- +20 DO FUT
- +21 QUIT
- +22 ;
- +23 ;
- SETSTR(W,X,Y,Z) ;SET UP THE STRING
- +1 ;W= String
- +2 ;X= Variable to set it into
- +3 ;Y= column to set it into
- +4 ;Z= length of the string
- +5 SET X=$$SETSTR^SDUL1(W,X,Y,Z)
- +6 QUIT X
- SET1(X) ;Sets the XMTEXT global
- +1 SET SDLN=SDLN+1
- SET ^TMP("SDMHP",$JOB,SDLN,0)=X
- QUIT
- SET ;
- +1 SET X=""
- SET SDLN=SDLN+1
- SET ^TMP("SDPRO1",$JOB,SDLN,0)=X
- +2 QUIT
- +3 ;
- +4 ;
- FUT ; FUTURE SCHEDULED APPTS.
- +1 NEW SDARRAY,SDCOUNT,SDX,X1,X2,X,SDPRODAY
- +2 SET SDPRODAY=$$GET^XPAR("SYS^PKG.SCHEDULING","SDMH PROACTIVE DAYS",1,"Q")
- +3 SET SDPRODAY=$SELECT(SDPRODAY]"":SDPRODAY,1:30)
- +4 ;Find Scheduled apointments for SDPRODAY days using scheduling API
- +5 SET X1=DT
- SET X2=SDPRODAY
- DO C^%DTC
- SET SDX=X
- +6 SET SDARRAY(1)=DT_";"_SDX
- +7 SET SDARRAY("SORT")="P"
- +8 SET SDARRAY(3)="NT;R"
- +9 SET SDARRAY(4)=SDXDFN
- +10 SET SDARRAY("FLDS")="1;2;3;4;10;13"
- +11 SET SDCOUNT=$$SDAPI^SDAMA301(.SDARRAY)
- +12 IF SDCOUNT>0
- Begin DoDot:1
- +13 ;Get info on future scheduled appointments and display it
- +14 SET SDX=""
- SET X=""
- +15 NEW SDFA,SDFNODE,SDFUTDT
- +16 ;!($P($G(SDFA),".",1))'=$P(SDBEG,".",1) D
- SET SDFA=0
- FOR
- SET SDFA=$ORDER(^TMP($JOB,"SDAMA301",SDXDFN,SDFA))
- if SDFA=""
- QUIT
- Begin DoDot:2
- +17 SET (SDX,X)=""
- +18 SET SDFUTDT=$$FMTE^XLFDT(SDFA,"5")
- SET SDFNODE=^TMP($JOB,"SDAMA301",SDXDFN,SDFA)
- +19 NEW SDCLCD
- SET SDCLCD=$PIECE($PIECE($GET(SDFNODE),"^",2),";",1)
- IF SDCLCD]""
- SET SDCLCD=$PIECE($GET(^SC(SDCLCD,0)),"^",15)
- if SDXDIV'=$PIECE($GET(^DG(40.8,SDCLCD,0)),"^",1)
- QUIT
- +20 IF '$DATA(SDXX)
- SET SDX=$$SETSTR(SDFUTDT,X,32,16)_$$SETSTR($PIECE($PIECE(SDFNODE,"^",2),";",2),X,2,30)
- +21 IF $DATA(SDXX)
- SET SDX=SDXX_$$SETSTR(SDFUTDT,X,2,16)_$$SETSTR($PIECE($PIECE(SDFNODE,"^",2),";",2),X,2,30)
- KILL SDXX
- +22 DO SET1(SDX)
- End DoDot:2
- +23 NEW SDX
- SET SDX=$$SETSTR(" ",X,1,81)
- DO SET1(SDX)
- +24 QUIT
- End DoDot:1
- if SDUP
- QUIT
- +25 IF SDCOUNT'>0
- Begin DoDot:1
- +26 SET (SDX,X)=""
- +27 SET SDX=" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN "_SDPRODAY_$SELECT(SDPRODAY=1:" DAY",1:" DAYS")
- +28 SET SDX=$$SETSTR(SDX,X,1,80)
- DO SET1(SDX)
- End DoDot:1
- +29 ;.S SDX=$$SETSTR(" Future Scheduled Appointments: NO APPOINTMENTS SCHEDULED WITHIN 30 DAYS",X,1,80) D SET1(SDX)
- +30 KILL ^TMP($JOB,"SDAMA301")
- +31 QUIT
- +32 ;
- +33 ;
- PID(DFN) ; Return PID
- +1 ; INPUT - DFN
- +2 ; OUTPUT - PID or 'UNKNOWN'
- +3 NEW VA
- +4 DO PID^VADPT6
- +5 QUIT $SELECT(VA("BID")]"":VA("BID"),1:"UNKNOWN")
- +6 ;
