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