- 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 ;
