APCHS2G ; IHS/CMI/LAB - PART 2B OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
; <SETUP>
Q:'$D(^AUPNVSIT("AA",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSPVD=0
S APCHSPFN=""
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,APCHSPHN
K APCHSNFL,APCHSNSH,APCHSCCL,APCHSNAB,APCHSVSC,APCHSITE,APCHSQIT,APCHSDCL,Y,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)
. Q:'$P(APCHSN,U,9)
. Q:$P(APCHSN,U,11)
. Q:'$$PHN(APCHSVDF) ;do not use if phn is not a provider on this visit
. D GETCLN,GETSITEV^APCHSUTL,DSPVIS
. Q:$D(APCHSQIT)
. Q
Q
;
GETCLN ;
;APCHSDCL=set to 34 if Display Clinic is Yes, 23 if No
I $D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,3)="Y"
E S APCHSCLI=" ",APCHSDCL=23 Q
S APCHSDCL=34
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,10)
S APCHSCCL=APCHSCLI
Q
PHN(V) ;if one provider is phn quit on 1 otherwise quit on ""
I 'V Q ""
I '$D(^AUPNVSIT(V)) Q ""
I '$D(^AUPNVPRV("AD",V)) Q ""
I $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32) Q 1
Q ""
;if include secondary remove lines above about primary
NEW %,%1,Y,P S Y=0,%1="" F S Y=$O(^AUPNVPRV("AD",V,Y)) Q:Y'=+Y S P=$P(^AUPNVPRV(Y,0),U) D
.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)) I % S %=$P($G(^DIC(7,%,9999999)),U)
.I %=13!(%=32) S %1=1
Q %1
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=$$VAL^XBDIQ1(9000010.07,APCHSPDN,.04) I $P(APCHSN,U,5)]"" S APCHSNRQ=APCHSNRQ_" (Stage: "_$P(APCHSN,U,5)_")" ;IHS/CMI/LAB
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 ***"
;S APCHSICL=$S(APCHSCLI'=" ":34,1:23)
W ?10,APCHSFAC W:APCHSCLI]"" ?23,APCHSCLI
S APCHSICL=$S(APCHSDCL=34:34,1:24)
S:0 APCHSICD=APCHSVSC_":"_APCHSICD D PRTICD^APCHSUTL
;display phn fields
Q:'$D(^AUPNVPHN("AD",APCHSVDF))
S APCHSPHN=$O(^AUPNVPHN("AD",APCHSVDF,0))
Q:'APCHSPHN
I $P(^AUPNVPHN(APCHSPHN,0),U,5)]"" X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG APCHSNDT=1 W ?APCHSICL,"Intervention: ",$$VAL^XBDIQ1(9000010.32,APCHSPHN,.05)
I $P(^AUPNVPHN(APCHSPHN,0),U,6)]"" X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG APCHSNDT=1 W !?APCHSICL,"Complexity: ",$$VAL^XBDIQ1(9000010.32,APCHSPHN,.06)
I $P(^AUPNVPHN(APCHSPHN,0),U,5)]""!($P(^AUPNVPHN(APCHSPHN,0),U,6)]"") W !
I $D(^AUPNVPHN(APCHSPHN,21)) S APCHSNRQ="Psycho/Soc/Env: "_^AUPNVPHN(APCHSPHN,21),APCHSTXT="",APCHSICL=$S(APCHSDCL=34:34,1:24)+1 D PRTTXT^APCHSUTL
I $D(^AUPNVPHN(APCHSPHN,22)) S APCHSNRQ="NSG Dx: "_^AUPNVPHN(APCHSPHN,22),APCHSTXT="",APCHSICL=$S(APCHSDCL=34:34,1:24)+1 D PRTTXT^APCHSUTL
I $D(^AUPNVPHN(APCHSPHN,23)) S APCHSNRQ="Short Term Goals: "_^AUPNVPHN(APCHSPHN,23),APCHSTXT="",APCHSICL=$S(APCHSDCL=34:34,1:24)+1 D PRTTXT^APCHSUTL
I $D(^AUPNVPHN(APCHSPHN,24)) S APCHSNRQ="Long Term Goals: "_^AUPNVPHN(APCHSPHN,24),APCHSTXT="",APCHSICL=$S(APCHSDCL=34:34,1:24)+1 D PRTTXT^APCHSUTL
Q
;
APCHS2G ; IHS/CMI/LAB - PART 2B OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
OUTPT ; ********** OUTPATIENT ENCOUNTERS * 9000010/9000010.07 **********
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVSIT("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 ; <DISPLAY>
+5 SET APCHSPVD=0
+6 SET APCHSPFN=""
+7 FOR APCHSIVD=0:0
SET APCHSIVD=$ORDER(^AUPNVSIT("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:1
+8 DO ONEDATE
+9 IF $DATA(APCHSQIT)
QUIT
+10 IF (APCHSDAT'=APCHSPVD)&APCHSDTU
SET APCHSNDM=APCHSNDM-APCHSDTU
SET APCHSPVD=APCHSDAT
+11 QUIT
End DoDot:1
IF APCHSNDM=0!($DATA(APCHSQIT))
QUIT
+12 ;
OUTPTX ; <CLEANUP>
+1 KILL APCHSIVD,APCHSDTU,APCHSDAT,APCHSVDF,APCHSFAC,APCHSPFN,APCHSSCL,APCHSMTX,APCHSMOD,APCHSPVD,APCHSOVT,APCHSNDT,APCHSCLI,APCHSPDN,APCHSICD,APCHSICL,APCHSNRQ,APCHSPHN
+2 KILL APCHSNFL,APCHSNSH,APCHSCCL,APCHSNAB,APCHSVSC,APCHSITE,APCHSQIT,APCHSDCL,Y,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 IF '$PIECE(APCHSN,U,9)
QUIT
+8 IF $PIECE(APCHSN,U,11)
QUIT
+9 ;do not use if phn is not a provider on this visit
IF '$$PHN(APCHSVDF)
QUIT
+10 DO GETCLN
DO GETSITEV^APCHSUTL
DO DSPVIS
+11 IF $DATA(APCHSQIT)
QUIT
+12 QUIT
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
+13 QUIT
+14 ;
GETCLN ;
+1 ;APCHSDCL=set to 34 if Display Clinic is Yes, 23 if No
+2 IF $DATA(^APCHSCTL(APCHSTYP,2))
IF $PIECE(^(2),U,3)="Y"
+3 IF '$TEST
SET APCHSCLI=" "
SET APCHSDCL=23
QUIT
+4 SET APCHSDCL=34
+5 SET APCHSCLI=$PIECE(APCHSN,U,8)
IF APCHSCLI=""
SET APCHSCCL="<none>"
QUIT
+6 SET APCHSCLI=$PIECE(APCHSN,U,8)
IF APCHSCLI=""
QUIT
+7 IF '$DATA(^DIC(40.7,APCHSCLI))
QUIT
+8 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
+9 SET APCHSCLI=$EXTRACT($PIECE(^DIC(40.7,APCHSCLI,0),U,1),1,10)
+10 SET APCHSCCL=APCHSCLI
+11 QUIT
PHN(V) ;if one provider is phn quit on 1 otherwise quit on ""
+1 IF 'V
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$DATA(^AUPNVPRV("AD",V))
QUIT ""
+4 IF $$PRIMPROV^APCLV(V,"D")=13!($$PRIMPROV^APCLV(V,"D")=32)
QUIT 1
+5 QUIT ""
+6 ;if include secondary remove lines above about primary
+7 NEW %,%1,Y,P
SET Y=0
SET %1=""
FOR
SET Y=$ORDER(^AUPNVPRV("AD",V,Y))
IF Y'=+Y
QUIT
SET P=$PIECE(^AUPNVPRV(Y,0),U)
Begin DoDot:1
+8 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
IF '$DATA(^VA(200,P))
QUIT
+9 IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
IF '$DATA(^DIC(6,P))
QUIT
+10 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))
IF %
SET %=$PIECE($GET(^DIC(7,%,9999999)),U)
+11 IF %=13!(%=32)
SET %1=1
End DoDot:1
+12 QUIT %1
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 ;IHS/CMI/LAB
SET APCHSNRQ=$$VAL^XBDIQ1(9000010.07,APCHSPDN,.04)
IF $PIECE(APCHSN,U,5)]""
SET APCHSNRQ=APCHSNRQ_" (Stage: "_$PIECE(APCHSN,U,5)_")"
+3 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 ;S APCHSICL=$S(APCHSCLI'=" ":34,1:23)
+11 WRITE ?10,APCHSFAC
IF APCHSCLI]""
WRITE ?23,APCHSCLI
+12 SET APCHSICL=$SELECT(APCHSDCL=34:34,1:24)
+13 IF 0
SET APCHSICD=APCHSVSC_":"_APCHSICD
DO PRTICD^APCHSUTL
+14 ;display phn fields
+15 IF '$DATA(^AUPNVPHN("AD",APCHSVDF))
QUIT
+16 SET APCHSPHN=$ORDER(^AUPNVPHN("AD",APCHSVDF,0))
+17 IF 'APCHSPHN
QUIT
+18 IF $PIECE(^AUPNVPHN(APCHSPHN,0),U,5)]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
SET APCHSNDT=1
WRITE ?APCHSICL,"Intervention: ",$$VAL^XBDIQ1(9000010.32,APCHSPHN,.05)
+19 IF $PIECE(^AUPNVPHN(APCHSPHN,0),U,6)]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
SET APCHSNDT=1
WRITE !?APCHSICL,"Complexity: ",$$VAL^XBDIQ1(9000010.32,APCHSPHN,.06)
+20 IF $PIECE(^AUPNVPHN(APCHSPHN,0),U,5)]""!($PIECE(^AUPNVPHN(APCHSPHN,0),U,6)]"")
WRITE !
+21 IF $DATA(^AUPNVPHN(APCHSPHN,21))
SET APCHSNRQ="Psycho/Soc/Env: "_^AUPNVPHN(APCHSPHN,21)
SET APCHSTXT=""
SET APCHSICL=$SELECT(APCHSDCL=34:34,1:24)+1
DO PRTTXT^APCHSUTL
+22 IF $DATA(^AUPNVPHN(APCHSPHN,22))
SET APCHSNRQ="NSG Dx: "_^AUPNVPHN(APCHSPHN,22)
SET APCHSTXT=""
SET APCHSICL=$SELECT(APCHSDCL=34:34,1:24)+1
DO PRTTXT^APCHSUTL
+23 IF $DATA(^AUPNVPHN(APCHSPHN,23))
SET APCHSNRQ="Short Term Goals: "_^AUPNVPHN(APCHSPHN,23)
SET APCHSTXT=""
SET APCHSICL=$SELECT(APCHSDCL=34:34,1:24)+1
DO PRTTXT^APCHSUTL
+24 IF $DATA(^AUPNVPHN(APCHSPHN,24))
SET APCHSNRQ="Long Term Goals: "_^AUPNVPHN(APCHSPHN,24)
SET APCHSTXT=""
SET APCHSICL=$SELECT(APCHSDCL=34:34,1:24)+1
DO PRTTXT^APCHSUTL
+25 QUIT
+26 ;
