AUPNPCT ; IHS/CMI/LAB - CALLED FROM TRIGGER ON V MEAS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009;Build 9
; FOR PERCENTILES, HT AND WT, AGE UP TO AND NOT INCLUDING AGE 18
EN ; ENTRY POINT FROM MUMPS XREF ON VALUE FIELD OF V MEASUREMENT FILE
I '$G(AUPNPAT) S AUPNPAT=$P(^AUPNVMSR(DA,0),U,2)
I '$G(AUPNVSIT) S AUPNVSIT=$P(^AUPNVMSR(DA,0),U,3)
S AUPNPD1=$P(^DPT(AUPNPAT,0),U,3)
S AUPNPD2=+^AUPNVSIT(AUPNVSIT,0)
I ((AUPNPD2-AUPNPD1)\10000)<18
E K AUPNPD1,AUPNPD2 Q ; not under age 18
S AUPNHTWT=+^AUPNVMSR(DA,0)
I AUPNHTWT,($D(^AUTTMSR("B","HT",AUPNHTWT))!$D(^AUTTMSR("B","WT",AUPNHTWT))) S AUPNHTWT=$S($D(^AUTTMSR("B","HT",AUPNHTWT)):"HT",1:"WT")
E I '$P(^AUPNVMSR(DA,0),U,5) K AUPNPD1,AUPNPD2,AUPNHTWT Q ; not HT or WT, no previous pctile for entry (would exist if type modified to not HT or WT)
E D DELPCT K AUPNPD1,AUPNPD2,AUPNHTWT Q
D AGEMO
D GETPCT
K AUPNHTWT
Q
;
AGEMO ; Get age in months
;S AUPNPYR=$E(AUPNPD2,2,3)-$E(AUPNPD1,2,3),AUPNPMO=$E(AUPNPD2,4,5)-$E(AUPNPD1,4,5)
S AUPNPYR=(AUPNPD2\10000)-(AUPNPD1\10000),AUPNPMO=$E(AUPNPD2,4,5)-$E(AUPNPD1,4,5) ;IHS/DSD/JLG 2/18/98 for Y2K compliance
I AUPNPMO<0 S AUPNPMO=AUPNPMO+12,AUPNPYR=AUPNPYR-1
S AUPNAGE=12*AUPNPYR+AUPNPMO
K AUPNPMO,AUPNPYR,AUPNPD1,AUPNPD2
Q
;
GETPCT ; Call to extrinsic function AUPNPC to get percentile for this ht or wt
S AUPNSAVX=X
S AUPNPCT=$$AUHTWT^AUPNPC(AUPNHTWT,$P(^DPT(AUPNPAT,0),U,2),AUPNAGE,$S($D(AUPNPT01):$P(^AUPNVMSR(DA,0),U,4),1:X))
S AUPNPCT=$S(AUPNPCT[">":99.9,AUPNPCT["<":.1,1:AUPNPCT)
S $P(^AUPNVMSR(DA,0),U,5)=$S(AUPNCIXF="S":AUPNPCT,1:"")
D XREF
S X=AUPNSAVX
K AUPNAGE,AUPNPCT,AUPNSAVX
Q
;
XREF ; Set "APCT" xref on .05 field, execute other xrefs
S X=AUPNPCT
S AUPNV=$D(^AUPNVMSR("AQ",$S(AUPNHTWT="HT":"HPC",1:"WPC")_$E("000",1,3-$L($P(X,".")))_X,DA)) S:AUPNCIXF="S" ^(DA)="" K:AUPNCIXF="K" ^(DA)
D ^XBGXREFS(9000010.01,.05,.AUPNXREF)
S AUPNNUM=0 F S AUPNNUM=$O(AUPNXREF(21,AUPNNUM)) Q:'AUPNNUM X AUPNXREF(21,AUPNNUM,AUPNCIXF)
K AUPNNUM,AUPNXREF,AUPNV
Q
;
DELPCT ; Called if type of meas. changes to not Ht or Wt and entry has pctile
NEW X
S X=$P(^AUPNVMSR(DA,0),U,5)
S $P(^AUPNVMSR(DA,0),U,5)=""
F AUPNTYP="HPC","WPC" K ^AUPNVMSR("AQ",AUPNTYP_$E("000",1,3-$L($P(X,".")))_X,DA)
D ^XBGXREFS(9000010.01,.05,.AUPNXREF)
S AUPNNUM=0 F S AUPNNUM=$O(AUPNXREF(21,AUPNNUM)) Q:'AUPNNUM X AUPNXREF(21,AUPNNUM,"K")
K AUPNPCT,AUPNTYP
Q
;
AUPNPCT ; IHS/CMI/LAB - CALLED FROM TRIGGER ON V MEAS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009;Build 9
+2 ; FOR PERCENTILES, HT AND WT, AGE UP TO AND NOT INCLUDING AGE 18
EN ; ENTRY POINT FROM MUMPS XREF ON VALUE FIELD OF V MEASUREMENT FILE
+1 IF '$GET(AUPNPAT)
SET AUPNPAT=$PIECE(^AUPNVMSR(DA,0),U,2)
+2 IF '$GET(AUPNVSIT)
SET AUPNVSIT=$PIECE(^AUPNVMSR(DA,0),U,3)
+3 SET AUPNPD1=$PIECE(^DPT(AUPNPAT,0),U,3)
+4 SET AUPNPD2=+^AUPNVSIT(AUPNVSIT,0)
+5 IF ((AUPNPD2-AUPNPD1)\10000)<18
+6 ; not under age 18
IF '$TEST
KILL AUPNPD1,AUPNPD2
QUIT
+7 SET AUPNHTWT=+^AUPNVMSR(DA,0)
+8 IF AUPNHTWT
IF ($DATA(^AUTTMSR("B","HT",AUPNHTWT))!$DATA(^AUTTMSR("B","WT",AUPNHTWT)))
SET AUPNHTWT=$SELECT($DATA(^AUTTMSR("B","HT",AUPNHTWT)):"HT",1:"WT")
+9 ; not HT or WT, no previous pctile for entry (would exist if type modified to not HT or WT)
IF '$TEST
IF '$PIECE(^AUPNVMSR(DA,0),U,5)
KILL AUPNPD1,AUPNPD2,AUPNHTWT
QUIT
+10 IF '$TEST
DO DELPCT
KILL AUPNPD1,AUPNPD2,AUPNHTWT
QUIT
+11 DO AGEMO
+12 DO GETPCT
+13 KILL AUPNHTWT
+14 QUIT
+15 ;
AGEMO ; Get age in months
+1 ;S AUPNPYR=$E(AUPNPD2,2,3)-$E(AUPNPD1,2,3),AUPNPMO=$E(AUPNPD2,4,5)-$E(AUPNPD1,4,5)
+2 ;IHS/DSD/JLG 2/18/98 for Y2K compliance
SET AUPNPYR=(AUPNPD2\10000)-(AUPNPD1\10000)
SET AUPNPMO=$EXTRACT(AUPNPD2,4,5)-$EXTRACT(AUPNPD1,4,5)
+3 IF AUPNPMO<0
SET AUPNPMO=AUPNPMO+12
SET AUPNPYR=AUPNPYR-1
+4 SET AUPNAGE=12*AUPNPYR+AUPNPMO
+5 KILL AUPNPMO,AUPNPYR,AUPNPD1,AUPNPD2
+6 QUIT
+7 ;
GETPCT ; Call to extrinsic function AUPNPC to get percentile for this ht or wt
+1 SET AUPNSAVX=X
+2 SET AUPNPCT=$$AUHTWT^AUPNPC(AUPNHTWT,$PIECE(^DPT(AUPNPAT,0),U,2),AUPNAGE,$SELECT($DATA(AUPNPT01):$PIECE(^AUPNVMSR(DA,0),U,4),1:X))
+3 SET AUPNPCT=$SELECT(AUPNPCT[">":99.9,AUPNPCT["<":.1,1:AUPNPCT)
+4 SET $PIECE(^AUPNVMSR(DA,0),U,5)=$SELECT(AUPNCIXF="S":AUPNPCT,1:"")
+5 DO XREF
+6 SET X=AUPNSAVX
+7 KILL AUPNAGE,AUPNPCT,AUPNSAVX
+8 QUIT
+9 ;
XREF ; Set "APCT" xref on .05 field, execute other xrefs
+1 SET X=AUPNPCT
+2 SET AUPNV=$DATA(^AUPNVMSR("AQ",$SELECT(AUPNHTWT="HT":"HPC",1:"WPC")_$EXTRACT("000",1,3-$LENGTH($PIECE(X,".")))_X,DA))
IF AUPNCIXF="S"
SET ^(DA)=""
IF AUPNCIXF="K"
KILL ^(DA)
+3 DO ^XBGXREFS(9000010.01,.05,.AUPNXREF)
+4 SET AUPNNUM=0
FOR
SET AUPNNUM=$ORDER(AUPNXREF(21,AUPNNUM))
IF 'AUPNNUM
QUIT
XECUTE AUPNXREF(21,AUPNNUM,AUPNCIXF)
+5 KILL AUPNNUM,AUPNXREF,AUPNV
+6 QUIT
+7 ;
DELPCT ; Called if type of meas. changes to not Ht or Wt and entry has pctile
+1 NEW X
+2 SET X=$PIECE(^AUPNVMSR(DA,0),U,5)
+3 SET $PIECE(^AUPNVMSR(DA,0),U,5)=""
+4 FOR AUPNTYP="HPC","WPC"
KILL ^AUPNVMSR("AQ",AUPNTYP_$EXTRACT("000",1,3-$LENGTH($PIECE(X,".")))_X,DA)
+5 DO ^XBGXREFS(9000010.01,.05,.AUPNXREF)
+6 SET AUPNNUM=0
FOR
SET AUPNNUM=$ORDER(AUPNXREF(21,AUPNNUM))
IF 'AUPNNUM
QUIT
XECUTE AUPNXREF(21,AUPNNUM,"K")
+7 KILL AUPNPCT,AUPNTYP
+8 QUIT
+9 ;
