- 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
