- 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
