Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHS1B

APCHS1B.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. DEMOG ; ******************** DEMOGRAPHICS ********************
  1. ; <SETUP>
  1. S APCHSN=^DPT(APCHSPAT,0)
  1. S APCHSNAM=$P(APCHSN,U,1)
  1. S APCHSEX=$P(APCHSN,U,2),APCHSEX=$S(APCHSEX="M":"MALE",APCHSEX="F":"FEMALE",APCHSEX="U":"UNKNOWN",1:"<no sex>")
  1. S Y=$P(APCHSN,U,3)
  1. I 'Y S APCHSDOB="<NO DATE OF BIRTH>"
  1. E X ^DD("DD") S APCHSDOB=Y
  1. S APCHSSN=$$SSN^APCHS1(APCHSPAT) ;$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
  1. S APCHSN=$G(^DPT(APCHSPAT,.24))
  1. S APCHSMNM=$P(APCHSN,U,3)
  1. S APCHSFNM=$P(APCHSN,U)
  1. S APCHSN=^AUPNPAT(APCHSPAT,0)
  1. S Y=$P(APCHSN,U,3)
  1. I 'Y S APCHSLUD=""
  1. E X ^DD("DD") S APCHSLUD=Y
  1. S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
  1. ;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 ***
  1. S APCHSPP=$P(APCHSN,U,14)
  1. S:APCHSPP=-1 APCHSPP="" ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
  1. S:APCHSPP="" APCHSPP="<none identified>"
  1. I +APCHSPP,$P(^DD(9000001,.14,0),U,2)[200 S APCHSPP=$P(^VA(200,APCHSPP,0),U) ;*** file 200 conversion ***
  1. I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1)
  1. V ;
  1. S APCHSVST="" I $D(^DPT(APCHSPAT,"VET"))#2,$P(^("VET"),U)="Y" D VSTAT
  1. S APCHSN=$G(^AUPNPAT(APCHSPAT,11))
  1. S APCHSTR=$P(APCHSN,U,8)
  1. I 'APCHSTR S APCHSTR="<no tribe>"
  1. E S APCHSTR=^AUTTTRI(APCHSTR,0) S APCHSTR=$P(APCHSTR,U,1)_$S($P(APCHSTR,U,4)="Y":" <old code>",1:"")
  1. S APCHSEL=$P(APCHSN,U,12)
  1. 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
  1. S APCHSCMR=$P(APCHSN,U,18) S:APCHSCMR="" APCHSCMR="<NO COMMUNITY OF RESIDENCE>"
  1. 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]"
  1. S APCHSADR=""
  1. 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
  1. S APCHSADR=$E(APCHSADR,2,255)
  1. S:APCHSADR]"" APCHSCMR=APCHSCMR_" ("_APCHSADR_") "
  1. S APCHSN=$G(^DPT(APCHSPAT,.13))
  1. S APCHSHPH=$P(APCHSN,U,1),APCHSOPH=$P(APCHSN,U,2)
  1. I APCHSHPH="",APCHSOPH="" S APCHSHPH="<no phone numbers recorded>"
  1. S:+APCHSHPH APCHSHPH="(H) "_APCHSHPH
  1. S:APCHSOPH]"" APCHSOPH="(W) "_APCHSOPH S:APCHSHPH]"" APCHSOPH=" "_APCHSOPH
  1. G DEMDSP
  1. VSTAT S APCHSVST="VETERAN"
  1. I $D(^DPT(APCHSPAT,.3))#2,$P(^(.3),U)="Y" S APCHSVST="SERVICE-CONNECTED "_APCHSVST
  1. S APCHSN=$G(^DPT(APCHSPAT,.32))
  1. I $P(APCHSN,U,5) S APCHSVST=APCHSVST_" "_$P(^DIC(23,$P(APCHSN,U,5),0),U,2)
  1. 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_")"
  1. I $D(^DPT(APCHSPAT,.31))#2 S APCHSN=^(.31) S Y=$P(APCHSN,U,3) I Y S APCHSVST=APCHSVST_" CLAIM# "_Y
  1. Q
  1. VSDT S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))
  1. Q
  1. DEMDSP ; <DISPLAY>
  1. X APCHSBRK
  1. I $$DOD^AUPNPAT(APCHSPAT)]""!($$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"") D
  1. .W "*** DOD: ",$$VAL^XBDIQ1(2,APCHSPAT,.351),!
  1. .W "*** CAUSE OF DEATH: " I $$VAL^XBDIQ1(9000001,APCHSPAT,1114)]"" D I 1
  1. ..W $$VAL^XBDIQ1(9000001,APCHSPAT,1114)
  1. ..K APCHSDSC
  1. ..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)
  1. ..K ^UTILITY($J,"W")
  1. ..S APCHSX=0
  1. ..S DIWL=0,DIWR=45 F S APCHSX=$O(APCHSDSC(APCHSX)) Q:APCHSX'=+APCHSX!($D(APCHSQIT)) D
  1. ...S X=APCHSDSC(APCHSX)
  1. ...Q:X="CODE TEXT MAY BE INACCURATE"
  1. ...Q:X=" "
  1. ...D ^DIWP
  1. ..S APCHSZ=0 F S APCHSZ=$O(^UTILITY($J,"W",DIWL,APCHSZ)) Q:APCHSZ'=+APCHSZ D
  1. ...X APCHSCKP Q:$D(APCHSQIT)
  1. ...W ?28,^UTILITY($J,"W",DIWL,APCHSZ,0),!
  1. .E W !!
  1. .;W !
  1. K ^UTILITY($J,"W"),APCHSDSC,DIWL,APCHSX,APCHSZ,DIWL,DIWR
  1. Q:$D(APCHSQIT)
  1. W APCHSNAM
  1. W:APCHSDOB]"" ?34,"DOB: ",APCHSDOB,?51,$$AGE(APCHSPAT,DT,"R")
  1. W:APCHSEX]"" ?59,APCHSEX
  1. W:APCHSBT]"" ?67,APCHSBT
  1. W !
  1. I APCHSTR]""!(APCHSMNM]"") W:APCHSTR]"" $E(APCHSTR,1,33) W:APCHSSN]"" ?34,"SSN: ",APCHSSN W !
  1. W:APCHSMNM]"" ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM W !
  1. W APCHSHPH,APCHSOPH W:APCHSFNM]"" ?34,"FATHER'S NAME: ",APCHSFNM W !
  1. S APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
  1. I APCHPLNG]"" W ?34,"PREFERRED LANGUAGE: ",APCHPLNG,!
  1. I APCHSCMR]"" W APCHSCMR,!!
  1. I APCHSLUD]""!(APCHSEL]"") W:APCHSLUD]"" "LAST UPDATED: ",APCHSLUD," " W:APCHSEL]"" ?34,"ELIGIBILITY: ",APCHSEL W !
  1. W:APCHSVST]"" APCHSVST,!
  1. I $P($G(^AUPNPAT(APCHSPAT,40)),U,2)]"" W !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
  1. W !
  1. ;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,!
  1. ;W "DESIGNATED PROVIDER: ",APCHSPP,!
  1. ;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
  1. ;D DSPCMSRG
  1. ; <CLEANUP>
  1. 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
  1. Q
  1. DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
  1. D DSPCMSRG^APCHS
  1. Q
  1. AGE(DFN,D,F) ;EP - Given DFN, return Age.
  1. I '$G(DFN) Q -1
  1. I '$D(^DPT(DFN,0)) Q -1
  1. I $$DOB^AUPNPAT(DFN,"")<0 Q -1
  1. S:$G(D)="" D=DT
  1. S:$G(F)="" F="Y"
  1. NEW %
  1. S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
  1. S %1=%\365.25
  1. I F="Y" Q %1
  1. ;beginning Y2K fix
  1. ;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
  1. Q $S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS") ;Y2000
  1. ;end Y2K
  1. ;