- APCHS2J ; IHS/CMI/LAB - PART 2D OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;
- ;
- SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 W/ CHART REQ AND WALK INS**********
- ; <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)_" ")
- Q:$P(APCHSN,U,7)=4 ;skip unscheduled
- S APCHSAM="am"
- 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
- APCHS2J ; IHS/CMI/LAB - PART 2D OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;
- +3 ;
- SCHENC ; ********** SCHEDULED ENCOUNTERS * 2/44 W/ CHART REQ AND WALK INS**********
- +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 ;skip unscheduled
- IF $PIECE(APCHSN,U,7)=4
- QUIT
- +3 SET APCHSAM="am"
- +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
