BHSENCS ;IHS/CIA/MGH - Encounters from PCC ;23-Jun-2010 12:09;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**4**;March 17,2006;Build 13
;===================================================================
;Taken from APCHS2D
; IHS/TUCSON/LAB - PART 2D OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 03/01/04 10:50 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**11,12,4**;JUN 24, 1997
;
;
SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 **********
; <SETUP>
N BHSPAT
S BHSPAT=DFN
Q:'$D(^DPT(BHSPAT,"S"))
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSI=$O(^DPT(BHSPAT,"S",0)) I BHSI,BHSI<DT D PAST
D:$O(^DPT(BHSPAT,"S",DT)) PEND
; <CLEANUP>
SCHENCX K BHSVDT,BHSVD1,BHSAM,BHSQIT,BHSQ,BHSIVD,BHSDAT,BHSPVD,BHSN,BHSVT,BHSCN,BHSCP,BHSTST,BHSI,BHSJ,BHSET,BHSHP,BHSVN,BHSVNT,Y,X
Q
;
PAST ;
K ^TMP($J,"BHS")
S BHSVD1=9999999-GMTSDLM,BHSDAT=0,BHSI=0
S BHSVDT=BHSVD1 F BHSQ=0:0 S BHSVDT=$O(^DPT(BHSPAT,"S",BHSVDT)) Q:'BHSVDT!(BHSVDT>DT) D ADDONE
Q:'$O(^TMP($J,"BHS",""))
S BHSET="PAST:" D CKP^GMTSUP Q:$D(GMTSQIT) W BHSET,!
S BHSIVD=0 F BHSQ=0:0 S BHSIVD=$O(^TMP($J,"BHS",BHSIVD)) Q:'BHSIVD S BHSVDT=^(BHSIVD) D ONEVIS Q:$D(GMTSQIT)
K ^TMP($J,"BHS")
Q
;
ADDONE S BHSIVD=9999999.9999-BHSVDT
S BHSI=BHSI+1,^TMP($J,"BHS",BHSIVD)=BHSVDT,^TMP($J,"BHS","B",BHSVDT)=""
I GMTSNDM>0,BHSI>GMTSNDM S BHSI=BHSI-1,BHSJ=$O(^TMP($J,"BHS","B","")) K ^(BHSJ) K ^TMP($J,"BHS",9999999.9999-BHSJ)
Q
PEND ;
S BHSET="PENDING:" D CKP^GMTSUP Q:$D(GMTSQIT) W BHSET,!
S BHSDAT=0,BHSVDT=DT-.01 F BHSQ=0:0 S BHSVDT=$O(^DPT(BHSPAT,"S",BHSVDT)) Q:'BHSVDT D ONEVIS Q:$D(GMTSQIT)
Q
;
ONEVIS S BHSN=^DPT(BHSPAT,"S",BHSVDT,0)
Q:"CP"[$E($P(BHSN,U,2)_" ")
S BHSAM="am"
;Q:$P(BHSN,U,7)=4 ;skip unscheduled
I BHSVDT\1'=BHSDAT S X=BHSVDT\1 D REGDT4^GMTSU S (BHSPVD,BHSDAT)=X,GMTSNDM=GMTSNDM-1
S BHSVT=$E($P(BHSVDT,".",2)_"000",1,4) S:BHSVT>1159 BHSAM="pm" S:BHSVT>1300 BHSVT=BHSVT-1200 S:$L(BHSVT)=3 BHSVT=" "_BHSVT S:$E(BHSVT)="0" BHSVT=" "_$E(BHSVT,2,4) S BHSVT=$E(BHSVT,1,2)_":"_$E(BHSVT,3,4)
S BHSTST="" F BHSI=3,4,5 S BHSJ=$P(BHSN,U,BHSI) I BHSJ S:BHSTST]"" BHSTST=BHSTST_"," S BHSTST=BHSTST_$P("^^LAB^XRAY^EKG^",U,BHSI)
S BHSCP=+BHSN,BHSCN=$P($G(^SC(BHSCP,0)),U,1) Q:BHSCN=""
S BHSTST="",BHSVNT=""
S BHSVN=0 F BHSQ=0:0 S BHSVN=$O(^SC(BHSCP,"S",BHSVDT,1,BHSVN)) Q:'BHSVN I +^(BHSVN,0)=BHSPAT S BHSTST=$P(^(0),U,2),BHSVNT=$P(^(0),U,4) S:BHSTST BHSTST=BHSTST_" min."
F BHSI=3,4,5 S BHSJ=$P(BHSN,U,BHSI) I BHSJ S:BHSTST]"" BHSTST=BHSTST_"," S BHSTST=BHSTST_$P("^^LAB^XRAY^EKG^",U,BHSI)
D L1
I BHSVNT]"" D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG L1 W ?18,BHSVNT,!
Q
L1 D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W BHSET,! S BHSDAT=BHSPVD
W ?2,BHSDAT,?14,BHSVT,?21,BHSCN W:BHSTST]"" " (",BHSTST,")"
W:$P(BHSN,U,2)["N" ?35,"*** DNKA ***" W !
Q
WAIT ;EP - active wait list entries for patient
S BHSPAT=DFN
I $T(WLDATA^BSDWLV)="" W !!,"The scheduling routine for Wait List is missing, cannot display data." Q
K BHWAIT
D WLDATA^BSDWLV(BHSPAT,,.BHWAIT)
Q:'$D(BHWAIT)
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
W BHWAIT(0),!
S BHSD="" F S BHSD=$O(BHWAIT(BHSD)) Q:BHSD=""!($D(GMTSQIT)) D
.S BHSX=0 F S BHSX=$O(BHWAIT(BHSD,BHSX)) Q:BHSX=""!($D(GMTSQIT)) D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W $P(BHWAIT(BHSD,BHSX),U,2),!
; <CLEANUP>
WAITX K BHWAIT,BHSD,BHSPAT,BHSX
Q
BHSENCS ;IHS/CIA/MGH - Encounters from PCC ;23-Jun-2010 12:09;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**4**;March 17,2006;Build 13
+2 ;===================================================================
+3 ;Taken from APCHS2D
+4 ; IHS/TUCSON/LAB - PART 2D OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 03/01/04 10:50 AM ]
+5 ;;2.0;IHS RPMS/PCC Health Summary;**11,12,4**;JUN 24, 1997
+6 ;
+7 ;
SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 **********
+1 ; <SETUP>
+2 NEW BHSPAT
+3 SET BHSPAT=DFN
+4 IF '$DATA(^DPT(BHSPAT,"S"))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 SET BHSI=$ORDER(^DPT(BHSPAT,"S",0))
IF BHSI
IF BHSI<DT
DO PAST
+8 IF $ORDER(^DPT(BHSPAT,"S",DT))
DO PEND
+9 ; <CLEANUP>
SCHENCX KILL BHSVDT,BHSVD1,BHSAM,BHSQIT,BHSQ,BHSIVD,BHSDAT,BHSPVD,BHSN,BHSVT,BHSCN,BHSCP,BHSTST,BHSI,BHSJ,BHSET,BHSHP,BHSVN,BHSVNT,Y,X
+1 QUIT
+2 ;
PAST ;
+1 KILL ^TMP($JOB,"BHS")
+2 SET BHSVD1=9999999-GMTSDLM
SET BHSDAT=0
SET BHSI=0
+3 SET BHSVDT=BHSVD1
FOR BHSQ=0:0
SET BHSVDT=$ORDER(^DPT(BHSPAT,"S",BHSVDT))
IF 'BHSVDT!(BHSVDT>DT)
QUIT
DO ADDONE
+4 IF '$ORDER(^TMP($JOB,"BHS",""))
QUIT
+5 SET BHSET="PAST:"
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSET,!
+6 SET BHSIVD=0
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^TMP($JOB,"BHS",BHSIVD))
IF 'BHSIVD
QUIT
SET BHSVDT=^(BHSIVD)
DO ONEVIS
IF $DATA(GMTSQIT)
QUIT
+7 KILL ^TMP($JOB,"BHS")
+8 QUIT
+9 ;
ADDONE SET BHSIVD=9999999.9999-BHSVDT
+1 SET BHSI=BHSI+1
SET ^TMP($JOB,"BHS",BHSIVD)=BHSVDT
SET ^TMP($JOB,"BHS","B",BHSVDT)=""
+2 IF GMTSNDM>0
IF BHSI>GMTSNDM
SET BHSI=BHSI-1
SET BHSJ=$ORDER(^TMP($JOB,"BHS","B",""))
KILL ^(BHSJ)
KILL ^TMP($JOB,"BHS",9999999.9999-BHSJ)
+3 QUIT
PEND ;
+1 SET BHSET="PENDING:"
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSET,!
+2 SET BHSDAT=0
SET BHSVDT=DT-.01
FOR BHSQ=0:0
SET BHSVDT=$ORDER(^DPT(BHSPAT,"S",BHSVDT))
IF 'BHSVDT
QUIT
DO ONEVIS
IF $DATA(GMTSQIT)
QUIT
+3 QUIT
+4 ;
ONEVIS SET BHSN=^DPT(BHSPAT,"S",BHSVDT,0)
+1 IF "CP"[$EXTRACT($PIECE(BHSN,U,2)_" ")
QUIT
+2 SET BHSAM="am"
+3 ;Q:$P(BHSN,U,7)=4 ;skip unscheduled
+4 IF BHSVDT\1'=BHSDAT
SET X=BHSVDT\1
DO REGDT4^GMTSU
SET (BHSPVD,BHSDAT)=X
SET GMTSNDM=GMTSNDM-1
+5 SET BHSVT=$EXTRACT($PIECE(BHSVDT,".",2)_"000",1,4)
IF BHSVT>1159
SET BHSAM="pm"
IF BHSVT>1300
SET BHSVT=BHSVT-1200
IF $LENGTH(BHSVT)=3
SET BHSVT=" "_BHSVT
IF $EXTRACT(BHSVT)="0"
SET BHSVT=" "_$EXTRACT(BHSVT,2,4)
SET BHSVT=$EXTRACT(BHSVT,1,2)_":"_$EXTRACT(BHSVT,3,4)
+6 SET BHSTST=""
FOR BHSI=3,4,5
SET BHSJ=$PIECE(BHSN,U,BHSI)
IF BHSJ
IF BHSTST]""
SET BHSTST=BHSTST_","
SET BHSTST=BHSTST_$PIECE("^^LAB^XRAY^EKG^",U,BHSI)
+7 SET BHSCP=+BHSN
SET BHSCN=$PIECE($GET(^SC(BHSCP,0)),U,1)
IF BHSCN=""
QUIT
+8 SET BHSTST=""
SET BHSVNT=""
+9 SET BHSVN=0
FOR BHSQ=0:0
SET BHSVN=$ORDER(^SC(BHSCP,"S",BHSVDT,1,BHSVN))
IF 'BHSVN
QUIT
IF +^(BHSVN,0)=BHSPAT
SET BHSTST=$PIECE(^(0),U,2)
SET BHSVNT=$PIECE(^(0),U,4)
IF BHSTST
SET BHSTST=BHSTST_" min."
+10 FOR BHSI=3,4,5
SET BHSJ=$PIECE(BHSN,U,BHSI)
IF BHSJ
IF BHSTST]""
SET BHSTST=BHSTST_","
SET BHSTST=BHSTST_$PIECE("^^LAB^XRAY^EKG^",U,BHSI)
+11 DO L1
+12 IF BHSVNT]""
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO L1
WRITE ?18,BHSVNT,!
+13 QUIT
L1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE BHSET,!
SET BHSDAT=BHSPVD
+1 WRITE ?2,BHSDAT,?14,BHSVT,?21,BHSCN
IF BHSTST]""
WRITE " (",BHSTST,")"
+2 IF $PIECE(BHSN,U,2)["N"
WRITE ?35,"*** DNKA ***"
WRITE !
+3 QUIT
WAIT ;EP - active wait list entries for patient
+1 SET BHSPAT=DFN
+2 IF $TEXT(WLDATA^BSDWLV)=""
WRITE !!,"The scheduling routine for Wait List is missing, cannot display data."
QUIT
+3 KILL BHWAIT
+4 DO WLDATA^BSDWLV(BHSPAT,,.BHWAIT)
+5 IF '$DATA(BHWAIT)
QUIT
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 ; <DISPLAY>
+8 WRITE BHWAIT(0),!
+9 SET BHSD=""
FOR
SET BHSD=$ORDER(BHWAIT(BHSD))
IF BHSD=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+10 SET BHSX=0
FOR
SET BHSX=$ORDER(BHWAIT(BHSD,BHSX))
IF BHSX=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+11 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+12 WRITE $PIECE(BHWAIT(BHSD,BHSX),U,2),!
End DoDot:2
End DoDot:1
+13 ; <CLEANUP>
WAITX KILL BHWAIT,BHSD,BHSPAT,BHSX
+1 QUIT
