BGP2DCHW ; IHS/CMI/LAB - calc measures 29 Apr 2010 7:38 PM ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
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(BGPBD)_"-"_$$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:$$AGE^AUPNPAT(DFN,$P($P(^AUPNVSIT(V,0),U),"."))>65
.Q:'$D(^AUPNVMSR("AD",V))
.S M=0,W="",H="" F S M=$O(^AUPNVMSR("AD",V,M)) Q:M'=+M D
..Q:$P($G(^AUPNVMSR(M,2)),U,1)
..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,$P($P(^AUPNVSIT(V,0),U),"."))<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(BGPBD)
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 ^BGPGPDCW(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) ;EP
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)
;
BGP2DCHW ; IHS/CMI/LAB - calc measures 29 Apr 2010 7:38 PM ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+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(BGPBD)_"-"_$$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 $$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))>65
QUIT
+11 IF '$DATA(^AUPNVMSR("AD",V))
QUIT
+12 SET M=0
SET W=""
SET H=""
FOR
SET M=$ORDER(^AUPNVMSR("AD",V,M))
IF M'=+M
QUIT
Begin DoDot:2
+13 IF $PIECE($GET(^AUPNVMSR(M,2)),U,1)
QUIT
+14 SET T=$PIECE($GET(^AUPNVMSR(M,0)),U)
+15 IF T=""
QUIT
+16 SET T=$PIECE($GET(^AUTTMSR(T,0)),U)
+17 IF T="WT"
SET W=$PIECE(^AUPNVMSR(M,0),U,4)
+18 IF T="HT"
SET H=$PIECE(^AUPNVMSR(M,0),U,4)
End DoDot:2
+19 ;no ht or wt so skip visit
IF W=""
IF H=""
QUIT
+20 ;under 19 and not both
IF $$AGE^AUPNPAT(DFN,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))<19
IF (H=""!(W=""))
QUIT
+21 DO SET
End DoDot:1
+22 QUIT
+23 ;
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(BGPBD)
+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 ^BGPGPDCW(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) ;EP
+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 ;
