BPCAPPT ; IHS/OIT/MJL - GUI APPT LIST ;
;;1.5;BPC;;MAY 26, 2005
;MODIFIED FOR IHS GUI CHART FJE 5/1/00 FROM BPC2D RTN
;
GETAPPT(BGUARRAY,BPCPIEN,BPCSDATE,BPCEDATE) ;EP REMOTE PROC: BPC GET SD APPT DATA
D ENA,KILL Q
;
ENA ;
;S BPCPIEN=25241,BPCSDATE="06/11/00",BPCEDATE="06/11/01"
D ^XBKVAR
S BPCCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S BPCGUI=1,X="",XWBWRAP=1 K ^TMP($J)
S BGUARRAY="^TMP("_$J_")"
I $G(BPCPIEN)="" S ^TMP($J,1)=-1,^TMP($J,2)="PATIENT IEN NOT SENT!" Q
I $G(BPCSDATE)="" S ^TMP($J,1)=-1,^TMP($J,2)="STARTING DATE NOT SENT!" Q
I $G(BPCEDATE)="" S ^TMP($J,1)=-1,^TMP($J,2)="ENDING DATE NOT SENT!" Q
S CNTR=2
S BPCPAT=BPCPIEN
S:BPCEDATE="" BPCEDATE="T"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
I '$D(^DPT(BPCPAT,"S")) S ^TMP($J,1)=1,^TMP($J,2)="No Appointment Data Available" Q
D:$O(^DPT(BPCPAT,"S",DT)) PEND
D:$O(^DPT(BPCPAT,"S",0)) PAST
I CNTR=2 S ^TMP($J,1)=1,^TMP($J,2)="No Data Available" Q
S ^TMP($J,1)=CNTR-2
Q
;
PAST ;
S BPCN=0 F S BPCN=$O(^DPT(BPCPAT,"S",BPCN)) Q:'BPCN D
.Q:BPCN<BPCSDAT
.Q:BPCN>(DT-.01)
.Q:BPCN>(BPCEDAT+.24)
.S BPC(9999999-BPCN)=""
S BPCIDT=0,BPCIDT=$O(BPC(BPCIDT)) I BPCIDT S ^TMP($J,CNTR)="Past:",CNTR=CNTR+1
S BPCIDT=0 F S BPCIDT=$O(BPC(BPCIDT)) Q:'BPCIDT D
.S BPCVDT=9999999-BPCIDT
.S BPCN=^DPT(BPCPAT,"S",BPCVDT,0)
.S Y=BPCVDT\1 X BPCCVD S BPCDAT=Y
.S BPCVT=$E($P(BPCVDT,".",2)_"000",1,4) S:BPCVT>1300 BPCVT=BPCVT-1200 S:$L(BPCVT)=3 BPCVT=" "_BPCVT S:$E(BPCVT)="0" BPCVT=" "_$E(BPCVT,2,4) S BPCVT=$E(BPCVT,1,2)_":"_$E(BPCVT,3,4)
.S BPCTST="" F BPCI=3,4,5 S BPCJ=$P(BPCN,U,BPCI) I BPCJ S:BPCTST]"" BPCTST=BPCTST_"," S BPCTST=BPCTST_$P("^^LAB^XRAY^EKG^",U,BPCI)
.S BPCCP=+BPCN,BPCCN=$P($G(^SC(BPCCP,0)),U,1)
.S BPCTST="",BPCVNT=""
.S BPCVN=0 F BPCQ=0:0 S BPCVN=$O(^SC(BPCCP,"S",BPCVDT,1,BPCVN)) Q:'BPCVN I +^(BPCVN,0)=BPCPAT S BPCTST=$P(^(0),U,2),BPCVNT=$P(^(0),U,4) S:BPCTST BPCTST=BPCTST_" min."
.F BPCI=3,4,5 S BPCJ=$P(BPCN,U,BPCI) I BPCJ S:BPCTST]"" BPCTST=BPCTST_"," S BPCTST=BPCTST_$P("^^LAB^XRAY^EKG^",U,BPCI)
.S ^TMP($J,CNTR)=BPCDAT_"^"_BPCVT_"^"_BPCCN S:BPCTST]"" BPCTST="<"_BPCTST_">" S ^TMP($J,CNTR)=^TMP($J,CNTR)_"^"_BPCTST
.S ^TMP($J,CNTR)=^TMP($J,CNTR)_"^"_BPCVNT
.S CNTR=CNTR+1
Q
;
PEND ;
S CNTR=CNTR+1,^TMP($J,CNTR)="Pending:",CNTR=CNTR+1
S BPCDAT=0,BPCVDT=DT-.01 F BPCQ=0:0 S BPCVDT=$O(^DPT(BPCPAT,"S",BPCVDT)) Q:'BPCVDT D
.S BPCN=^DPT(BPCPAT,"S",BPCVDT,0)
.S Y=BPCVDT\1 X BPCCVD S BPCDAT=Y
.S BPCVT=$E($P(BPCVDT,".",2)_"000",1,4) S:BPCVT>1300 BPCVT=BPCVT-1200 S:$L(BPCVT)=3 BPCVT=" "_BPCVT S:$E(BPCVT)="0" BPCVT=" "_$E(BPCVT,2,4) S BPCVT=$E(BPCVT,1,2)_":"_$E(BPCVT,3,4)
.S BPCTST="" F BPCI=3,4,5 S BPCJ=$P(BPCN,U,BPCI) I BPCJ S:BPCTST]"" BPCTST=BPCTST_"," S BPCTST=BPCTST_$P("^^LAB^XRAY^EKG^",U,BPCI)
.S BPCCP=+BPCN,BPCCN=$P($G(^SC(BPCCP,0)),U,1)
.S BPCTST="",BPCVNT=""
.S BPCVN=0 F BPCQ=0:0 S BPCVN=$O(^SC(BPCCP,"S",BPCVDT,1,BPCVN)) Q:'BPCVN I +^(BPCVN,0)=BPCPAT S BPCTST=$P(^(0),U,2),BPCVNT=$P(^(0),U,4) S:BPCTST BPCTST=BPCTST_" min."
.F BPCI=3,4,5 S BPCJ=$P(BPCN,U,BPCI) I BPCJ S:BPCTST]"" BPCTST=BPCTST_"," S BPCTST=BPCTST_$P("^^LAB^XRAY^EKG^",U,BPCI)
.S ^TMP($J,CNTR)=BPCDAT_"^"_BPCVT_"^"_BPCCN S:BPCTST]"" BPCTST="<"_BPCTST_">" S ^TMP($J,CNTR)=^TMP($J,CNTR)_"^"_BPCTST
.S ^TMP($J,CNTR)=^TMP($J,CNTR)_"^"_BPCVNT
.S CNTR=CNTR+1
Q
KILL ;
K BPC,BPCCN,BPCCP,BPCCVD,BPCDAT,BPCEDATE,BPCGUI,BPCIDT,BPCJ,BPCN,BPCPAT,BPCSDATE,BPCTST,BPCVDT,BPCVN,BPCVNT,BPCVT,CNTR,X,Y
Q
BPCAPPT ; IHS/OIT/MJL - GUI APPT LIST ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;MODIFIED FOR IHS GUI CHART FJE 5/1/00 FROM BPC2D RTN
+3 ;
GETAPPT(BGUARRAY,BPCPIEN,BPCSDATE,BPCEDATE) ;EP REMOTE PROC: BPC GET SD APPT DATA
+1 DO ENA
DO KILL
QUIT
+2 ;
ENA ;
+1 ;S BPCPIEN=25241,BPCSDATE="06/11/00",BPCEDATE="06/11/01"
+2 DO ^XBKVAR
+3 SET BPCCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+4 SET BPCGUI=1
SET X=""
SET XWBWRAP=1
KILL ^TMP($JOB)
+5 SET BGUARRAY="^TMP("_$JOB_")"
+6 IF $GET(BPCPIEN)=""
SET ^TMP($JOB,1)=-1
SET ^TMP($JOB,2)="PATIENT IEN NOT SENT!"
QUIT
+7 IF $GET(BPCSDATE)=""
SET ^TMP($JOB,1)=-1
SET ^TMP($JOB,2)="STARTING DATE NOT SENT!"
QUIT
+8 IF $GET(BPCEDATE)=""
SET ^TMP($JOB,1)=-1
SET ^TMP($JOB,2)="ENDING DATE NOT SENT!"
QUIT
+9 SET CNTR=2
+10 SET BPCPAT=BPCPIEN
+11 IF BPCEDATE=""
SET BPCEDATE="T"
+12 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+13 IF BPCSDAT=-1
Begin DoDot:1
+14 SET BPCSDATE="1/1/1980"
+15 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+16 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+17 IF BPCEDAT=-1
Begin DoDot:1
+18 SET BPCEDATE="T"
+19 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+20 IF '$DATA(^DPT(BPCPAT,"S"))
SET ^TMP($JOB,1)=1
SET ^TMP($JOB,2)="No Appointment Data Available"
QUIT
+21 IF $ORDER(^DPT(BPCPAT,"S",DT))
DO PEND
+22 IF $ORDER(^DPT(BPCPAT,"S",0))
DO PAST
+23 IF CNTR=2
SET ^TMP($JOB,1)=1
SET ^TMP($JOB,2)="No Data Available"
QUIT
+24 SET ^TMP($JOB,1)=CNTR-2
+25 QUIT
+26 ;
PAST ;
+1 SET BPCN=0
FOR
SET BPCN=$ORDER(^DPT(BPCPAT,"S",BPCN))
IF 'BPCN
QUIT
Begin DoDot:1
+2 IF BPCN<BPCSDAT
QUIT
+3 IF BPCN>(DT-.01)
QUIT
+4 IF BPCN>(BPCEDAT+.24)
QUIT
+5 SET BPC(9999999-BPCN)=""
End DoDot:1
+6 SET BPCIDT=0
SET BPCIDT=$ORDER(BPC(BPCIDT))
IF BPCIDT
SET ^TMP($JOB,CNTR)="Past:"
SET CNTR=CNTR+1
+7 SET BPCIDT=0
FOR
SET BPCIDT=$ORDER(BPC(BPCIDT))
IF 'BPCIDT
QUIT
Begin DoDot:1
+8 SET BPCVDT=9999999-BPCIDT
+9 SET BPCN=^DPT(BPCPAT,"S",BPCVDT,0)
+10 SET Y=BPCVDT\1
XECUTE BPCCVD
SET BPCDAT=Y
+11 SET BPCVT=$EXTRACT($PIECE(BPCVDT,".",2)_"000",1,4)
IF BPCVT>1300
SET BPCVT=BPCVT-1200
IF $LENGTH(BPCVT)=3
SET BPCVT=" "_BPCVT
IF $EXTRACT(BPCVT)="0"
SET BPCVT=" "_$EXTRACT(BPCVT,2,4)
SET BPCVT=$EXTRACT(BPCVT,1,2)_":"_$EXTRACT(BPCVT,3,4)
+12 SET BPCTST=""
FOR BPCI=3,4,5
SET BPCJ=$PIECE(BPCN,U,BPCI)
IF BPCJ
IF BPCTST]""
SET BPCTST=BPCTST_","
SET BPCTST=BPCTST_$PIECE("^^LAB^XRAY^EKG^",U,BPCI)
+13 SET BPCCP=+BPCN
SET BPCCN=$PIECE($GET(^SC(BPCCP,0)),U,1)
+14 SET BPCTST=""
SET BPCVNT=""
+15 SET BPCVN=0
FOR BPCQ=0:0
SET BPCVN=$ORDER(^SC(BPCCP,"S",BPCVDT,1,BPCVN))
IF 'BPCVN
QUIT
IF +^(BPCVN,0)=BPCPAT
SET BPCTST=$PIECE(^(0),U,2)
SET BPCVNT=$PIECE(^(0),U,4)
IF BPCTST
SET BPCTST=BPCTST_" min."
+16 FOR BPCI=3,4,5
SET BPCJ=$PIECE(BPCN,U,BPCI)
IF BPCJ
IF BPCTST]""
SET BPCTST=BPCTST_","
SET BPCTST=BPCTST_$PIECE("^^LAB^XRAY^EKG^",U,BPCI)
+17 SET ^TMP($JOB,CNTR)=BPCDAT_"^"_BPCVT_"^"_BPCCN
IF BPCTST]""
SET BPCTST="<"_BPCTST_">"
SET ^TMP($JOB,CNTR)=^TMP($JOB,CNTR)_"^"_BPCTST
+18 SET ^TMP($JOB,CNTR)=^TMP($JOB,CNTR)_"^"_BPCVNT
+19 SET CNTR=CNTR+1
End DoDot:1
+20 QUIT
+21 ;
PEND ;
+1 SET CNTR=CNTR+1
SET ^TMP($JOB,CNTR)="Pending:"
SET CNTR=CNTR+1
+2 SET BPCDAT=0
SET BPCVDT=DT-.01
FOR BPCQ=0:0
SET BPCVDT=$ORDER(^DPT(BPCPAT,"S",BPCVDT))
IF 'BPCVDT
QUIT
Begin DoDot:1
+3 SET BPCN=^DPT(BPCPAT,"S",BPCVDT,0)
+4 SET Y=BPCVDT\1
XECUTE BPCCVD
SET BPCDAT=Y
+5 SET BPCVT=$EXTRACT($PIECE(BPCVDT,".",2)_"000",1,4)
IF BPCVT>1300
SET BPCVT=BPCVT-1200
IF $LENGTH(BPCVT)=3
SET BPCVT=" "_BPCVT
IF $EXTRACT(BPCVT)="0"
SET BPCVT=" "_$EXTRACT(BPCVT,2,4)
SET BPCVT=$EXTRACT(BPCVT,1,2)_":"_$EXTRACT(BPCVT,3,4)
+6 SET BPCTST=""
FOR BPCI=3,4,5
SET BPCJ=$PIECE(BPCN,U,BPCI)
IF BPCJ
IF BPCTST]""
SET BPCTST=BPCTST_","
SET BPCTST=BPCTST_$PIECE("^^LAB^XRAY^EKG^",U,BPCI)
+7 SET BPCCP=+BPCN
SET BPCCN=$PIECE($GET(^SC(BPCCP,0)),U,1)
+8 SET BPCTST=""
SET BPCVNT=""
+9 SET BPCVN=0
FOR BPCQ=0:0
SET BPCVN=$ORDER(^SC(BPCCP,"S",BPCVDT,1,BPCVN))
IF 'BPCVN
QUIT
IF +^(BPCVN,0)=BPCPAT
SET BPCTST=$PIECE(^(0),U,2)
SET BPCVNT=$PIECE(^(0),U,4)
IF BPCTST
SET BPCTST=BPCTST_" min."
+10 FOR BPCI=3,4,5
SET BPCJ=$PIECE(BPCN,U,BPCI)
IF BPCJ
IF BPCTST]""
SET BPCTST=BPCTST_","
SET BPCTST=BPCTST_$PIECE("^^LAB^XRAY^EKG^",U,BPCI)
+11 SET ^TMP($JOB,CNTR)=BPCDAT_"^"_BPCVT_"^"_BPCCN
IF BPCTST]""
SET BPCTST="<"_BPCTST_">"
SET ^TMP($JOB,CNTR)=^TMP($JOB,CNTR)_"^"_BPCTST
+12 SET ^TMP($JOB,CNTR)=^TMP($JOB,CNTR)_"^"_BPCVNT
+13 SET CNTR=CNTR+1
End DoDot:1
+14 QUIT
KILL ;
+1 KILL BPC,BPCCN,BPCCP,BPCCVD,BPCDAT,BPCEDATE,BPCGUI,BPCIDT,BPCJ,BPCN,BPCPAT,BPCSDATE,BPCTST,BPCVDT,BPCVN,BPCVNT,BPCVT,CNTR,X,Y
+2 QUIT
