TIULO1 ; SLC/JER - More embedded Objects ;05/31/12 14:33
;;1.0;TEXT INTEGRATION UTILITIES;**47,260,265**;Jun 20, 1997;Build 25
;
;^XLFSTR 10104, ^XLFDT 10103, ^PXRMD(810.9 5599, ^SC("AST" 4482, ^SDAPI^SDAMA301 4433, ^VADPT 10061
;^LAB(60,"B" 3853, LR7OR2 3856
;
VISDATE(TIU) ; Visit date/time
N TIUX,TIUY
S TIUX=$S(+$G(TIU("VISIT")):$P($G(TIU("VISIT")),U,2),$L($G(TIU("VSTR"))):$P($G(TIU("VSTR")),";",2),1:"")
I TIUX']"" S TIUY="VISIT DATE UNKNOWN" G VISDTX
S TIUY=$$DATE^TIULS(TIUX,"MM/DD/YY HR:MIN")
VISDTX Q $G(TIUY)
LABS(DFN,TIUTEST,TIUEDT,TIULDT) ; Get Lab Results
N TIUY,TIUTST,TIUX S TIUTST=+$O(^LAB(60,"B",TIUTEST,0))
I '+$G(TIUTST) G LABX
D TEST^LR7OR2(.TIUY,DFN,"",$G(TIUEDT),$G(TIULDT),"",TIUTST)
S TIUX=$S($D(TIUY)#2:$G(@TIUY@(1)),1:"____")
I $L(TIUX,U)>1 D
. S TIUTST=$P(TIUX,U,4)_" "_$P(TIUX,U,6)_" "_$P(TIUX,U,5)_" ("
. S TIUTST=TIUTST_$$DATE^TIULS($P(TIUX,U),"MM/DD/CCYY HR:MIN")_")"
E S TIUTST=TIUX
I $D(TIUY)#2 K @TIUY
LABX Q $G(TIUTST)
;
HPHONE(DFN) ;Current Home Telephone Number
N VAPA
D ADD^VADPT
HPHX Q $G(VAPA(8))
;
SADD(DFN) ;Single Line Street Address
N VAPA,J
D ADD^VADPT
S:$D(VAPA(1)) J=VAPA(1) S:$D(VAPA(2)) J=J_" "_VAPA(2) S:$D(VAPA(3)) J=J_" "_VAPA(3)
SADX Q J
;
CISTZI(DFN) ;City, State, Zip
N VAPA,J
D ADD^VADPT
S:$D(VAPA(4)) J=VAPA(4) S:$D(VAPA(5)) J=J_", "_$P(VAPA(5),U,2) S:$D(VAPA(6)) J=J_", "_VAPA(6)
CSTX Q J
;
MSTAPPT(DFN,TARGET) ;Missed MH appointments for past 10 days;; WAT-TIU*1.0*260
K ^TMP($J,"TIU CLIN LIST"),@TARGET
N CLINCNT S CLINCNT=1
N RMLL,RMLLSTP,RMCLINIC,RMCLNCNT
N TIUARR,SDCOUNT,SDDFN,SDDATE,SDAPPT,SDDATIME,SDCLINIC,APSTATUS,CLINAME
N LINE,IDX1,ERROR,ENDT,DASH73
S $P(DASH73,"=",73)="="
S LINE=0,ERROR=0
S @TARGET@(LINE,0)="",LINE=LINE+1
S @TARGET@(LINE,0)="MH Appointments Missed Last 10 Days",LINE=LINE+1
S @TARGET@(LINE,0)="",LINE=LINE+1
S RMLL=$O(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL",""))
S RMCLNCNT=0,IDX1=0,RMCLINIC=""
I $G(RMLL)="" S SDCOUNT=0 D ERROR Q "~@"_$NA(@TARGET) ;error and quit if RMLL not found
F S IDX1=$O(^PXRMD(810.9,RMLL,40.7,IDX1)) Q:IDX1'>0!(ERROR=1) D
.S RMLLSTP=^PXRMD(810.9,RMLL,40.7,IDX1,0)
.S RMLLSTP=$P($G(RMLLSTP),"^") ;->this is the stop code, now get clinics for this stop code
.Q:$D(^SC("AST",RMLLSTP))=0
.F S RMCLINIC=$O(^SC("AST",RMLLSTP,RMCLINIC)) Q:RMCLINIC=""!(ERROR=1) D
..S ^TMP($J,"TIU CLIN LIST",RMCLINIC)=RMCLINIC
;NOW HAVE LIST OF CLINICS TO SEARCH FOR APPOINTMENTS
;CALL SDAPI ONCE FOR ALL CLINICS IN THE LIST
S ENDT=$$FMADD^XLFDT(DT,-10)
S TIUARR(1)=ENDT_";"_DT
S TIUARR(2)="^TMP($J,""TIU CLIN LIST""" ;an array of clinic IENs
S TIUARR(3)="NS;NSR" ;appt status NO SHOW & NO SHOW RESCHEDULED
S TIUARR(4)=DFN
S TIUARR("FLDS")="1;2;4;3"
S TIUARR("SORT")="P"
S SDCOUNT=$$SDAPI^SDAMA301(.TIUARR)
I SDCOUNT=0 S @TARGET@(LINE,0)="No Missed Appointments Found",LINE=LINE+1
I SDCOUNT<0 D ERROR Q "~@"_$NA(@TARGET)
I SDCOUNT>0 D
. S @TARGET@(LINE,0)="DATE/TIME"_$J("CLINIC",19)_$J("STATUS",32),LINE=LINE+1
. S @TARGET@(LINE,0)=DASH73,LINE=LINE+1
. S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301",SDDFN)) Q:SDDFN="" D
.. ;get appointment date/time
.. S SDDATE=0 F S SDDATE=$O(^TMP($J,"SDAMA301",SDDFN,SDDATE)) Q:SDDATE="" D
... S SDAPPT=$G(^TMP($J,"SDAMA301",SDDFN,SDDATE)) ;appointment data
... S SDDATIME=$P($G(SDAPPT),"^",1) ;appointment date/time
... S APSTATUS=$P($G(SDAPPT),"^",3),APSTATUS=$P(APSTATUS,";",2)
... S CLINAME=$P($G(SDAPPT),"^",2),CLINAME=$P(CLINAME,";",2) ;CLINIC NAME
... I $L(CLINAME)<30 S CLINAME=CLINAME_($$REPEAT^XLFSTR(" ",(30-$L(CLINAME))))
... S SDDATIME=$$FMTE^XLFDT(SDDATIME,"5ZP")
... I $L(SDDATIME)<20 S SDDATIME=SDDATIME_($$REPEAT^XLFSTR(" ",(22-$L(SDDATIME)))) ;WAT/265
... I APSTATUS["&" S APSTATUS=$E(APSTATUS,1,17)_"."
... I $L(APSTATUS)<18 S APSTATUS=APSTATUS_($$REPEAT^XLFSTR(" ",(18-$L(APSTATUS))))
... S @TARGET@(LINE,0)=SDDATIME_CLINAME_$J(APSTATUS,20),LINE=LINE+1
I SDCOUNT'=0 K ^TMP($J,"SDAMA301")
Q "~@"_$NA(@TARGET)
;
ERROR ;errors returned from SDAPI
N IDXERR S IDXERR=""
I $G(RMLL)="" S @TARGET@(LINE,0)="Reminder location list not found. Unable to retrun appointment data",LINE=LINE+1 Q
F S IDXERR=$O(^TMP($J,"SDAMA301",IDXERR)) Q:IDXERR'>0 D
.S @TARGET@(LINE,0)=^TMP($J,"SDAMA301",IDXERR),LINE=LINE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULO1 4354 printed Oct 16, 2024@18:42:57 Page 2
TIULO1 ; SLC/JER - More embedded Objects ;05/31/12 14:33
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**47,260,265**;Jun 20, 1997;Build 25
+2 ;
+3 ;^XLFSTR 10104, ^XLFDT 10103, ^PXRMD(810.9 5599, ^SC("AST" 4482, ^SDAPI^SDAMA301 4433, ^VADPT 10061
+4 ;^LAB(60,"B" 3853, LR7OR2 3856
+5 ;
VISDATE(TIU) ; Visit date/time
+1 NEW TIUX,TIUY
+2 SET TIUX=$SELECT(+$GET(TIU("VISIT")):$PIECE($GET(TIU("VISIT")),U,2),$LENGTH($GET(TIU("VSTR"))):$PIECE($GET(TIU("VSTR")),";",2),1:"")
+3 IF TIUX']""
SET TIUY="VISIT DATE UNKNOWN"
GOTO VISDTX
+4 SET TIUY=$$DATE^TIULS(TIUX,"MM/DD/YY HR:MIN")
VISDTX QUIT $GET(TIUY)
LABS(DFN,TIUTEST,TIUEDT,TIULDT) ; Get Lab Results
+1 NEW TIUY,TIUTST,TIUX
SET TIUTST=+$ORDER(^LAB(60,"B",TIUTEST,0))
+2 IF '+$GET(TIUTST)
GOTO LABX
+3 DO TEST^LR7OR2(.TIUY,DFN,"",$GET(TIUEDT),$GET(TIULDT),"",TIUTST)
+4 SET TIUX=$SELECT($DATA(TIUY)#2:$GET(@TIUY@(1)),1:"____")
+5 IF $LENGTH(TIUX,U)>1
Begin DoDot:1
+6 SET TIUTST=$PIECE(TIUX,U,4)_" "_$PIECE(TIUX,U,6)_" "_$PIECE(TIUX,U,5)_" ("
+7 SET TIUTST=TIUTST_$$DATE^TIULS($PIECE(TIUX,U),"MM/DD/CCYY HR:MIN")_")"
End DoDot:1
+8 IF '$TEST
SET TIUTST=TIUX
+9 IF $DATA(TIUY)#2
KILL @TIUY
LABX QUIT $GET(TIUTST)
+1 ;
HPHONE(DFN) ;Current Home Telephone Number
+1 NEW VAPA
+2 DO ADD^VADPT
HPHX QUIT $GET(VAPA(8))
+1 ;
SADD(DFN) ;Single Line Street Address
+1 NEW VAPA,J
+2 DO ADD^VADPT
+3 if $DATA(VAPA(1))
SET J=VAPA(1)
if $DATA(VAPA(2))
SET J=J_" "_VAPA(2)
if $DATA(VAPA(3))
SET J=J_" "_VAPA(3)
SADX QUIT J
+1 ;
CISTZI(DFN) ;City, State, Zip
+1 NEW VAPA,J
+2 DO ADD^VADPT
+3 if $DATA(VAPA(4))
SET J=VAPA(4)
if $DATA(VAPA(5))
SET J=J_", "_$PIECE(VAPA(5),U,2)
if $DATA(VAPA(6))
SET J=J_", "_VAPA(6)
CSTX QUIT J
+1 ;
MSTAPPT(DFN,TARGET) ;Missed MH appointments for past 10 days;; WAT-TIU*1.0*260
+1 KILL ^TMP($JOB,"TIU CLIN LIST"),@TARGET
+2 NEW CLINCNT
SET CLINCNT=1
+3 NEW RMLL,RMLLSTP,RMCLINIC,RMCLNCNT
+4 NEW TIUARR,SDCOUNT,SDDFN,SDDATE,SDAPPT,SDDATIME,SDCLINIC,APSTATUS,CLINAME
+5 NEW LINE,IDX1,ERROR,ENDT,DASH73
+6 SET $PIECE(DASH73,"=",73)="="
+7 SET LINE=0
SET ERROR=0
+8 SET @TARGET@(LINE,0)=""
SET LINE=LINE+1
+9 SET @TARGET@(LINE,0)="MH Appointments Missed Last 10 Days"
SET LINE=LINE+1
+10 SET @TARGET@(LINE,0)=""
SET LINE=LINE+1
+11 SET RMLL=$ORDER(^PXRMD(810.9,"B","VA-MH NO SHOW APPT CLINICS LL",""))
+12 SET RMCLNCNT=0
SET IDX1=0
SET RMCLINIC=""
+13 ;error and quit if RMLL not found
IF $GET(RMLL)=""
SET SDCOUNT=0
DO ERROR
QUIT "~@"_$NAME(@TARGET)
+14 FOR
SET IDX1=$ORDER(^PXRMD(810.9,RMLL,40.7,IDX1))
if IDX1'>0!(ERROR=1)
QUIT
Begin DoDot:1
+15 SET RMLLSTP=^PXRMD(810.9,RMLL,40.7,IDX1,0)
+16 ;->this is the stop code, now get clinics for this stop code
SET RMLLSTP=$PIECE($GET(RMLLSTP),"^")
+17 if $DATA(^SC("AST",RMLLSTP))=0
QUIT
+18 FOR
SET RMCLINIC=$ORDER(^SC("AST",RMLLSTP,RMCLINIC))
if RMCLINIC=""!(ERROR=1)
QUIT
Begin DoDot:2
+19 SET ^TMP($JOB,"TIU CLIN LIST",RMCLINIC)=RMCLINIC
End DoDot:2
End DoDot:1
+20 ;NOW HAVE LIST OF CLINICS TO SEARCH FOR APPOINTMENTS
+21 ;CALL SDAPI ONCE FOR ALL CLINICS IN THE LIST
+22 SET ENDT=$$FMADD^XLFDT(DT,-10)
+23 SET TIUARR(1)=ENDT_";"_DT
+24 ;an array of clinic IENs
SET TIUARR(2)="^TMP($J,""TIU CLIN LIST"""
+25 ;appt status NO SHOW & NO SHOW RESCHEDULED
SET TIUARR(3)="NS;NSR"
+26 SET TIUARR(4)=DFN
+27 SET TIUARR("FLDS")="1;2;4;3"
+28 SET TIUARR("SORT")="P"
+29 SET SDCOUNT=$$SDAPI^SDAMA301(.TIUARR)
+30 IF SDCOUNT=0
SET @TARGET@(LINE,0)="No Missed Appointments Found"
SET LINE=LINE+1
+31 IF SDCOUNT<0
DO ERROR
QUIT "~@"_$NAME(@TARGET)
+32 IF SDCOUNT>0
Begin DoDot:1
+33 SET @TARGET@(LINE,0)="DATE/TIME"_$JUSTIFY("CLINIC",19)_$JUSTIFY("STATUS",32)
SET LINE=LINE+1
+34 SET @TARGET@(LINE,0)=DASH73
SET LINE=LINE+1
+35 SET SDDFN=0
FOR
SET SDDFN=$ORDER(^TMP($JOB,"SDAMA301",SDDFN))
if SDDFN=""
QUIT
Begin DoDot:2
+36 ;get appointment date/time
+37 SET SDDATE=0
FOR
SET SDDATE=$ORDER(^TMP($JOB,"SDAMA301",SDDFN,SDDATE))
if SDDATE=""
QUIT
Begin DoDot:3
+38 ;appointment data
SET SDAPPT=$GET(^TMP($JOB,"SDAMA301",SDDFN,SDDATE))
+39 ;appointment date/time
SET SDDATIME=$PIECE($GET(SDAPPT),"^",1)
+40 SET APSTATUS=$PIECE($GET(SDAPPT),"^",3)
SET APSTATUS=$PIECE(APSTATUS,";",2)
+41 ;CLINIC NAME
SET CLINAME=$PIECE($GET(SDAPPT),"^",2)
SET CLINAME=$PIECE(CLINAME,";",2)
+42 IF $LENGTH(CLINAME)<30
SET CLINAME=CLINAME_($$REPEAT^XLFSTR(" ",(30-$LENGTH(CLINAME))))
+43 SET SDDATIME=$$FMTE^XLFDT(SDDATIME,"5ZP")
+44 ;WAT/265
IF $LENGTH(SDDATIME)<20
SET SDDATIME=SDDATIME_($$REPEAT^XLFSTR(" ",(22-$LENGTH(SDDATIME))))
+45 IF APSTATUS["&"
SET APSTATUS=$EXTRACT(APSTATUS,1,17)_"."
+46 IF $LENGTH(APSTATUS)<18
SET APSTATUS=APSTATUS_($$REPEAT^XLFSTR(" ",(18-$LENGTH(APSTATUS))))
+47 SET @TARGET@(LINE,0)=SDDATIME_CLINAME_$JUSTIFY(APSTATUS,20)
SET LINE=LINE+1
End DoDot:3
End DoDot:2
End DoDot:1
+48 IF SDCOUNT'=0
KILL ^TMP($JOB,"SDAMA301")
+49 QUIT "~@"_$NAME(@TARGET)
+50 ;
ERROR ;errors returned from SDAPI
+1 NEW IDXERR
SET IDXERR=""
+2 IF $GET(RMLL)=""
SET @TARGET@(LINE,0)="Reminder location list not found. Unable to retrun appointment data"
SET LINE=LINE+1
QUIT
+3 FOR
SET IDXERR=$ORDER(^TMP($JOB,"SDAMA301",IDXERR))
if IDXERR'>0
QUIT
Begin DoDot:1
+4 SET @TARGET@(LINE,0)=^TMP($JOB,"SDAMA301",IDXERR)
SET LINE=LINE+1
End DoDot:1
+5 QUIT
