Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHS2F

APCHS2F.m

Go to the documentation of this file. 
  1. APCHS2F ; IHS/CMI/LAB - PART 2B OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS PCC SUITE;**10,15**;MAY 14, 2009;Build 11
  1.  ;
  1. OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVSIT("AA",APCHSPAT))
  1.  S APCHSOVT="ARSCOTE" ; NOTE: THIS CONTROLS TYPES OF VISITS DISPLAYED
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  ; <DISPLAY>
  1.  S APCHSPVD=0
  1.  S APCHSPFN=""
  1.  S APCHSDCX="",APCHSDPR=""
  1.  I $D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,3)="Y" S APCHSDCX=1
  1.  I $D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,5)=1 S APCHSDPR=1
  1.  I 'APCHSDPR,'APCHSDCX S APCHSDCL=23
  1.  I APCHSDCX,'APCHSDPR S APCHSDCL=32
  1.  I APCHSDCX,APCHSDPR S APCHSDCL=35
  1.  I 'APCHSDCX,APCHSDPR S APCHSDCL=28
  1.  F APCHSIVD=0:0 S APCHSIVD=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D  Q:APCHSNDM=0!($D(APCHSQIT))
  1.  . D ONEDATE
  1.  . Q:$D(APCHSQIT)
  1.  . S:(APCHSDAT'=APCHSPVD)&APCHSDTU APCHSNDM=APCHSNDM-APCHSDTU,APCHSPVD=APCHSDAT
  1.  . Q
  1.  ;
  1. OUTPTX ; <CLEANUP>
  1.  K APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSPFN,APCHSSCL,APCHSMTX,APCHSMOD,APCHSPVD,APCHSOVT,APCHSNDT,APCHSCLI,APCHSPDN,APCHSICD,APCHSICL,APCHSNRQ,APCHSDCX
  1.  K APCHSNFL,APCHSNSH,APCHSCCL,APCHSNAB,APCHSVSC,APCHSITE,APCHSQIT,APCHSDCL,Y,APCHSDPR,APCHCSVD
  1.  Q
  1.  ;
  1. ONEDATE ;
  1.  S APCHSCCL=""
  1.  S (Y,APCHCSVD)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S APCHSDTU=0,APCHSNDT=(APCHSDAT'=APCHSPVD)
  1.  S APCHSVDF="" F APCHSQ=0:0 S APCHSVDF=$O(^AUPNVSIT("AA",APCHSPAT,APCHSIVD,APCHSVDF)) Q:APCHSVDF=""  D  Q:$D(APCHSQIT)
  1.  . S APCHSSCL=""
  1.  . S APCHSN=^AUPNVSIT(APCHSVDF,0)
  1.  .  I $P(APCHSN,U,7)="E",'$D(^AUPNVPOV("AD",APCHSVDF)) Q  ;don't display events with no pov
  1.  . Q:'$P(APCHSN,U,9)
  1.  . Q:$P(APCHSN,U,11)
  1.  . Q:APCHSOVT'[$P(APCHSN,U,7)  ;not correct service category
  1.  . S APCHSFND=0 D CHKSCRN Q:'APCHSFND
  1.  . D GETCLN,GETPROV,GETSITEV^APCHSUTL,DSPVIS
  1.  . Q:$D(APCHSQIT)
  1.  . Q
  1.  Q
  1. GETPROV ;
  1.  S APCHSPRV=$$PRIMPROV^APCLV(APCHSVDF,"T")
  1.  Q
  1. GETCLN ;
  1.  S APCHSCLI=$P(APCHSN,U,8) I APCHSCLI="" S APCHSCCL="<none>" Q
  1.  S APCHSCLI=$P(APCHSN,U,8) Q:APCHSCLI=""
  1.  Q:'$D(^DIC(40.7,APCHSCLI))
  1.  I $D(^DIC(40.7,APCHSCLI,9999999)),$P(^(9999999),U,1)]"" S APCHSCLI=$P(^DIC(40.7,APCHSCLI,9999999),U,1),APCHSCCL=APCHSCLI Q
  1.  S APCHSCLI=$E($P(^DIC(40.7,APCHSCLI,0),U,1),1,8)
  1.  S APCHSCCL=APCHSCLI
  1.  Q
  1. CHKSCRN ;check for screening
  1.  ;screen out any clinics
  1.  NEW % S %=$P(APCHSN,U,8) I %,$D(^APCHSCTL(APCHSTYP,11,"B",%)) Q
  1.  ;screen out primary provider disciplines
  1.  NEW % S %=$$PP(APCHSVDF)
  1.  Q:'%
  1.  Q:$D(^APCHSCTL(APCHSTYP,9,"B",%))
  1.  S APCHSFND=1
  1.  Q
  1. PP(V) ;get primary provider discipline ien
  1.  I 'V Q ""
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  NEW %,Y,P S P="",Y=0 F  S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y  I $P(^AUPNVPRV(Y,0),U,4)="P" S P=$P(^AUPNVPRV(Y,0),U)
  1.  I 'P Q P
  1.  I $P(^DD(9000010.06,.01,0),U,2)[200,'$D(^VA(200,P)) Q ""
  1.  I $P(^DD(9000010.06,.01,0),U,2)[6,'$D(^DIC(6,P)) Q ""
  1.  S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)[200:200,1:6),P,$S($P(^DD(9000010.06,.01,0),U,2)[200:53.5,1:2))
  1.  Q %
  1. DSPVIS ;
  1.  S APCHSDTU=1
  1.  I $O(^AUPNVPOV("AD",APCHSVDF,""))="" D NOPOV Q
  1.  S APCHSPDN="" F APCHSQ=0:0 S APCHSPDN=$O(^AUPNVPOV("AD",APCHSVDF,APCHSPDN)) Q:'APCHSPDN  S APCHSN=^AUPNVPOV(APCHSPDN,0) D HASPOV
  1.  Q
  1.  ;
  1. NOPOV ;
  1.  S (APCHSICD,APCHSNRQ)="<purpose of visit not yet entered>",APCHSMOD=""
  1.  G COMMON
  1.  ;
  1. HASPOV ;
  1.  S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
  1.  S APCHSNRQ=$P(APCHSN,U,4) D
  1.  .I $$WANTPN^APCHSUTL(APCHSTYP) S APCHSNRQ=$$GET1^DIQ(9000010.07,APCHSPDN_",",.04)
  1.  .I $P(APCHSN,U,29)]"" S APCHSNRQ=APCHSNRQ_" ["_$$VAL^XBDIQ1(9000010.07,APCHSPDN,.29)_"]" ;IHS/CMI/LAB V2.0 PATCH 15
  1.  .I $P(APCHSN,U,5)]"" S APCHSNRQ=APCHSNRQ_"  (Stage: "_$P(APCHSN,U,5)_")"
  1.  S APCHSMOD=$P(APCHSN,U,6)
  1. COMMON ;
  1.  X APCHSCKP Q:$D(APCHSQIT)  S:APCHSNPG APCHSNDT=1
  1.  I APCHSNDT W APCHSDAT S (APCHSPFN,APCHSSCL)="",APCHSNDT=0
  1.  I APCHSNSH=APCHSPFN S APCHSFAC=""
  1.  E  S (APCHSFAC,APCHSPFN)=APCHSNSH,APCHSSCL=""
  1.  I APCHSCCL=APCHSSCL S APCHSCLI=""
  1.  E  S (APCHSCLI,APCHSSCL)=APCHSCCL
  1.  I APCHSICD["<purpose of visit not"&(APCHSSCL="<none>") S APCHSCLI=""
  1.  I APCHSMOD]"" S APCHSMTX=$P(^DD(9000010.07,.06,0),U,3),APCHSMTX=$P($P(APCHSMTX,APCHSMOD_":",2),";",1),APCHSMTX=$P(APCHSMTX,",",1),APCHSICD=APCHSMTX_" "_APCHSICD
  1.  S:$D(^AUPNVCHS("AD",APCHSVDF)) APCHSNTE="*** CHS ***"
  1.  W ?10,APCHSFAC
  1.  I APCHSDCX,APCHSDPR W ?23,$E(APCHSCLI,1,6),?30,APCHSPRV
  1.  I APCHSDCX,'APCHSDPR W ?23,APCHSCLI
  1.  I 'APCHSDCX,APCHSDPR W ?23,APCHSPRV
  1.  S APCHSICL=APCHSDCL
  1.  S:0 APCHSICD=APCHSVSC_":"_APCHSICD D PRTICD^APCHSUTL
  1.  Q
  1.  ;