- BHSENCW ;IHS/CIA/MGH - Encounters from PCC ;17-Mar-2006 10:36;MGH
- ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
- ;===================================================================
- ;Taken from APCHS2J
- ; IHS/TUCSON/LAB - PART 2D OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 03/01/04 10:50 AM ]
- ;;2.0;IHS RPMS/PCC Health Summary;**11,12**;JUN 24, 1997
- ;
- ;
- SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 W/ CHART REQ AND WALK INS**********
- ; <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,BHSIVD,BHSDAT,BHSPVD,BHSN,BHSVT,BHSCN,BHSCP,BHSTST,BHSI,BHSJ,BHSET,BHSHP,BHSVN,BHSVNT,BHSQ,Y
- 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)_" ")
- 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>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
- BHSENCW ;IHS/CIA/MGH - Encounters from PCC ;17-Mar-2006 10:36;MGH
- +1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
- +2 ;===================================================================
- +3 ;Taken from APCHS2J
- +4 ; IHS/TUCSON/LAB - PART 2D OF BHS -- SUMMARY PRODUCTION COMPONENTS ; [ 03/01/04 10:50 AM ]
- +5 ;;2.0;IHS RPMS/PCC Health Summary;**11,12**;JUN 24, 1997
- +6 ;
- +7 ;
- SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 W/ CHART REQ AND WALK INS**********
- +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,BHSIVD,BHSDAT,BHSPVD,BHSN,BHSVT,BHSCN,BHSCP,BHSTST,BHSI,BHSJ,BHSET,BHSHP,BHSVN,BHSVNT,BHSQ,Y
- +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 ;skip unscheduled
- IF $PIECE(BHSN,U,7)=4
- QUIT
- +3 IF BHSVDT\1'=BHSDAT
- SET X=BHSVDT\1
- DO REGDT4^GMTSU
- SET (BHSPVD,BHSDAT)=X
- SET GMTSNDM=GMTSNDM-1
- +4 SET BHSVT=$EXTRACT($PIECE(BHSVDT,".",2)_"000",1,4)
- 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)
- +5 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)
- +6 SET BHSCP=+BHSN
- SET BHSCN=$PIECE($GET(^SC(BHSCP,0)),U,1)
- IF BHSCN=""
- QUIT
- +7 SET BHSTST=""
- SET BHSVNT=""
- +8 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."
- +9 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)
- +10 DO L1
- +11 IF BHSVNT]""
- DO CKP^GMTSUP
- IF $DATA(GMTSQIT)
- QUIT
- IF GMTSNPG
- DO L1
- WRITE ?18,BHSVNT,!
- +12 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
