APCHS1B ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
;
DEMOG ; ******************** DEMOGRAPHICS ********************
; <SETUP>
S APCHSN=^DPT(APCHSPAT,0)
S APCHSNAM=$P(APCHSN,U,1)
S APCHSEX=$P(APCHSN,U,2),APCHSEX=$S(APCHSEX="M":"MALE",APCHSEX="F":"FEMALE",APCHSEX="U":"UNKNOWN",1:"<no sex>")
S Y=$P(APCHSN,U,3)
I 'Y S APCHSDOB="<NO DATE OF BIRTH>"
E X ^DD("DD") S APCHSDOB=Y
S APCHSSN=$$SSN^APCHS1(APCHSPAT) ;$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
S APCHSN=$G(^DPT(APCHSPAT,.24))
S APCHSMNM=$P(APCHSN,U,3)
S APCHSFNM=$P(APCHSN,U)
S APCHSN=^AUPNPAT(APCHSPAT,0)
S Y=$P(APCHSN,U,3)
I 'Y S APCHSLUD=""
E X ^DD("DD") S APCHSLUD=Y
S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
;S APCHSPP=$P(APCHSN,U,14) S:APCHSPP="" APCHSPP="<none identified>" I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1) ;*** file 200 conversion ***
S APCHSPP=$P(APCHSN,U,14)
S:APCHSPP=-1 APCHSPP="" ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
S:APCHSPP="" APCHSPP="<none identified>"
I +APCHSPP,$P(^DD(9000001,.14,0),U,2)[200 S APCHSPP=$P(^VA(200,APCHSPP,0),U) ;*** file 200 conversion ***
I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1)
V ;
S APCHSVST="" I $D(^DPT(APCHSPAT,"VET"))#2,$P(^("VET"),U)="Y" D VSTAT
S APCHSN=$G(^AUPNPAT(APCHSPAT,11))
S APCHSTR=$P(APCHSN,U,8)
I 'APCHSTR S APCHSTR="<no tribe>"
E S APCHSTR=^AUTTTRI(APCHSTR,0) S APCHSTR=$P(APCHSTR,U,1)_$S($P(APCHSTR,U,4)="Y":" <old code>",1:"")
S APCHSEL=$P(APCHSN,U,12)
S X=$P(^DD(9000001,1112,0),U,3) F APCHSI=1:1 S APCHSP=$P(X,";",APCHSI) Q:APCHSP="" I $P(APCHSP,":",1)=APCHSEL S APCHSEL=$P(APCHSP,":",2) Q
S APCHSCMR=$P(APCHSN,U,18) S:APCHSCMR="" APCHSCMR="<NO COMMUNITY OF RESIDENCE>"
S APCHSI=$O(^AUPNPAT(APCHSPAT,13,0)) S APCHSRE1=$S(APCHSI:^(APCHSI,0),1:"") S APCHSI=$O(^AUPNPAT(APCHSPAT,13,APCHSI)) S APCHSRE2=$S(APCHSI:^(APCHSI,0),1:"") S:$O(^AUPNPAT(APCHSPAT,13,APCHSI)) APCHSRE2=APCHSRE2_" [more]"
S APCHSADR=""
I $D(^DPT(APCHSPAT,.11)) S APCHSN=^(.11) F E=1:1:6 S APCHSP=$P(APCHSN,U,E) I APCHSP]"" S:E=5 APCHSP=$P(^DIC(5,APCHSP,0),U,2) S APCHSADR=APCHSADR_","_APCHSP
S APCHSADR=$E(APCHSADR,2,255)
S:APCHSADR]"" APCHSCMR=APCHSCMR_" ("_APCHSADR_") "
S APCHSN=$G(^DPT(APCHSPAT,.13))
S APCHSHPH=$P(APCHSN,U,1),APCHSOPH=$P(APCHSN,U,2)
I APCHSHPH="",APCHSOPH="" S APCHSHPH="<no phone numbers recorded>"
S:+APCHSHPH APCHSHPH="(H) "_APCHSHPH
S:APCHSOPH]"" APCHSOPH="(W) "_APCHSOPH S:APCHSHPH]"" APCHSOPH=" "_APCHSOPH
G DEMDSP
VSTAT S APCHSVST="VETERAN"
I $D(^DPT(APCHSPAT,.3))#2,$P(^(.3),U)="Y" S APCHSVST="SERVICE-CONNECTED "_APCHSVST
S APCHSN=$G(^DPT(APCHSPAT,.32))
I $P(APCHSN,U,5) S APCHSVST=APCHSVST_" "_$P(^DIC(23,$P(APCHSN,U,5),0),U,2)
S Y=$P(APCHSN,U,6) I Y D VSDT S APCHSVST=APCHSVST_" ("_Y_"-" S Y=$P(APCHSN,U,7) S:'Y APCHSVST=APCHSVST_"?)" I Y D VSDT S APCHSVST=APCHSVST_Y_")"
I $D(^DPT(APCHSPAT,.31))#2 S APCHSN=^(.31) S Y=$P(APCHSN,U,3) I Y S APCHSVST=APCHSVST_" CLAIM# "_Y
Q
VSDT S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))
Q
DEMDSP ; <DISPLAY>
X APCHSBRK
I $$DOD^AUPNPAT(APCHSPAT)]""!($$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"") D
.W "*** DOD: ",$$VAL^XBDIQ1(2,APCHSPAT,.351),!
.W "*** CAUSE OF DEATH: " I $$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"" D I 1
..W $$VAL^XBDIQ1(9000001,APCHSPAT,1114)
..K APCHSDSC
..S APCHSDSC=$$ICDD^AUPNVUTL($$VAL^XBDIQ1(9000001,APCHSPAT,1114),"APCHSDSC",$$DOD^AUPNPAT(APCHSPAT)) I $P(APCHSDSC,U)=-1 S APCHSDSC(1)=$P($$ICDDX^ICDEX($P(^AUPNPAT(APCHSPAT,11),U,14),$$DOD^AUPNPAT(APCHSPAT)),U,4)
..K ^UTILITY($J,"W")
..S APCHSX=0
..S DIWL=0,DIWR=45 F S APCHSX=$O(APCHSDSC(APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT)) D
...S X=APCHSDSC(APCHSX)
...Q:X="CODE TEXT MAY BE INACCURATE"
...Q:X=" "
...D ^DIWP
..S APCHSZ=0 F S APCHSZ=$O(^UTILITY($J,"W",DIWL,APCHSZ)) Q:APCHSZ'=+APCHSZ D
...X APCHSCKP Q:$D(APCHSQIT)
...W ?28,^UTILITY($J,"W",DIWL,APCHSZ,0),!
.E W !!
.;W !
K ^UTILITY($J,"W"),APCHSDSC,DIWL,APCHSX,APCHSZ,DIWL,DIWR
Q:$D(APCHSQIT)
W APCHSNAM
W:APCHSDOB]"" ?34,"DOB: ",APCHSDOB,?51,$$AGE(APCHSPAT,DT,"R")
W:APCHSEX]"" ?59,APCHSEX
W:APCHSBT]"" ?67,APCHSBT
W !
I APCHSTR]""!(APCHSMNM]"") W:APCHSTR]"" $E(APCHSTR,1,33) W:APCHSSN]"" ?34,"SSN: ",APCHSSN W !
W:APCHSMNM]"" ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM W !
W APCHSHPH,APCHSOPH W:APCHSFNM]"" ?34,"FATHER'S NAME: ",APCHSFNM W !
S APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
I APCHPLNG]"" W ?34,"PREFERRED LANGUAGE: ",APCHPLNG,!
I APCHSCMR]"" W APCHSCMR,!!
I APCHSLUD]""!(APCHSEL]"") W:APCHSLUD]"" "LAST UPDATED: ",APCHSLUD," " W:APCHSEL]"" ?34,"ELIGIBILITY: ",APCHSEL W !
W:APCHSVST]"" APCHSVST,!
I $P($G(^AUPNPAT(APCHSPAT,40)),U,2)]"" W !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
W !
;I $D(^AUPNPAT(APCHSPAT,41)) W "HEALTH RECORD NUMBERS:" F APCHSFP=0:0 S APCHSFP=$O(^AUPNPAT(APCHSPAT,41,APCHSFP)) Q:'APCHSFP S APCHSHRN=$P(^(APCHSFP,0),U,2),APCHSFAC=$P(^DIC(4,APCHSFP,0),U,1) W ?24,$E(1000000+APCHSHRN,2,7)," ",APCHSFAC,!
;W "DESIGNATED PROVIDER: ",APCHSPP,!
;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
;D DSPCMSRG
; <CLEANUP>
DEMOGX K APCHSNAM,APCHSTR,APCHSEX,APCHSDOB,APCHSSN,APCHSMNM,APCHSCMR,APCHSEL,APCHSFP,APCHSFAC,APCHSHRN,APCHSBT,APCHSPP,APCHSADR,APCHSN,APCHSP,APCHSI,APCHSJ,APCHSHPH,APCHSOPH,APCHSVST,APCHSLUD,APCHSRE1,APCHSRE2,E,X,Y
Q
DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
D DSPCMSRG^APCHS
Q
AGE(DFN,D,F) ;EP - Given DFN, return Age.
I '$G(DFN) Q -1
I '$D(^DPT(DFN,0)) Q -1
I $$DOB^AUPNPAT(DFN,"")<0 Q -1
S:$G(D)="" D=DT
S:$G(F)="" F="Y"
NEW %
S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
S %1=%\365.25
I F="Y" Q %1
;beginning Y2K fix
;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
Q $S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS") ;Y2000
;end Y2K
;
APCHS1B ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
+2 ;
DEMOG ; ******************** DEMOGRAPHICS ********************
+1 ; <SETUP>
+2 SET APCHSN=^DPT(APCHSPAT,0)
+3 SET APCHSNAM=$PIECE(APCHSN,U,1)
+4 SET APCHSEX=$PIECE(APCHSN,U,2)
SET APCHSEX=$SELECT(APCHSEX="M":"MALE",APCHSEX="F":"FEMALE",APCHSEX="U":"UNKNOWN",1:"<no sex>")
+5 SET Y=$PIECE(APCHSN,U,3)
+6 IF 'Y
SET APCHSDOB="<NO DATE OF BIRTH>"
+7 IF '$TEST
XECUTE ^DD("DD")
SET APCHSDOB=Y
+8 ;$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
SET APCHSSN=$$SSN^APCHS1(APCHSPAT)
+9 SET APCHSN=$GET(^DPT(APCHSPAT,.24))
+10 SET APCHSMNM=$PIECE(APCHSN,U,3)
+11 SET APCHSFNM=$PIECE(APCHSN,U)
+12 SET APCHSN=^AUPNPAT(APCHSPAT,0)
+13 SET Y=$PIECE(APCHSN,U,3)
+14 IF 'Y
SET APCHSLUD=""
+15 IF '$TEST
XECUTE ^DD("DD")
SET APCHSLUD=Y
+16 SET APCHSBT=$PIECE(APCHSN,U,13)
IF APCHSBT=""
SET APCHSBT="no blood type"
+17 ;S APCHSPP=$P(APCHSN,U,14) S:APCHSPP="" APCHSPP="<none identified>" I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1) ;*** file 200 conversion ***
+18 SET APCHSPP=$PIECE(APCHSN,U,14)
+19 ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
IF APCHSPP=-1
SET APCHSPP=""
+20 IF APCHSPP=""
SET APCHSPP="<none identified>"
+21 ;*** file 200 conversion ***
IF +APCHSPP
IF $PIECE(^DD(9000001,.14,0),U,2)[200
SET APCHSPP=$PIECE(^VA(200,APCHSPP,0),U)
+22 IF +APCHSPP
SET APCHSPP=$PIECE(^DIC(6,+APCHSPP,0),U,1)
IF +APCHSPP
SET APCHSPP=$PIECE(^DIC(16,+APCHSPP,0),U,1)
V ;
+1 SET APCHSVST=""
IF $DATA(^DPT(APCHSPAT,"VET"))#2
IF $PIECE(^("VET"),U)="Y"
DO VSTAT
+2 SET APCHSN=$GET(^AUPNPAT(APCHSPAT,11))
+3 SET APCHSTR=$PIECE(APCHSN,U,8)
+4 IF 'APCHSTR
SET APCHSTR="<no tribe>"
+5 IF '$TEST
SET APCHSTR=^AUTTTRI(APCHSTR,0)
SET APCHSTR=$PIECE(APCHSTR,U,1)_$SELECT($PIECE(APCHSTR,U,4)="Y":" <old code>",1:"")
+6 SET APCHSEL=$PIECE(APCHSN,U,12)
+7 SET X=$PIECE(^DD(9000001,1112,0),U,3)
FOR APCHSI=1:1
SET APCHSP=$PIECE(X,";",APCHSI)
IF APCHSP=""
QUIT
IF $PIECE(APCHSP,":",1)=APCHSEL
SET APCHSEL=$PIECE(APCHSP,":",2)
QUIT
+8 SET APCHSCMR=$PIECE(APCHSN,U,18)
IF APCHSCMR=""
SET APCHSCMR="<NO COMMUNITY OF RESIDENCE>"
+9 SET APCHSI=$ORDER(^AUPNPAT(APCHSPAT,13,0))
SET APCHSRE1=$SELECT(APCHSI:^(APCHSI,0),1:"")
SET APCHSI=$ORDER(^AUPNPAT(APCHSPAT,13,APCHSI))
SET APCHSRE2=$SELECT(APCHSI:^(APCHSI,0),1:"")
IF $ORDER(^AUPNPAT(APCHSPAT,13,APCHSI))
SET APCHSRE2=APCHSRE2_" [more]"
+10 SET APCHSADR=""
+11 IF $DATA(^DPT(APCHSPAT,.11))
SET APCHSN=^(.11)
FOR E=1:1:6
SET APCHSP=$PIECE(APCHSN,U,E)
IF APCHSP]""
IF E=5
SET APCHSP=$PIECE(^DIC(5,APCHSP,0),U,2)
SET APCHSADR=APCHSADR_","_APCHSP
+12 SET APCHSADR=$EXTRACT(APCHSADR,2,255)
+13 IF APCHSADR]""
SET APCHSCMR=APCHSCMR_" ("_APCHSADR_") "
+14 SET APCHSN=$GET(^DPT(APCHSPAT,.13))
+15 SET APCHSHPH=$PIECE(APCHSN,U,1)
SET APCHSOPH=$PIECE(APCHSN,U,2)
+16 IF APCHSHPH=""
IF APCHSOPH=""
SET APCHSHPH="<no phone numbers recorded>"
+17 IF +APCHSHPH
SET APCHSHPH="(H) "_APCHSHPH
+18 IF APCHSOPH]""
SET APCHSOPH="(W) "_APCHSOPH
IF APCHSHPH]""
SET APCHSOPH=" "_APCHSOPH
+19 GOTO DEMDSP
VSTAT SET APCHSVST="VETERAN"
+1 IF $DATA(^DPT(APCHSPAT,.3))#2
IF $PIECE(^(.3),U)="Y"
SET APCHSVST="SERVICE-CONNECTED "_APCHSVST
+2 SET APCHSN=$GET(^DPT(APCHSPAT,.32))
+3 IF $PIECE(APCHSN,U,5)
SET APCHSVST=APCHSVST_" "_$PIECE(^DIC(23,$PIECE(APCHSN,U,5),0),U,2)
+4 SET Y=$PIECE(APCHSN,U,6)
IF Y
DO VSDT
SET APCHSVST=APCHSVST_" ("_Y_"-"
SET Y=$PIECE(APCHSN,U,7)
IF 'Y
SET APCHSVST=APCHSVST_"?)"
IF Y
DO VSDT
SET APCHSVST=APCHSVST_Y_")"
+5 IF $DATA(^DPT(APCHSPAT,.31))#2
SET APCHSN=^(.31)
SET Y=$PIECE(APCHSN,U,3)
IF Y
SET APCHSVST=APCHSVST_" CLAIM# "_Y
+6 QUIT
VSDT SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))
+1 QUIT
DEMDSP ; <DISPLAY>
+1 XECUTE APCHSBRK
+2 IF $$DOD^AUPNPAT(APCHSPAT)]""!($$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"")
Begin DoDot:1
+3 WRITE "*** DOD: ",$$VAL^XBDIQ1(2,APCHSPAT,.351),!
+4 WRITE "*** CAUSE OF DEATH: "
IF $$VAL^XBDIQ1(9000001,APCHSPAT,1114)]""
Begin DoDot:2
+5 WRITE $$VAL^XBDIQ1(9000001,APCHSPAT,1114)
+6 KILL APCHSDSC
+7 SET APCHSDSC=$$ICDD^AUPNVUTL($$VAL^XBDIQ1(9000001,APCHSPAT,1114),"APCHSDSC",$$DOD^AUPNPAT(APCHSPAT))
IF $PIECE(APCHSDSC,U)=-1
SET APCHSDSC(1)=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNPAT(APCHSPAT,11),U,14),$$DOD^AUPNPAT(APCHSPAT)),U,4)
+8 KILL ^UTILITY($JOB,"W")
+9 SET APCHSX=0
+10 SET DIWL=0
SET DIWR=45
FOR
SET APCHSX=$ORDER(APCHSDSC(APCHSX))
IF APCHSX'=+APCHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+11 SET X=APCHSDSC(APCHSX)
+12 IF X="CODE TEXT MAY BE INACCURATE"
QUIT
+13 IF X=" "
QUIT
+14 DO ^DIWP
End DoDot:3
+15 SET APCHSZ=0
FOR
SET APCHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCHSZ))
IF APCHSZ'=+APCHSZ
QUIT
Begin DoDot:3
+16 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+17 WRITE ?28,^UTILITY($JOB,"W",DIWL,APCHSZ,0),!
End DoDot:3
End DoDot:2
IF 1
+18 IF '$TEST
WRITE !!
+19 ;W !
End DoDot:1
+20 KILL ^UTILITY($JOB,"W"),APCHSDSC,DIWL,APCHSX,APCHSZ,DIWL,DIWR
+21 IF $DATA(APCHSQIT)
QUIT
+22 WRITE APCHSNAM
+23 IF APCHSDOB]""
WRITE ?34,"DOB: ",APCHSDOB,?51,$$AGE(APCHSPAT,DT,"R")
+24 IF APCHSEX]""
WRITE ?59,APCHSEX
+25 IF APCHSBT]""
WRITE ?67,APCHSBT
+26 WRITE !
+27 IF APCHSTR]""!(APCHSMNM]"")
IF APCHSTR]""
WRITE $EXTRACT(APCHSTR,1,33)
IF APCHSSN]""
WRITE ?34,"SSN: ",APCHSSN
WRITE !
+28 IF APCHSMNM]""
WRITE ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM
WRITE !
+29 WRITE APCHSHPH,APCHSOPH
IF APCHSFNM]""
WRITE ?34,"FATHER'S NAME: ",APCHSFNM
WRITE !
+30 SET APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
+31 IF APCHPLNG]""
WRITE ?34,"PREFERRED LANGUAGE: ",APCHPLNG,!
+32 IF APCHSCMR]""
WRITE APCHSCMR,!!
+33 IF APCHSLUD]""!(APCHSEL]"")
IF APCHSLUD]""
WRITE "LAST UPDATED: ",APCHSLUD," "
IF APCHSEL]""
WRITE ?34,"ELIGIBILITY: ",APCHSEL
WRITE !
+34 IF APCHSVST]""
WRITE APCHSVST,!
+35 IF $PIECE($GET(^AUPNPAT(APCHSPAT,40)),U,2)]""
WRITE !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
+36 WRITE !
+37 ;I $D(^AUPNPAT(APCHSPAT,41)) W "HEALTH RECORD NUMBERS:" F APCHSFP=0:0 S APCHSFP=$O(^AUPNPAT(APCHSPAT,41,APCHSFP)) Q:'APCHSFP S APCHSHRN=$P(^(APCHSFP,0),U,2),APCHSFAC=$P(^DIC(4,APCHSFP,0),U,1) W ?24,$E(1000000+APCHSHRN,2,7)," ",APCHSFAC,!
+38 ;W "DESIGNATED PROVIDER: ",APCHSPP,!
+39 ;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
+40 ;D DSPCMSRG
+41 ; <CLEANUP>
DEMOGX KILL APCHSNAM,APCHSTR,APCHSEX,APCHSDOB,APCHSSN,APCHSMNM,APCHSCMR,APCHSEL,APCHSFP,APCHSFAC,APCHSHRN,APCHSBT,APCHSPP,APCHSADR,APCHSN,APCHSP,APCHSI,APCHSJ,APCHSHPH,APCHSOPH,APCHSVST,APCHSLUD,APCHSRE1,APCHSRE2,E,X,Y
+1 QUIT
DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
+1 DO DSPCMSRG^APCHS
+2 QUIT
AGE(DFN,D,F) ;EP - Given DFN, return Age.
+1 IF '$GET(DFN)
QUIT -1
+2 IF '$DATA(^DPT(DFN,0))
QUIT -1
+3 IF $$DOB^AUPNPAT(DFN,"")<0
QUIT -1
+4 IF $GET(D)=""
SET D=DT
+5 IF $GET(F)=""
SET F="Y"
+6 NEW %
+7 SET %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
+8 SET %1=%\365.25
+9 IF F="Y"
QUIT %1
+10 ;beginning Y2K fix
+11 ;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
+12 ;Y2000
QUIT $SELECT(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS")
+13 ;end Y2K
+14 ;
