- BGP6DCHW ; IHS/CMI/LAB - calc measures 29 Apr 2006 7:38 PM ;
- ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- ;
- GEN ;EP
- Q:'BGPACTCL
- I '$D(^AUPNVSIT("AC",DFN)) Q ""
- K ^TMP($J,"A")
- S A="^TMP($J,""A"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BGPBBD)_"-"_$$FMTE^XLFDT(BGPED),E=$$START1^APCLDF(B,A)
- I '$D(^TMP($J,"A",1)) Q ""
- S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
- .Q:'$D(^AUPNVSIT(V,0))
- .Q:'$P(^AUPNVSIT(V,0),U,9)
- .Q:$P(^AUPNVSIT(V,0),U,11)
- .Q:'$D(^AUPNVMSR("AD",V))
- .S M=0,W="",H="" F S M=$O(^AUPNVMSR("AD",V,M)) Q:M'=+M D
- ..S T=$P($G(^AUPNVMSR(M,0)),U)
- ..Q:T=""
- ..S T=$P($G(^AUTTMSR(T,0)),U)
- ..I T="WT" S W=$P(^AUPNVMSR(M,0),U,4)
- ..I T="HT" S H=$P(^AUPNVMSR(M,0),U,4)
- .I W="",H="" Q ;no ht or wt so skip visit
- .I $$AGE^AUPNPAT(DFN,BGPED)<19,(H=""!(W="")) Q ;under 19 and not both
- .D SET
- Q
- ;
- SET ;
- S BGPCHWC=BGPCHWC+1
- S BGPHTV=H,BGPWTV=W
- S R=""
- S $P(R,U)=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05)
- S $P(R,U,2)=$P(^AUTTLOC(DUZ(2),0),U,10)
- S $P(R,U,3)=$P($G(^AUTTLOC($P(^AUTTSITE(1,0),U),1)),U,3)
- S $P(R,U,4)=$$DATE(DT)
- S $P(R,U,5)=$$DATE(BGPBBD)
- S $P(R,U,6)=$$DATE(BGPED)
- S $P(R,U,7)=$$UID(DFN)
- S $P(R,U,8)=$$DATE($P(^DPT(DFN,0),U,3))
- S $P(R,U,9)=$$TRIBE^AUPNPAT(DFN,"C")
- S $P(R,U,10)=$P(^DPT(DFN,0),U,2)
- S $P(R,U,11)=$$STATE(DFN)
- S $P(R,U,12)=$$UIDV(V)
- S $P(R,U,13)=$$DATE($P($P(^AUPNVSIT(V,0),U),"."))
- S $P(R,U,14)=$$RZERO($P($P(^AUPNVSIT(V,0),U),".",2),4)
- S I=BGPHTV*2.54,I=$J(I,6,2),I=$$STRIP^XLFSTR(I," ")
- S $P(R,U,15)=$S(BGPHTV]"":I,1:"")
- S I=BGPWTV*.45359,I=$J(I,6,2),I=$$STRIP^XLFSTR(I," ")
- S $P(R,U,16)=$S(BGPWTV]"":I,1:"")
- S ^BGPGPDCS(BGPRPT,88888,BGPCHWC,0)=R
- Q
- UID(BGPA) ;PEP-Given DFN return unique patient record id.
- ; BGPA can be DFN, but is not required if DFN or DA exists.
- ;
- ; pt record id = 6DIGIT_PADDFN
- ; where 6DIGIT is the ASUFAC at the time of implementation of
- ; this functionality. I.e., the existing ASUFAC was frozen and
- ; stuffed into the .25 field of the RPMS SITE file.
- ; PADDFN = DFN right justified in a field of 10.
- ;
- ; If not there, stuff the ASUFAC into RPMS SITE for durability.
- ;I '$P($G(^AUTTSITE(1,1)),U,3) S $P(^AUTTSITE(1,1),U,3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)
- ;
- ;
- Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(BGPA))_BGPA
- ;
- DATE(D) ;EP
- I $G(D)="" Q ""
- Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+($E(D,1,3)))
- ;
- UIDV(VISIT) ;EP - generate unique ID for visit
- I '$G(VISIT) Q VISIT
- NEW X
- S X=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)
- Q X_$$LZERO(VISIT,10)
- ;
- LZERO(V,L) ;EP - left zero fill
- NEW %,I
- S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
- Q V
- RZERO(V,L) ;ep right zero fill
- NEW %,I
- S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
- Q V
- STATE(P) ;
- S C=$$COMMRES^AUPNPAT(P,"C")
- I C="" Q ""
- S S=$E(C,1,2)
- S S=$O(^DIC(5,"C",S,0))
- I S="" Q S
- Q $P($G(^DIC(5,S,0)),U,2)
- ;
- BGP6DCHW ; IHS/CMI/LAB - calc measures 29 Apr 2006 7:38 PM ;
- +1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
- +2 ;
- GEN ;EP
- +1 IF 'BGPACTCL
- QUIT
- +2 IF '$DATA(^AUPNVSIT("AC",DFN))
- QUIT ""
- +3 KILL ^TMP($JOB,"A")
- +4 SET A="^TMP($J,""A"","
- SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BGPBBD)_"-"_$$FMTE^XLFDT(BGPED)
- SET E=$$START1^APCLDF(B,A)
- +5 IF '$DATA(^TMP($JOB,"A",1))
- QUIT ""
- +6 SET (X,G)=0
- FOR
- SET X=$ORDER(^TMP($JOB,"A",X))
- IF X'=+X
- QUIT
- SET V=$PIECE(^TMP($JOB,"A",X),U,5)
- Begin DoDot:1
- +7 IF '$DATA(^AUPNVSIT(V,0))
- QUIT
- +8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
- QUIT
- +9 IF $PIECE(^AUPNVSIT(V,0),U,11)
- QUIT
- +10 IF '$DATA(^AUPNVMSR("AD",V))
- QUIT
- +11 SET M=0
- SET W=""
- SET H=""
- FOR
- SET M=$ORDER(^AUPNVMSR("AD",V,M))
- IF M'=+M
- QUIT
- Begin DoDot:2
- +12 SET T=$PIECE($GET(^AUPNVMSR(M,0)),U)
- +13 IF T=""
- QUIT
- +14 SET T=$PIECE($GET(^AUTTMSR(T,0)),U)
- +15 IF T="WT"
- SET W=$PIECE(^AUPNVMSR(M,0),U,4)
- +16 IF T="HT"
- SET H=$PIECE(^AUPNVMSR(M,0),U,4)
- End DoDot:2
- +17 ;no ht or wt so skip visit
- IF W=""
- IF H=""
- QUIT
- +18 ;under 19 and not both
- IF $$AGE^AUPNPAT(DFN,BGPED)<19
- IF (H=""!(W=""))
- QUIT
- +19 DO SET
- End DoDot:1
- +20 QUIT
- +21 ;
- SET ;
- +1 SET BGPCHWC=BGPCHWC+1
- +2 SET BGPHTV=H
- SET BGPWTV=W
- +3 SET R=""
- +4 SET $PIECE(R,U)=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05)
- +5 SET $PIECE(R,U,2)=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
- +6 SET $PIECE(R,U,3)=$PIECE($GET(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),1)),U,3)
- +7 SET $PIECE(R,U,4)=$$DATE(DT)
- +8 SET $PIECE(R,U,5)=$$DATE(BGPBBD)
- +9 SET $PIECE(R,U,6)=$$DATE(BGPED)
- +10 SET $PIECE(R,U,7)=$$UID(DFN)
- +11 SET $PIECE(R,U,8)=$$DATE($PIECE(^DPT(DFN,0),U,3))
- +12 SET $PIECE(R,U,9)=$$TRIBE^AUPNPAT(DFN,"C")
- +13 SET $PIECE(R,U,10)=$PIECE(^DPT(DFN,0),U,2)
- +14 SET $PIECE(R,U,11)=$$STATE(DFN)
- +15 SET $PIECE(R,U,12)=$$UIDV(V)
- +16 SET $PIECE(R,U,13)=$$DATE($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
- +17 SET $PIECE(R,U,14)=$$RZERO($PIECE($PIECE(^AUPNVSIT(V,0),U),".",2),4)
- +18 SET I=BGPHTV*2.54
- SET I=$JUSTIFY(I,6,2)
- SET I=$$STRIP^XLFSTR(I," ")
- +19 SET $PIECE(R,U,15)=$SELECT(BGPHTV]"":I,1:"")
- +20 SET I=BGPWTV*.45359
- SET I=$JUSTIFY(I,6,2)
- SET I=$$STRIP^XLFSTR(I," ")
- +21 SET $PIECE(R,U,16)=$SELECT(BGPWTV]"":I,1:"")
- +22 SET ^BGPGPDCS(BGPRPT,88888,BGPCHWC,0)=R
- +23 QUIT
- UID(BGPA) ;PEP-Given DFN return unique patient record id.
- +1 ; BGPA can be DFN, but is not required if DFN or DA exists.
- +2 ;
- +3 ; pt record id = 6DIGIT_PADDFN
- +4 ; where 6DIGIT is the ASUFAC at the time of implementation of
- +5 ; this functionality. I.e., the existing ASUFAC was frozen and
- +6 ; stuffed into the .25 field of the RPMS SITE file.
- +7 ; PADDFN = DFN right justified in a field of 10.
- +8 ;
- +9 ; If not there, stuff the ASUFAC into RPMS SITE for durability.
- +10 ;I '$P($G(^AUTTSITE(1,1)),U,3) S $P(^AUTTSITE(1,1),U,3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)
- +11 ;
- +12 ;
- +13 QUIT $$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_$EXTRACT("0000000000",1,10-$LENGTH(BGPA))_BGPA
- +14 ;
- DATE(D) ;EP
- +1 IF $GET(D)=""
- QUIT ""
- +2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+($EXTRACT(D,1,3)))
- +3 ;
- UIDV(VISIT) ;EP - generate unique ID for visit
- +1 IF '$GET(VISIT)
- QUIT VISIT
- +2 NEW X
- +3 SET X=$$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)
- +4 QUIT X_$$LZERO(VISIT,10)
- +5 ;
- LZERO(V,L) ;EP - left zero fill
- +1 NEW %,I
- +2 SET %=$LENGTH(V)
- SET Z=L-%
- FOR I=1:1:Z
- SET V="0"_V
- +3 QUIT V
- RZERO(V,L) ;ep right zero fill
- +1 NEW %,I
- +2 SET %=$LENGTH(V)
- SET Z=L-%
- FOR I=1:1:Z
- SET V=V_"0"
- +3 QUIT V
- STATE(P) ;
- +1 SET C=$$COMMRES^AUPNPAT(P,"C")
- +2 IF C=""
- QUIT ""
- +3 SET S=$EXTRACT(C,1,2)
- +4 SET S=$ORDER(^DIC(5,"C",S,0))
- +5 IF S=""
- QUIT S
- +6 QUIT $PIECE($GET(^DIC(5,S,0)),U,2)
- +7 ;
