APCHS2A ; IHS/CMI/LAB - PART 2A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**4,20**;MAY 14, 2009;Build 25
;
MEASP ; ******************** MEASUREMENT PANELS * 9000010.01 *******
; <SETUP>
Q:'$D(^AUPNVMSR("AA",APCHSPAT))
X APCHSBRK
; <BUILD> APCHSCTL-HLTH SUM TYPE
F APCHSPOR=0:0 S APCHSPOR=$O(^APCHSCTL(APCHSTYP,3,APCHSPOR)) Q:'APCHSPOR S APCHSND2=APCHSNDM,APCHSDMX=0 D PBLD
;now display lab refusals
S APCHST="MEASUREMENT",APCHSFN=9999999.07 D DISPREF^APCHS3C
K APCHST,APCHSFN
MEASPX K APCHSPOR,APCHSPDF,APCHSCOR,APCHSCT,APCHSCT2,APCHSCT3,APCHSCLN,APCHSMT,APCHSML,APCHSTSQ,APCHSTVL,APCHSVAL,APCHSIVD,APCHST,APCHSC,APCHSND2,APCHSDMX,APCHSDFN,APCHSDAT,APCHSDM2,APCHSPS1,APCHSIDT,APCHSNTS,Y,X
Q
PBLD S APCHSPDF=$P(^APCHSCTL(APCHSTYP,3,APCHSPOR,0),U,2)
K APCHSTSQ,APCHSTVL,APCHSNTS
S APCHSNTS=0
F APCHSPS1=1,0 F APCHSCOR=0:0 S APCHSCOR=$O(^APCHSMPN(APCHSPDF,1,APCHSCOR)) Q:APCHSCOR="" D CBLD
D POUT
Q
CBLD S APCHSP=^APCHSMPN(APCHSPDF,1,APCHSCOR,0) S APCHSCT3=$G(^(1))
S APCHSCT=$P(APCHSP,U,2),APCHSCLN=$P(APCHSP,U,3)
S X=$P(APCHSP,U,5) S:X]"" APCHSNTS(X)=""
S:APCHSCT="" APCHSCT=" " S APCHSCT2=$S($D(^AUTTMSR(APCHSCT,0)):$P(^(0),U,1),1:APCHSCT)
S:$P(APCHSP,U,4)]"" APCHSCT2=$P(APCHSP,U,4)
S:APCHSCLN="" APCHSCLN=10
S APCHSTSQ(APCHSCOR,1)=APCHSCT2,APCHSTSQ(APCHSCOR,2)=APCHSCLN,APCHSTSQ(APCHSCOR,3)=APCHSCT3
I APCHSPS1 S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D CBLD2
I 'APCHSPS1 S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,0)) I APCHSIVD,'$D(APCHSTVL(APCHSIVD,APCHSCOR)) D CBLD3
Q
CBLD2 I '$D(APCHSTVL(APCHSIVD)) S APCHSND2=APCHSND2-1 I APCHSND2=-1 S APCHSND2=0 Q:APCHSDMX&(APCHSIVD'<APCHSDMX) K APCHSTVL(APCHSDMX) F APCHSDM2=0:0 S APCHSDM2=$O(APCHSTVL(APCHSDM2)) Q:'APCHSDM2 S APCHSDMX=APCHSDM2
S:APCHSIVD>APCHSDMX APCHSDMX=APCHSIVD
CBLD3 S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD,APCHSDFN)) Q:APCHSDFN'=+APCHSDFN D
.Q:$P($G(^AUPNVMSR(APCHSDFN,2)),U,1) ;entered in error
.S V=$P(^AUPNVMSR(APCHSDFN,0),U,3) Q:"HI"[$P($G(^AUPNVSIT(V,0)),U,7) ;exclude inpatient
.S APCHSVAL=$P(^AUPNVMSR(APCHSDFN,0),U,4),APCHSTVL(APCHSIVD,APCHSCOR)=APCHSVAL_"^"_$P(^AUPNVMSR(APCHSDFN,0),U,6)
.;S APCHSVAL=$$VAL^XBDIQ1(9000010.01,APCHSDFN,.04),APCHSTVL(APCHSIVD,APCHSCOR)=APCHSVAL_"^"_$P(^AUPNVMSR(APCHSDFN,0),U,6)
Q
; <DISPLAY>
POUT X APCHSCKP Q:$D(APCHSQIT) W !
X APCHSCKP Q:$D(APCHSQIT) D PHDR
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(APCHSTVL(APCHSIVD)) Q:APCHSIVD="" X APCHSCKP Q:$D(APCHSQIT) D:APCHSNPG PHDR D PLINE
I $O(APCHSNTS(0))]"" W ! S X="" F S X=$O(APCHSNTS(X)) Q:X="" W X,!
Q
PHDR S APCHST=10,APCHSC=""
F APCHSQ=0:0 S APCHSC=$O(APCHSTSQ(APCHSC)) Q:APCHSC="" S APCHSMT=APCHSTSQ(APCHSC,1),APCHSML=APCHSTSQ(APCHSC,2) W ?(APCHST+1+(APCHSML-$L(APCHSMT)\2)),APCHSMT S APCHST=APCHST+APCHSML+2
W !
Q
PLINE S APCHSIDT=APCHSIVD,Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
W APCHSDAT S APCHST=11
S APCHSC="" F APCHSQ=0:0 S APCHSC=$O(APCHSTSQ(APCHSC)) Q:APCHSC="" D PVAL
W !
Q
PVAL ;
K APCHSVNM
S APCHSML=APCHSTSQ(APCHSC,2)
S (APCHSVAL,APCHSVNM)="",APCHSVAL=$P($G(APCHSTVL(APCHSIVD,APCHSC)),U) I $P($G(APCHSTVL(APCHSIVD,APCHSC)),U,2)]"" S APCHSVNM=$P($G(APCHSTVL(APCHSIVD,APCHSC)),U,2)
I APCHSVAL]"" S X=APCHSVAL X APCHSTSQ(APCHSC,3) S APCHSVAL=$P(X,"^",1),X=$P(X,"^",2) S:X]"" APCHSNTS(X)=""
S:APCHSVAL]"" APCHSVAL=$S($P(APCHSML,".",2)="":$J(APCHSVAL,$P(APCHSML,".",1)),1:$J(APCHSVAL,$P(APCHSML,".",1),$P(APCHSML,".",2)))
W ?APCHST,APCHSVAL S APCHST=APCHST+APCHSML+2
K APCHSVNM
Q
APCHS2A ; IHS/CMI/LAB - PART 2A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**4,20**;MAY 14, 2009;Build 25
+2 ;
MEASP ; ******************** MEASUREMENT PANELS * 9000010.01 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVMSR("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSBRK
+4 ; <BUILD> APCHSCTL-HLTH SUM TYPE
+5 FOR APCHSPOR=0:0
SET APCHSPOR=$ORDER(^APCHSCTL(APCHSTYP,3,APCHSPOR))
IF 'APCHSPOR
QUIT
SET APCHSND2=APCHSNDM
SET APCHSDMX=0
DO PBLD
+6 ;now display lab refusals
+7 SET APCHST="MEASUREMENT"
SET APCHSFN=9999999.07
DO DISPREF^APCHS3C
+8 KILL APCHST,APCHSFN
MEASPX KILL APCHSPOR,APCHSPDF,APCHSCOR,APCHSCT,APCHSCT2,APCHSCT3,APCHSCLN,APCHSMT,APCHSML,APCHSTSQ,APCHSTVL,APCHSVAL,APCHSIVD,APCHST,APCHSC,APCHSND2,APCHSDMX,APCHSDFN,APCHSDAT,APCHSDM2,APCHSPS1,APCHSIDT,APCHSNTS,Y,X
+1 QUIT
PBLD SET APCHSPDF=$PIECE(^APCHSCTL(APCHSTYP,3,APCHSPOR,0),U,2)
+1 KILL APCHSTSQ,APCHSTVL,APCHSNTS
+2 SET APCHSNTS=0
+3 FOR APCHSPS1=1,0
FOR APCHSCOR=0:0
SET APCHSCOR=$ORDER(^APCHSMPN(APCHSPDF,1,APCHSCOR))
IF APCHSCOR=""
QUIT
DO CBLD
+4 DO POUT
+5 QUIT
CBLD SET APCHSP=^APCHSMPN(APCHSPDF,1,APCHSCOR,0)
SET APCHSCT3=$GET(^(1))
+1 SET APCHSCT=$PIECE(APCHSP,U,2)
SET APCHSCLN=$PIECE(APCHSP,U,3)
+2 SET X=$PIECE(APCHSP,U,5)
IF X]""
SET APCHSNTS(X)=""
+3 IF APCHSCT=""
SET APCHSCT=" "
SET APCHSCT2=$SELECT($DATA(^AUTTMSR(APCHSCT,0)):$PIECE(^(0),U,1),1:APCHSCT)
+4 IF $PIECE(APCHSP,U,4)]""
SET APCHSCT2=$PIECE(APCHSP,U,4)
+5 IF APCHSCLN=""
SET APCHSCLN=10
+6 SET APCHSTSQ(APCHSCOR,1)=APCHSCT2
SET APCHSTSQ(APCHSCOR,2)=APCHSCLN
SET APCHSTSQ(APCHSCOR,3)=APCHSCT3
+7 IF APCHSPS1
SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO CBLD2
+8 IF 'APCHSPS1
SET APCHSIVD=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSCT,0))
IF APCHSIVD
IF '$DATA(APCHSTVL(APCHSIVD,APCHSCOR))
DO CBLD3
+9 QUIT
CBLD2 IF '$DATA(APCHSTVL(APCHSIVD))
SET APCHSND2=APCHSND2-1
IF APCHSND2=-1
SET APCHSND2=0
IF APCHSDMX&(APCHSIVD'<APCHSDMX)
QUIT
KILL APCHSTVL(APCHSDMX)
FOR APCHSDM2=0:0
SET APCHSDM2=$ORDER(APCHSTVL(APCHSDM2))
IF 'APCHSDM2
QUIT
SET APCHSDMX=APCHSDM2
+1 IF APCHSIVD>APCHSDMX
SET APCHSDMX=APCHSIVD
CBLD3 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD,APCHSDFN))
IF APCHSDFN'=+APCHSDFN
QUIT
Begin DoDot:1
+1 ;entered in error
IF $PIECE($GET(^AUPNVMSR(APCHSDFN,2)),U,1)
QUIT
+2 ;exclude inpatient
SET V=$PIECE(^AUPNVMSR(APCHSDFN,0),U,3)
IF "HI"[$PIECE($GET(^AUPNVSIT(V,0)),U,7)
QUIT
+3 SET APCHSVAL=$PIECE(^AUPNVMSR(APCHSDFN,0),U,4)
SET APCHSTVL(APCHSIVD,APCHSCOR)=APCHSVAL_"^"_$PIECE(^AUPNVMSR(APCHSDFN,0),U,6)
+4 ;S APCHSVAL=$$VAL^XBDIQ1(9000010.01,APCHSDFN,.04),APCHSTVL(APCHSIVD,APCHSCOR)=APCHSVAL_"^"_$P(^AUPNVMSR(APCHSDFN,0),U,6)
End DoDot:1
+5 QUIT
+6 ; <DISPLAY>
POUT XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
DO PHDR
+2 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(APCHSTVL(APCHSIVD))
IF APCHSIVD=""
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
DO PHDR
DO PLINE
+3 IF $ORDER(APCHSNTS(0))]""
WRITE !
SET X=""
FOR
SET X=$ORDER(APCHSNTS(X))
IF X=""
QUIT
WRITE X,!
+4 QUIT
PHDR SET APCHST=10
SET APCHSC=""
+1 FOR APCHSQ=0:0
SET APCHSC=$ORDER(APCHSTSQ(APCHSC))
IF APCHSC=""
QUIT
SET APCHSMT=APCHSTSQ(APCHSC,1)
SET APCHSML=APCHSTSQ(APCHSC,2)
WRITE ?(APCHST+1+(APCHSML-$LENGTH(APCHSMT)\2)),APCHSMT
SET APCHST=APCHST+APCHSML+2
+2 WRITE !
+3 QUIT
PLINE SET APCHSIDT=APCHSIVD
SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+1 WRITE APCHSDAT
SET APCHST=11
+2 SET APCHSC=""
FOR APCHSQ=0:0
SET APCHSC=$ORDER(APCHSTSQ(APCHSC))
IF APCHSC=""
QUIT
DO PVAL
+3 WRITE !
+4 QUIT
PVAL ;
+1 KILL APCHSVNM
+2 SET APCHSML=APCHSTSQ(APCHSC,2)
+3 SET (APCHSVAL,APCHSVNM)=""
SET APCHSVAL=$PIECE($GET(APCHSTVL(APCHSIVD,APCHSC)),U)
IF $PIECE($GET(APCHSTVL(APCHSIVD,APCHSC)),U,2)]""
SET APCHSVNM=$PIECE($GET(APCHSTVL(APCHSIVD,APCHSC)),U,2)
+4 IF APCHSVAL]""
SET X=APCHSVAL
XECUTE APCHSTSQ(APCHSC,3)
SET APCHSVAL=$PIECE(X,"^",1)
SET X=$PIECE(X,"^",2)
IF X]""
SET APCHSNTS(X)=""
+5 IF APCHSVAL]""
SET APCHSVAL=$SELECT($PIECE(APCHSML,".",2)="":$JUSTIFY(APCHSVAL,$PIECE(APCHSML,".",1)),1:$JUSTIFY(APCHSVAL,$PIECE(APCHSML,".",1),$PIECE(APCHSML,".",2)))
+6 WRITE ?APCHST,APCHSVAL
SET APCHST=APCHST+APCHSML+2
+7 KILL APCHSVNM
+8 QUIT
