APCHS2D ; IHS/CMI/LAB - PART 2D OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
;
SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 **********
; <SETUP>
Q:'$D(^DPT(APCHSPAT,"S"))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSI=$O(^DPT(APCHSPAT,"S",0)) I APCHSI,APCHSI<DT D PAST
D:$O(^DPT(APCHSPAT,"S",DT)) PEND
; <CLEANUP>
SCHENCX K APCHSVDT,APCHSVD1,APCHSIVD,APCHSDAT,APCHSPVD,APCHSN,APCHSVT,APCHSCN,APCHSCP,APCHSTST,APCHSI,APCHSJ,APCHSET,APCHSHP,APCHSVN,APCHSVNT,Y
Q
;
PAST ;
K ^TMP($J,"APCHS")
S APCHSVD1=9999999-APCHSDLM,APCHSDAT=0,APCHSI=0
S APCHSVDT=APCHSVD1 F APCHSQ=0:0 S APCHSVDT=$O(^DPT(APCHSPAT,"S",APCHSVDT)) Q:'APCHSVDT!(APCHSVDT>DT) D ADDONE
Q:'$O(^TMP($J,"APCHS",""))
S APCHSET="PAST:" X APCHSCKP Q:$D(APCHSQIT) W APCHSET,!
S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHS",APCHSIVD)) Q:'APCHSIVD S APCHSVDT=^(APCHSIVD) D ONEVIS Q:$D(APCHSQIT)
K ^TMP($J,"APCHS")
Q
;
ADDONE S APCHSIVD=9999999.9999-APCHSVDT
S APCHSI=APCHSI+1,^TMP($J,"APCHS",APCHSIVD)=APCHSVDT,^TMP($J,"APCHS","B",APCHSVDT)=""
I APCHSNDM>0,APCHSI>APCHSNDM S APCHSI=APCHSI-1,APCHSJ=$O(^TMP($J,"APCHS","B","")) K ^(APCHSJ) K ^TMP($J,"APCHS",9999999.9999-APCHSJ)
Q
PEND ;
S APCHSET="PENDING:" X APCHSCKP Q:$D(APCHSQIT) W APCHSET,!
S APCHSDAT=0,APCHSVDT=DT-.01 F APCHSQ=0:0 S APCHSVDT=$O(^DPT(APCHSPAT,"S",APCHSVDT)) Q:'APCHSVDT D ONEVIS Q:$D(APCHSQIT)
Q
;
ONEVIS S APCHSN=^DPT(APCHSPAT,"S",APCHSVDT,0)
Q:"CP"[$E($P(APCHSN,U,2)_" ")
S APCHSAM="am"
;Q:$P(APCHSN,U,7)=4 ;skip unscheduled
I APCHSVDT\1'=APCHSDAT S Y=APCHSVDT\1 X APCHSCVD S (APCHSPVD,APCHSDAT)=Y,APCHSNDM=APCHSNDM-1
S APCHSVT=$E($P(APCHSVDT,".",2)_"000",1,4) S:APCHSVT>1159 APCHSAM="pm" S:APCHSVT>1300 APCHSVT=APCHSVT-1200 S:$L(APCHSVT)=3 APCHSVT=" "_APCHSVT S:$E(APCHSVT)="0" APCHSVT=" "_$E(APCHSVT,2,4) S APCHSVT=$E(APCHSVT,1,2)_":"_$E(APCHSVT,3,4)
S APCHSTST="" F APCHSI=3,4,5 S APCHSJ=$P(APCHSN,U,APCHSI) I APCHSJ S:APCHSTST]"" APCHSTST=APCHSTST_"," S APCHSTST=APCHSTST_$P("^^LAB^XRAY^EKG^",U,APCHSI)
S APCHSCP=+APCHSN,APCHSCN=$P($G(^SC(APCHSCP,0)),U,1) Q:APCHSCN=""
S APCHSTST="",APCHSVNT=""
S APCHSVN=0 F APCHSQ=0:0 S APCHSVN=$O(^SC(APCHSCP,"S",APCHSVDT,1,APCHSVN)) Q:'APCHSVN I +^(APCHSVN,0)=APCHSPAT S APCHSTST=$P(^(0),U,2),APCHSVNT=$P(^(0),U,4) S:APCHSTST APCHSTST=APCHSTST_" min."
F APCHSI=3,4,5 S APCHSJ=$P(APCHSN,U,APCHSI) I APCHSJ S:APCHSTST]"" APCHSTST=APCHSTST_"," S APCHSTST=APCHSTST_$P("^^LAB^XRAY^EKG^",U,APCHSI)
D L1
I APCHSVNT]"" X APCHSCKP Q:$D(APCHSQIT) D:APCHSNPG L1 W ?20,APCHSVNT,!
Q
L1 X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W APCHSET,! S APCHSDAT=APCHSPVD
W ?2,APCHSDAT,?11,APCHSVT,APCHSAM,?20,APCHSCN W:APCHSTST]"" " (",APCHSTST,")"
W:$P(APCHSN,U,2)["N" ?37,"*** DNKA ***" W !
Q
WAIT ;EP - active wait list entries for patient
I $T(WLDATA^BSDWLV)="" W !!,"The scheduling routine for Wait List is missing, cannot display data." Q
K APCHWAIT
D WLDATA^BSDWLV(APCHSPAT,,.APCHWAIT)
Q:'$D(APCHWAIT)
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
W APCHWAIT(0),!
S APCHSD="" F S APCHSD=$O(APCHWAIT(APCHSD)) Q:APCHSD=""!($D(APCHSQIT)) D
.S APCHSX=0 F S APCHSX=$O(APCHWAIT(APCHSD,APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W $P(APCHWAIT(APCHSD,APCHSX),U,2),!
; <CLEANUP>
WAITX K APCHWAIT
Q
APCHS2D ; IHS/CMI/LAB - PART 2D OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+2 ;
+3 ;
SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 **********
+1 ; <SETUP>
+2 IF '$DATA(^DPT(APCHSPAT,"S"))
QUIT
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 SET APCHSI=$ORDER(^DPT(APCHSPAT,"S",0))
IF APCHSI
IF APCHSI<DT
DO PAST
+6 IF $ORDER(^DPT(APCHSPAT,"S",DT))
DO PEND
+7 ; <CLEANUP>
SCHENCX KILL APCHSVDT,APCHSVD1,APCHSIVD,APCHSDAT,APCHSPVD,APCHSN,APCHSVT,APCHSCN,APCHSCP,APCHSTST,APCHSI,APCHSJ,APCHSET,APCHSHP,APCHSVN,APCHSVNT,Y
+1 QUIT
+2 ;
PAST ;
+1 KILL ^TMP($JOB,"APCHS")
+2 SET APCHSVD1=9999999-APCHSDLM
SET APCHSDAT=0
SET APCHSI=0
+3 SET APCHSVDT=APCHSVD1
FOR APCHSQ=0:0
SET APCHSVDT=$ORDER(^DPT(APCHSPAT,"S",APCHSVDT))
IF 'APCHSVDT!(APCHSVDT>DT)
QUIT
DO ADDONE
+4 IF '$ORDER(^TMP($JOB,"APCHS",""))
QUIT
+5 SET APCHSET="PAST:"
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSET,!
+6 SET APCHSIVD=0
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHS",APCHSIVD))
IF 'APCHSIVD
QUIT
SET APCHSVDT=^(APCHSIVD)
DO ONEVIS
IF $DATA(APCHSQIT)
QUIT
+7 KILL ^TMP($JOB,"APCHS")
+8 QUIT
+9 ;
ADDONE SET APCHSIVD=9999999.9999-APCHSVDT
+1 SET APCHSI=APCHSI+1
SET ^TMP($JOB,"APCHS",APCHSIVD)=APCHSVDT
SET ^TMP($JOB,"APCHS","B",APCHSVDT)=""
+2 IF APCHSNDM>0
IF APCHSI>APCHSNDM
SET APCHSI=APCHSI-1
SET APCHSJ=$ORDER(^TMP($JOB,"APCHS","B",""))
KILL ^(APCHSJ)
KILL ^TMP($JOB,"APCHS",9999999.9999-APCHSJ)
+3 QUIT
PEND ;
+1 SET APCHSET="PENDING:"
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSET,!
+2 SET APCHSDAT=0
SET APCHSVDT=DT-.01
FOR APCHSQ=0:0
SET APCHSVDT=$ORDER(^DPT(APCHSPAT,"S",APCHSVDT))
IF 'APCHSVDT
QUIT
DO ONEVIS
IF $DATA(APCHSQIT)
QUIT
+3 QUIT
+4 ;
ONEVIS SET APCHSN=^DPT(APCHSPAT,"S",APCHSVDT,0)
+1 IF "CP"[$EXTRACT($PIECE(APCHSN,U,2)_" ")
QUIT
+2 SET APCHSAM="am"
+3 ;Q:$P(APCHSN,U,7)=4 ;skip unscheduled
+4 IF APCHSVDT\1'=APCHSDAT
SET Y=APCHSVDT\1
XECUTE APCHSCVD
SET (APCHSPVD,APCHSDAT)=Y
SET APCHSNDM=APCHSNDM-1
+5 SET APCHSVT=$EXTRACT($PIECE(APCHSVDT,".",2)_"000",1,4)
IF APCHSVT>1159
SET APCHSAM="pm"
IF APCHSVT>1300
SET APCHSVT=APCHSVT-1200
IF $LENGTH(APCHSVT)=3
SET APCHSVT=" "_APCHSVT
IF $EXTRACT(APCHSVT)="0"
SET APCHSVT=" "_$EXTRACT(APCHSVT,2,4)
SET APCHSVT=$EXTRACT(APCHSVT,1,2)_":"_$EXTRACT(APCHSVT,3,4)
+6 SET APCHSTST=""
FOR APCHSI=3,4,5
SET APCHSJ=$PIECE(APCHSN,U,APCHSI)
IF APCHSJ
IF APCHSTST]""
SET APCHSTST=APCHSTST_","
SET APCHSTST=APCHSTST_$PIECE("^^LAB^XRAY^EKG^",U,APCHSI)
+7 SET APCHSCP=+APCHSN
SET APCHSCN=$PIECE($GET(^SC(APCHSCP,0)),U,1)
IF APCHSCN=""
QUIT
+8 SET APCHSTST=""
SET APCHSVNT=""
+9 SET APCHSVN=0
FOR APCHSQ=0:0
SET APCHSVN=$ORDER(^SC(APCHSCP,"S",APCHSVDT,1,APCHSVN))
IF 'APCHSVN
QUIT
IF +^(APCHSVN,0)=APCHSPAT
SET APCHSTST=$PIECE(^(0),U,2)
SET APCHSVNT=$PIECE(^(0),U,4)
IF APCHSTST
SET APCHSTST=APCHSTST_" min."
+10 FOR APCHSI=3,4,5
SET APCHSJ=$PIECE(APCHSN,U,APCHSI)
IF APCHSJ
IF APCHSTST]""
SET APCHSTST=APCHSTST_","
SET APCHSTST=APCHSTST_$PIECE("^^LAB^XRAY^EKG^",U,APCHSI)
+11 DO L1
+12 IF APCHSVNT]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
DO L1
WRITE ?20,APCHSVNT,!
+13 QUIT
L1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE APCHSET,!
SET APCHSDAT=APCHSPVD
+1 WRITE ?2,APCHSDAT,?11,APCHSVT,APCHSAM,?20,APCHSCN
IF APCHSTST]""
WRITE " (",APCHSTST,")"
+2 IF $PIECE(APCHSN,U,2)["N"
WRITE ?37,"*** DNKA ***"
WRITE !
+3 QUIT
WAIT ;EP - active wait list entries for patient
+1 IF $TEXT(WLDATA^BSDWLV)=""
WRITE !!,"The scheduling routine for Wait List is missing, cannot display data."
QUIT
+2 KILL APCHWAIT
+3 DO WLDATA^BSDWLV(APCHSPAT,,.APCHWAIT)
+4 IF '$DATA(APCHWAIT)
QUIT
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 ; <DISPLAY>
+7 WRITE APCHWAIT(0),!
+8 SET APCHSD=""
FOR
SET APCHSD=$ORDER(APCHWAIT(APCHSD))
IF APCHSD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+9 SET APCHSX=0
FOR
SET APCHSX=$ORDER(APCHWAIT(APCHSD,APCHSX))
IF APCHSX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 WRITE $PIECE(APCHWAIT(APCHSD,APCHSX),U,2),!
End DoDot:2
End DoDot:1
+12 ; <CLEANUP>
WAITX KILL APCHWAIT
+1 QUIT
