- APCHS1 ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- ;;2.0;IHS PCC SUITE;**2,5,10,11**;MAY 14, 2009;Build 58
- ;CMI/TUCSON/LAB - patch 2 fix age display
- ;IHS/CMI/LAB - patch 11, added check for LR nodes to prevent undef
- ; patch 11, added Notice of Privacy Act data per Shirley Lujan email
- ;IHS/CMI/LAB - patch 12 added chronic pain registry data per ANMC
- ;
- 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(APCHSPAT)
- ;S APCHSSN=$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"
- ; start - vjm 9/20/01 logic for Blood Bank blood type
- ; 1) use BB's ABO/Rh - if it exists
- ; 2) use PCC blood type - if it exists
- ; 3) otherwise, say 'no blood type'
- ;S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
- D
- . Q:'$D(^DPT(APCHSPAT,"LR"))
- . S APCHX("LRDFN")=^DPT(APCHSPAT,"LR") ; get pt's LRDFN
- . D ; get Blood Bank blood type
- .. Q:'$D(APCHX("LRDFN"))
- .. Q:APCHX("LRDFN")=""
- .. Q:'$D(^LR(APCHX("LRDFN"),0))
- .. S APCHX("LR")=^LR(APCHX("LRDFN"),0)
- .. S APCHX("ABO")=$P($G(APCHX("LR")),U,5)
- .. Q:APCHX("ABO")=""
- .. S APCHX("Rh")=$P($G(APCHX("LR")),U,6)
- .. Q:APCHX("Rh")=""
- .. S APCHX("ABO/Rh")=APCHX("ABO")_"/"_APCHX("Rh")
- .. S:$D(APCHX("ABO/Rh")) APCHSBT="ABO/Rh: "_APCHX("ABO/Rh")
- .. Q
- . Q
- I '$D(APCHX("ABO/Rh")) D ; no BB data - data from ^DPT BType
- . S APCHSBT=$P(APCHSN,U,13)
- . S:APCHSBT="" APCHSBT="no blood type"
- . Q
- K APCHX ; kill APCHX vars
- ; end - vjm 9/20/01
- ;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,$P(^DD(9000001,.14,0),U,2)[6 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 APCHSNL=$P($G(^APCHSITE(DUZ(2),0)),U,4)
- S APCHSFLD=$P($G(^APCHSITE(DUZ(2),0)),U,5)
- I 'APCHSNL S APCHSNL=2
- I APCHSFLD="" S APCHSFLD="F"
- K APCHSRE1
- S C=0,APCHTCNT=0
- S X=0 F S X=$O(^AUPNPAT(APCHSPAT,13,X)) Q:X'=+X S APCHTCNT=APCHTCNT+1
- I APCHSFLD="F" S X=0 F S X=$O(^AUPNPAT(APCHSPAT,13,X)) Q:X'=+X!(C=APCHSNL) S C=C+1,APCHSRE1(C)=^AUPNPAT(APCHSPAT,13,X,0)
- I APCHSFLD="L" S X=9999999 F S X=$O(^AUPNPAT(APCHSPAT,13,X),-1) Q:X<1!(C=APCHSNL) S C=C+1,APCHSRE1(99999-C)=^AUPNPAT(APCHSPAT,13,X,0)
- ;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($G(^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
- S APCHOTPH=$P($G(^AUPNPAT(APCHSPAT,18)),U,1)
- 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
- ; start - vjm 9/20/2001 - to accomodate the display of ABO/Rh
- ;W:APCHSBT]"" ?67,APCHSBT
- ;W !
- D
- . I APCHSBT["/" W !,?34,APCHSBT,! Q
- . W:APCHSBT]"" ?67,APCHSBT,!
- . Q
- ; end - vjm 9/20/2001
- 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")
- D
- .I APCHOTPH]"" W "OTHER PHONE: ",APCHOTPH
- .I APCHPLNG]"" W ?34,"PREFERRED LANGUAGE: ",APCHPLNG
- .I APCHOTPH]""!(APCHPLNG)]"" W !
- I APCHSCMR]"" W APCHSCMR,!!
- I APCHSLUD]""!(APCHSEL]"") W:APCHSLUD]"" "LAST UPDATED: ",APCHSLUD," " W:APCHSEL]"" ?34,"ELIGIBILITY: ",APCHSEL W !
- W:APCHSVST]"" APCHSVST,!
- ;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
- S APCHSNPP=$G(^AUPNNPP(APCHSPAT,0))
- W !,"NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.02)
- W !," DATE RECEIVED BY PATIENT: ",$$FMTE^XLFDT($P(APCHSNPP,U,3))
- W !," WAS ACKNOWLEDGEMENT SIGNED? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.04)
- I $P(APCHSNPP,U,5)]"" D
- .W !," REASON: ",$P(APCHSNPP,U,5)
- W !
- K APCHSNPP
- 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,!
- X APCHSCKP Q:$D(APCHSQIT)
- I $O(^BDPRECN("C",APCHSPAT,0)) D BDPDISP G REM
- W "DESIGNATED PRIMARY CARE PROVIDER: ",APCHSPP,!
- REM ;
- ;IHS/ANMC/LAB - added next 3 lines per Mosley 2/12/01
- I $P($G(^BWP(APCHSPAT,0)),U,25) S A="WOMEN'S HEALTH DESIGNATED PROVIDER" W ?(38-$L(A)),A,": "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25),!
- I $P($G(^AUPNPAT(APCHSPAT,17)),U,1) S A="PRIMARY MENTAL HEALTH PROVIDER" W ?(38-$L(A)),A,": ",$E($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22),!
- I $P($G(^AUPNPAT(APCHSPAT,17)),U,4) S A="SECONDARY MENTAL HEALTH PROVIDER" W ?(38-$L(A)),A,": ",$$VAL^XBDIQ1(9000001,APCHSPAT,1704),!
- ;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
- I $D(APCHSRE1) W "REMARKS:",! D
- .S APCHSX=0 F S APCHSX=$O(APCHSRE1(APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) D
- ..X APCHSCKP Q:$D(APCHSQIT)
- ..W ?1,APCHSRE1(APCHSX),!
- I APCHSNL<APCHTCNT W ?1,"[more]",!
- I $D(^BCPP(APCHSPAT)) D ;IHS/ANMC/LAB
- .S X="BCPAPI" X ^%ZOSF("TEST") I '$T Q
- .W !,"CHRONIC PAIN REGISTRY STATUS: ",$$VAL^XBDIQ1(90246,APCHSPAT,.02) ;IHS/ANMC/LAB - added for chronic pain registry
- .D ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1) W ?45,$S(APCHAG:"Opioid Agreement",1:"No Opioid Agreement"),! ;IHS/ANMC/LAB
- I $P($G(^AUPNPAT(APCHSPAT,40)),U,2)]"" W !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
- D DSPCMSRG
- ; CIA/PLS - 11/24/04 - WiseWoman Modification per Mike Mosley
- ;D WWDSPL(APCHSPAT) ; WW modification per Mike Mosley
- ; <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
- K APCHSX,APCHSRE1,APCHSNL,APCHSFLD
- 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
- ;
- BDPDISP ;EP - display providers from desg prov package
- W ?30,"DESIGNATED PROVIDERS",!
- S APCHSX=0 F S APCHSX=$O(^BDPRECN("C",APCHSPAT,APCHSX)) Q:APCHSX'=+APCHSX D
- .X APCHSCKP Q:$D(APCHSQIT)
- .;get category and check health summary status
- .S A=$P($G(^BDPRECN(APCHSX,0)),U)
- .Q:A=""
- .Q:'$D(^BDPTCAT(A,0))
- .Q:$P(^BDPTCAT(A,0),U,8)="N"
- .S A=$$VAL^XBDIQ1(90360.1,APCHSX,.01) S:A="DESIGNATED PRIMARY PROVIDER" A="DESIGNATED PRIMARY CARE PROVIDER" W ?(38-$L(A)),A,": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03),!
- .Q
- Q
- WWDSPL(DFN) ;
- N AGE,STAT,SDATE,WW
- Q:$E(APCHSEX,1)'="F" "" ; Must be a female patient
- S STAT="",SDATE=0
- S WW=$$WWENPROC(DFN)
- I WW D
- .S STAT="ENROLLED",SDATE=WW
- E D
- .S STAT=$$GET1^DIQ(9000001,DFN,1709)
- .I $L(STAT) D
- ..S SDATE=$$GET1^DIQ(9000001,DFN,1710,"I")
- .E D
- ..S AGE=$$AGE^AUPNPAT(DFN)
- ..S:AGE>29&(AGE<65) STAT="UNKNOWN"
- I $L(STAT) D
- .W !,"WW Status: ",STAT W:SDATE ?30,"WW Update Date: ",$$FMTE^XLFDT(SDATE)
- .W !!
- Q
- ; Return date of WW Enrollment Procedure or Zero
- WWENPROC(DFN) ;
- N IEN,PDT
- S PDT=0
- Q:'$G(DFN) PDT
- S (IEN,PDT)=0 F S IEN=$O(^BWPCD("C",DFN,IEN)) Q:'IEN D
- .I $$GET1^DIQ(9002086.1,IEN,4.01,"I")=1 D
- ..S PDT=+$$GET1^DIQ(9002086.1,IEN,4.02,"I")
- Q PDT
- SSN(P) ;EP
- I '$G(P) Q ""
- I '$D(^DPT(P,0)) Q ""
- Q $S($L($P(^DPT(P,0),U,9))=9:$J("XXX-XX-"_$E($P(^DPT(P,0),U,9),6,9),11),1:$J($P(^DPT(P,0),U,9),11))
- APCHS1 ; IHS/CMI/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
- +1 ;;2.0;IHS PCC SUITE;**2,5,10,11**;MAY 14, 2009;Build 58
- +2 ;CMI/TUCSON/LAB - patch 2 fix age display
- +3 ;IHS/CMI/LAB - patch 11, added check for LR nodes to prevent undef
- +4 ; patch 11, added Notice of Privacy Act data per Shirley Lujan email
- +5 ;IHS/CMI/LAB - patch 12 added chronic pain registry data per ANMC
- +6 ;
- 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 SET APCHSSN=$$SSN(APCHSPAT)
- +9 ;S APCHSSN=$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
- +10 SET APCHSN=$GET(^DPT(APCHSPAT,.24))
- +11 SET APCHSMNM=$PIECE(APCHSN,U,3)
- +12 SET APCHSFNM=$PIECE(APCHSN,U)
- +13 SET APCHSN=^AUPNPAT(APCHSPAT,0)
- +14 SET Y=$PIECE(APCHSN,U,3)
- +15 IF 'Y
- SET APCHSLUD=""
- +16 IF '$TEST
- XECUTE ^DD("DD")
- SET APCHSLUD=Y
- +17 ;S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
- +18 ; start - vjm 9/20/01 logic for Blood Bank blood type
- +19 ; 1) use BB's ABO/Rh - if it exists
- +20 ; 2) use PCC blood type - if it exists
- +21 ; 3) otherwise, say 'no blood type'
- +22 ;S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
- +23 Begin DoDot:1
- +24 IF '$DATA(^DPT(APCHSPAT,"LR"))
- QUIT
- +25 ; get pt's LRDFN
- SET APCHX("LRDFN")=^DPT(APCHSPAT,"LR")
- +26 ; get Blood Bank blood type
- Begin DoDot:2
- +27 IF '$DATA(APCHX("LRDFN"))
- QUIT
- +28 IF APCHX("LRDFN")=""
- QUIT
- +29 IF '$DATA(^LR(APCHX("LRDFN"),0))
- QUIT
- +30 SET APCHX("LR")=^LR(APCHX("LRDFN"),0)
- +31 SET APCHX("ABO")=$PIECE($GET(APCHX("LR")),U,5)
- +32 IF APCHX("ABO")=""
- QUIT
- +33 SET APCHX("Rh")=$PIECE($GET(APCHX("LR")),U,6)
- +34 IF APCHX("Rh")=""
- QUIT
- +35 SET APCHX("ABO/Rh")=APCHX("ABO")_"/"_APCHX("Rh")
- +36 IF $DATA(APCHX("ABO/Rh"))
- SET APCHSBT="ABO/Rh: "_APCHX("ABO/Rh")
- +37 QUIT
- End DoDot:2
- +38 QUIT
- End DoDot:1
- +39 ; no BB data - data from ^DPT BType
- IF '$DATA(APCHX("ABO/Rh"))
- Begin DoDot:1
- +40 SET APCHSBT=$PIECE(APCHSN,U,13)
- +41 IF APCHSBT=""
- SET APCHSBT="no blood type"
- +42 QUIT
- End DoDot:1
- +43 ; kill APCHX vars
- KILL APCHX
- +44 ; end - vjm 9/20/01
- +45 ;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 ***
- +46 SET APCHSPP=$PIECE(APCHSN,U,14)
- +47 ;IHS/ANMC/LJF 8/5/99 prevent UNDEF
- IF APCHSPP=-1
- SET APCHSPP=""
- +48 IF APCHSPP=""
- SET APCHSPP="<none identified>"
- +49 ;*** file 200 conversion ***
- IF +APCHSPP
- IF $PIECE(^DD(9000001,.14,0),U,2)[200
- SET APCHSPP=$PIECE(^VA(200,APCHSPP,0),U)
- +50 IF +APCHSPP
- IF $PIECE(^DD(9000001,.14,0),U,2)[6
- 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 APCHSNL=$PIECE($GET(^APCHSITE(DUZ(2),0)),U,4)
- +10 SET APCHSFLD=$PIECE($GET(^APCHSITE(DUZ(2),0)),U,5)
- +11 IF 'APCHSNL
- SET APCHSNL=2
- +12 IF APCHSFLD=""
- SET APCHSFLD="F"
- +13 KILL APCHSRE1
- +14 SET C=0
- SET APCHTCNT=0
- +15 SET X=0
- FOR
- SET X=$ORDER(^AUPNPAT(APCHSPAT,13,X))
- IF X'=+X
- QUIT
- SET APCHTCNT=APCHTCNT+1
- +16 IF APCHSFLD="F"
- SET X=0
- FOR
- SET X=$ORDER(^AUPNPAT(APCHSPAT,13,X))
- IF X'=+X!(C=APCHSNL)
- QUIT
- SET C=C+1
- SET APCHSRE1(C)=^AUPNPAT(APCHSPAT,13,X,0)
- +17 IF APCHSFLD="L"
- SET X=9999999
- FOR
- SET X=$ORDER(^AUPNPAT(APCHSPAT,13,X),-1)
- IF X<1!(C=APCHSNL)
- QUIT
- SET C=C+1
- SET APCHSRE1(99999-C)=^AUPNPAT(APCHSPAT,13,X,0)
- +18 ;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]"
- +19 SET APCHSADR=""
- +20 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($GET(^DIC(5,APCHSP,0)),U,2)
- SET APCHSADR=APCHSADR_","_APCHSP
- +21 SET APCHSADR=$EXTRACT(APCHSADR,2,255)
- +22 IF APCHSADR]""
- SET APCHSCMR=APCHSCMR_" ("_APCHSADR_") "
- +23 SET APCHSN=$GET(^DPT(APCHSPAT,.13))
- +24 SET APCHSHPH=$PIECE(APCHSN,U,1)
- SET APCHSOPH=$PIECE(APCHSN,U,2)
- +25 IF APCHSHPH=""
- IF APCHSOPH=""
- SET APCHSHPH="<no phone numbers recorded>"
- +26 IF +APCHSHPH
- SET APCHSHPH="(H) "_APCHSHPH
- +27 IF APCHSOPH]""
- SET APCHSOPH="(W) "_APCHSOPH
- IF APCHSHPH]""
- SET APCHSOPH=" "_APCHSOPH
- +28 SET APCHOTPH=$PIECE($GET(^AUPNPAT(APCHSPAT,18)),U,1)
- +29 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 ; start - vjm 9/20/2001 - to accomodate the display of ABO/Rh
+26 ;W:APCHSBT]"" ?67,APCHSBT
+27 ;W !
+28 Begin DoDot:1
+29 IF APCHSBT["/"
WRITE !,?34,APCHSBT,!
QUIT
+30 IF APCHSBT]""
WRITE ?67,APCHSBT,!
+31 QUIT
End DoDot:1
+32 ; end - vjm 9/20/2001
+33 IF APCHSTR]""!(APCHSMNM]"")
IF APCHSTR]""
WRITE $EXTRACT(APCHSTR,1,33)
IF APCHSSN]""
WRITE ?34,"SSN: ",APCHSSN
WRITE !
+34 IF APCHSMNM]""
WRITE ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM
WRITE !
+35 WRITE APCHSHPH,APCHSOPH
IF APCHSFNM]""
WRITE ?34,"FATHER'S NAME: ",APCHSFNM
WRITE !
+36 SET APCHPLNG=$$PREFLANG^APCLAPI7(APCHSPAT,DT,"E")
+37 Begin DoDot:1
+38 IF APCHOTPH]""
WRITE "OTHER PHONE: ",APCHOTPH
+39 IF APCHPLNG]""
WRITE ?34,"PREFERRED LANGUAGE: ",APCHPLNG
+40 IF APCHOTPH]""!(APCHPLNG)]""
WRITE !
End DoDot:1
+41 IF APCHSCMR]""
WRITE APCHSCMR,!!
+42 IF APCHSLUD]""!(APCHSEL]"")
IF APCHSLUD]""
WRITE "LAST UPDATED: ",APCHSLUD," "
IF APCHSEL]""
WRITE ?34,"ELIGIBILITY: ",APCHSEL
WRITE !
+43 IF APCHSVST]""
WRITE APCHSVST,!
+44 ;IHS/CMI/LAB - patch 11 added Notice of Privacy act display
+45 SET APCHSNPP=$GET(^AUPNNPP(APCHSPAT,0))
+46 WRITE !,"NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.02)
+47 WRITE !," DATE RECEIVED BY PATIENT: ",$$FMTE^XLFDT($PIECE(APCHSNPP,U,3))
+48 WRITE !," WAS ACKNOWLEDGEMENT SIGNED? ",$$VAL^XBDIQ1(9000038,APCHSPAT,.04)
+49 IF $PIECE(APCHSNPP,U,5)]""
Begin DoDot:1
+50 WRITE !," REASON: ",$PIECE(APCHSNPP,U,5)
End DoDot:1
+51 WRITE !
+52 KILL APCHSNPP
+53 WRITE !
+54 IF $DATA(^AUPNPAT(APCHSPAT,41))
WRITE "HEALTH RECORD NUMBERS:"
FOR APCHSFP=0:0
SET APCHSFP=$ORDER(^AUPNPAT(APCHSPAT,41,APCHSFP))
IF 'APCHSFP
QUIT
SET APCHSHRN=$PIECE(^(APCHSFP,0),U,2)
SET APCHSFAC=$PIECE(^DIC(4,APCHSFP,0),U,1)
WRITE ?24,$EXTRACT(1000000+APCHSHRN,2,7)," ",APCHSFAC,!
+55 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+56 IF $ORDER(^BDPRECN("C",APCHSPAT,0))
DO BDPDISP
GOTO REM
+57 WRITE "DESIGNATED PRIMARY CARE PROVIDER: ",APCHSPP,!
REM ;
+1 ;IHS/ANMC/LAB - added next 3 lines per Mosley 2/12/01
+2 IF $PIECE($GET(^BWP(APCHSPAT,0)),U,25)
SET A="WOMEN'S HEALTH DESIGNATED PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25),!
+3 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,1)
SET A="PRIMARY MENTAL HEALTH PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": ",$EXTRACT($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22),!
+4 IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,4)
SET A="SECONDARY MENTAL HEALTH PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": ",$$VAL^XBDIQ1(9000001,APCHSPAT,1704),!
+5 ;I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
+6 IF $DATA(APCHSRE1)
WRITE "REMARKS:",!
Begin DoDot:1
+7 SET APCHSX=0
FOR
SET APCHSX=$ORDER(APCHSRE1(APCHSX))
IF APCHSX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?1,APCHSRE1(APCHSX),!
End DoDot:2
End DoDot:1
+10 IF APCHSNL<APCHTCNT
WRITE ?1,"[more]",!
+11 ;IHS/ANMC/LAB
IF $DATA(^BCPP(APCHSPAT))
Begin DoDot:1
+12 SET X="BCPAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+13 ;IHS/ANMC/LAB - added for chronic pain registry
WRITE !,"CHRONIC PAIN REGISTRY STATUS: ",$$VAL^XBDIQ1(90246,APCHSPAT,.02)
+14 ;IHS/ANMC/LAB
DO ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1)
WRITE ?45,$SELECT(APCHAG:"Opioid Agreement",1:"No Opioid Agreement"),!
End DoDot:1
+15 IF $PIECE($GET(^AUPNPAT(APCHSPAT,40)),U,2)]""
WRITE !,"Preferred Method of Receiving Reminders: ",$$VAL^XBDIQ1(9000001,APCHSPAT,4002),!
+16 DO DSPCMSRG
+17 ; CIA/PLS - 11/24/04 - WiseWoman Modification per Mike Mosley
+18 ;D WWDSPL(APCHSPAT) ; WW modification per Mike Mosley
+19 ; <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 KILL APCHSX,APCHSRE1,APCHSNL,APCHSFLD
+2 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 ;
BDPDISP ;EP - display providers from desg prov package
+1 WRITE ?30,"DESIGNATED PROVIDERS",!
+2 SET APCHSX=0
FOR
SET APCHSX=$ORDER(^BDPRECN("C",APCHSPAT,APCHSX))
IF APCHSX'=+APCHSX
QUIT
Begin DoDot:1
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 ;get category and check health summary status
+5 SET A=$PIECE($GET(^BDPRECN(APCHSX,0)),U)
+6 IF A=""
QUIT
+7 IF '$DATA(^BDPTCAT(A,0))
QUIT
+8 IF $PIECE(^BDPTCAT(A,0),U,8)="N"
QUIT
+9 SET A=$$VAL^XBDIQ1(90360.1,APCHSX,.01)
IF A="DESIGNATED PRIMARY PROVIDER"
SET A="DESIGNATED PRIMARY CARE PROVIDER"
WRITE ?(38-$LENGTH(A)),A,": "_$$VAL^XBDIQ1(90360.1,APCHSX,.03),!
+10 QUIT
End DoDot:1
+11 QUIT
WWDSPL(DFN) ;
+1 NEW AGE,STAT,SDATE,WW
+2 ; Must be a female patient
IF $EXTRACT(APCHSEX,1)'="F"
QUIT ""
+3 SET STAT=""
SET SDATE=0
+4 SET WW=$$WWENPROC(DFN)
+5 IF WW
Begin DoDot:1
+6 SET STAT="ENROLLED"
SET SDATE=WW
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET STAT=$$GET1^DIQ(9000001,DFN,1709)
+9 IF $LENGTH(STAT)
Begin DoDot:2
+10 SET SDATE=$$GET1^DIQ(9000001,DFN,1710,"I")
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 SET AGE=$$AGE^AUPNPAT(DFN)
+13 IF AGE>29&(AGE<65)
SET STAT="UNKNOWN"
End DoDot:2
End DoDot:1
+14 IF $LENGTH(STAT)
Begin DoDot:1
+15 WRITE !,"WW Status: ",STAT
IF SDATE
WRITE ?30,"WW Update Date: ",$$FMTE^XLFDT(SDATE)
+16 WRITE !!
End DoDot:1
+17 QUIT
+18 ; Return date of WW Enrollment Procedure or Zero
WWENPROC(DFN) ;
+1 NEW IEN,PDT
+2 SET PDT=0
+3 IF '$GET(DFN)
QUIT PDT
+4 SET (IEN,PDT)=0
FOR
SET IEN=$ORDER(^BWPCD("C",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+5 IF $$GET1^DIQ(9002086.1,IEN,4.01,"I")=1
Begin DoDot:2
+6 SET PDT=+$$GET1^DIQ(9002086.1,IEN,4.02,"I")
End DoDot:2
End DoDot:1
+7 QUIT PDT
SSN(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P,0))
QUIT ""
+3 QUIT $SELECT($LENGTH($PIECE(^DPT(P,0),U,9))=9:$JUSTIFY("XXX-XX-"_$EXTRACT($PIECE(^DPT(P,0),U,9),6,9),11),1:$JUSTIFY($PIECE(^DPT(P,0),U,9),11))
