Routine: APCHS1

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"

 .  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

VSDT S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))

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 !

 .  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")

 .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

DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER

 D DSPCMSRG^APCHS

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

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

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

APCHS1.m