Routine: BSDX41A

BSDX41A ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 ; Support routines for BSDX HEALTH SUMMARY remote procedure

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

 ;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(^DPT(APCHSPAT,"VET"),U)="Y" D VSTAT^APCHS1

 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=^DPT(APCHSPAT,.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

 S APCHOTPH=$P($G(^AUPNPAT(APCHSPAT,18)),U,1)

 ;demographics output

DEMDSP ; output for demographics taken from APCHS1

 I $G(APCHSBRK)]"" X APCHSBRK

 I $$DOD^AUPNPAT(APCHSPAT)]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="*** DOD: "_$$FMTE^XLFDT($$DOD^AUPNPAT(APCHSPAT),"2D")_" ***"_$C(30)

 S BSDXTMP=APCHSNAM_$$FILL^BSDX41(34-$L(APCHSNAM)," ")

 I APCHSDOB]"" S BSDXTMP=BSDXTMP_"DOB: "_APCHSDOB_"  "_$$AGE(APCHSPAT,DT,"R")_"  "

 I APCHSEX]"" S BSDXTMP=BSDXTMP_APCHSEX_"    "

 .  I APCHSBT["/" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(33)_APCHSBT_$C(30) Q

 .  I APCHSBT]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_APCHSBT_$C(30)

 .  Q

 I APCHSTR]""!(APCHSMNM]"") S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$S(APCHSTR]"":$E(APCHSTR,1,33),1:"")_$S(APCHSSN]"":$$FILL^BSDX41($S((APCHSTR]"")&(APCHSSN]""):34-$L(APCHSTR),1:34))_"SSN: "_APCHSSN,1:"")_$C(30)

 I APCHSMNM]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(33)_"MOTHER'S MAIDEN NAME: "_APCHSMNM_$C(30)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSHPH_APCHSOPH_$S(APCHSFNM]"":$$FILL^BSDX41(33-($L(APCHSHPH)+$L(APCHSOPH)))_"FATHER'S NAME: "_APCHSFNM,1:"")_$C(30)

 I APCHOTPH]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="OTHER PHONE: "_APCHOTPH_$C(30)

 I APCHSCMR]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSCMR_$C(30) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 I APCHSLUD]""!(APCHSEL]"") D

 . I APCHSLUD]"" S BSDXTMP="LAST UPDATED: "_APCHSLUD_"   "

 . I APCHSEL]"" D

  . . S BSDXTMP=BSDXTMP_$$FILL^BSDX41(33-$L("LAST UPDATED: "_APCHSLUD_"   "))_"ELIGIBILITY: "_APCHSEL

 . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)

 I APCHSVST]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSVST_$C(30)

 ;IHS/CMI/LAB - patch 11 added Notice of Privacy act display

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 S APCHSNPP=$G(^AUPNNPP(APCHSPAT,0))

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT?  "_$$VAL^XBDIQ1(9000038,APCHSPAT,.02)_$C(30)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="                    DATE RECEIVED BY PATIENT:  "_$$FMTE^XLFDT($P(APCHSNPP,U,3))_$C(30)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="                  WAS ACKNOWLEDGEMENT SIGNED?  "_$$VAL^XBDIQ1(9000038,APCHSPAT,.04)_$C(30)

 I $P(APCHSNPP,U,5)]"" D

 .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="                                      REASON:  "_$P(APCHSNPP,U,5)_$C(30)

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 K APCHSNPP

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 I $D(^AUPNPAT(APCHSPAT,41)) S LCNT=0 S BSDXTMP="HEALTH RECORD NUMBERS:" F APCHSFP=0:0 S LCNT=LCNT+1 S APCHSFP=$O(^AUPNPAT(APCHSPAT,41,APCHSFP)) Q:'APCHSFP  D

 . S APCHSHRN=$P(^AUPNPAT(APCHSPAT,41,APCHSFP,0),U,2),APCHSFAC=$P(^DIC(4,APCHSFP,0),U,1)

 . S BSDXTMP=BSDXTMP_$S(LCNT=1:" ",1:"                       ")_$E(1000000+APCHSHRN,2,7)_"  "_APCHSFAC

 I $G(APCHSKP)]"" X APCHSCKP Q:$D(APCHSQIT)  ;SAT What is this.

 I $O(^BDPRECN("C",APCHSPAT,0)) D BDPDISP G REM

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_"DESIGNATED PROVIDER: "_APCHSPP_$C(30)

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" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(38-$L(A))_A_":  "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25)_$C(30)

 I $P($G(^AUPNPAT(APCHSPAT,17)),U,1) S A="PRIMARY MENTAL HEALTH PROVIDER" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(38-$L(A))_A_":  "_$E($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22)_$C(30)

 I $P($G(^AUPNPAT(APCHSPAT,17)),U,4) S A="SECONDARY MENTAL HEALTH PROVIDER" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$$FILL^BSDX41(38-$L(A))_A_":  "_$$VAL^XBDIQ1(9000001,APCHSPAT,1704)_$C(30)

 I APCHSRE1]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="REMARKS: "_APCHSRE1_$C(30) I APCHSRE2]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="        "_APCHSRE2_$C(30)

 I $D(^BCPP(APCHSPAT)) D  ;IHS/ANMC/LAB

 .S X="BCPAPI" X ^%ZOSF("TEST") I '$T Q

 .S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)

 .S BSDXTMP="CHRONIC PAIN REGISTRY STATUS: "_$$VAL^XBDIQ1(90246,APCHSPAT,.02) ;IHS/ANMC/LAB - added for chronic pain registry

 .D ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_" "_$S(APCHAG:"Opioid Agreement",1:"No Opioid Agreement")_$C(30)

 D DSPCMSRG

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

DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER

 Q:'$D(^ACM(41,"D",APCHSPAT))

 S APCHSJ=1

 F APCHSI=0:0 S APCHSI=$O(^ACM(41,"AC",APCHSPAT,APCHSI)) Q:'APCHSI  I $P(^ACM(41.1,APCHSI,0),U,7) S BSDXTMP=APCHSJ_" ON CMS REGISTER(S): " D

 .S APCHSJ=0 S BSDXTMP=BSDXTMP_$P(^ACM(41.1,APCHSI,0),U)

 .S APCHSK=^ACM(41,"AC",APCHSPAT,APCHSI) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_"  Status: "_$$VAL^XBDIQ1(9002241,APCHSK,1)_$C(30)

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

BDPDISP ;EP - display providers from desg prov package

 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="DESIGNATED PROVIDERS"_$C(30)

 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 BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=A_":  "_$$VAL^XBDIQ1(90360.1,APCHSX,.03)_$C(30)

.Q

BSDX41A   ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 +1       ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

 +2       ;

 +3       ; Support routines for BSDX HEALTH SUMMARY remote procedure

 +4       ;

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",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^APCHS1(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(^DPT(APCHSPAT,"VET"),U)="Y"

                   DO VSTAT^APCHS1

 +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=^DPT(APCHSPAT,.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       SET APCHOTPH=$PIECE($GET(^AUPNPAT(APCHSPAT,18)),U,1)

 +20      ;demographics output

DEMDSP    ; output for demographics taken from APCHS1

 +1        IF $GET(APCHSBRK)]""

               XECUTE APCHSBRK

 +2        IF $$DOD^AUPNPAT(APCHSPAT)]""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)="*** DOD: "_$$FMTE^XLFDT($$DOD^AUPNPAT(APCHSPAT),"2D")_" ***"_$CHAR(30)

 +3        SET BSDXTMP=APCHSNAM_$$FILL^BSDX41(34-$LENGTH(APCHSNAM)," ")

 +4        IF APCHSDOB]""

               SET BSDXTMP=BSDXTMP_"DOB: "_APCHSDOB_"  "_$$AGE(APCHSPAT,DT,"R")_"  "

 +5        IF APCHSEX]""

               SET BSDXTMP=BSDXTMP_APCHSEX_"    "

 +6        Begin DoDot:1

 +7            IF APCHSBT["/"

                   SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)

                   SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(33)_APCHSBT_$CHAR(30)

                   QUIT

 +8            IF APCHSBT]""

                   SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_APCHSBT_$CHAR(30)

 +9            QUIT

           End DoDot:1

 +10       IF APCHSTR]""!(APCHSMNM]"")

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=$SELECT(APCHSTR]"":$EXTRACT(APCHSTR,1,33),1:"")_$SELECT(APCHSSN]"":$$FILL^BSDX41($SELECT((APCHSTR]"")&(APCHSSN]""):34-$LENGTH(APCHSTR),1:34))_"SSN: "_APCHSSN,1:"")_$CHAR(30)

 +11       IF APCHSMNM]""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(33)_"MOTHER'S MAIDEN NAME: "_APCHSMNM_$CHAR(30)

 +12       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=APCHSHPH_APCHSOPH_$SELECT(APCHSFNM]"":$$FILL^BSDX41(33-($LENGTH(APCHSHPH)+$LENGTH(APCHSOPH)))_"FATHER'S NAME: "_APCHSFNM,1:"")_$CHAR(30)

 +13       IF APCHOTPH]""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)="OTHER PHONE: "_APCHOTPH_$CHAR(30)

 +14       IF APCHSCMR]""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=APCHSCMR_$CHAR(30)

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

 +15       IF APCHSLUD]""!(APCHSEL]"")

               Begin DoDot:1

 +16               IF APCHSLUD]""

                       SET BSDXTMP="LAST UPDATED: "_APCHSLUD_"   "

 +17               IF APCHSEL]""

                       Begin DoDot:2

 +18                       SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(33-$LENGTH("LAST UPDATED: "_APCHSLUD_"   "))_"ELIGIBILITY: "_APCHSEL

                       End DoDot:2

 +19               SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)

               End DoDot:1

 +20       IF APCHSVST]""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=APCHSVST_$CHAR(30)

 +21      ;IHS/CMI/LAB - patch 11 added Notice of Privacy act display

 +22       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

 +23       SET APCHSNPP=$GET(^AUPNNPP(APCHSPAT,0))

 +24       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)="NOTICE OF PRIVACY PRACTICES REC'D BY PATIENT?  "_$$VAL^XBDIQ1(9000038,APCHSPAT,.02)_$CHAR(30)

 +25       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)="                    DATE RECEIVED BY PATIENT:  "_$$FMTE^XLFDT($PIECE(APCHSNPP,U,3))_$CHAR(30)

 +26       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)="                  WAS ACKNOWLEDGEMENT SIGNED?  "_$$VAL^XBDIQ1(9000038,APCHSPAT,.04)_$CHAR(30)

 +27       IF $PIECE(APCHSNPP,U,5)]""

               Begin DoDot:1

 +28               SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)="                                      REASON:  "_$PIECE(APCHSNPP,U,5)_$CHAR(30)

               End DoDot:1

 +29       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

 +30       KILL APCHSNPP

 +31       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

 +32       IF $DATA(^AUPNPAT(APCHSPAT,41))

               SET LCNT=0

               SET BSDXTMP="HEALTH RECORD NUMBERS:"

               FOR APCHSFP=0:0

                   SET LCNT=LCNT+1

                   SET APCHSFP=$ORDER(^AUPNPAT(APCHSPAT,41,APCHSFP))

                   IF 'APCHSFP

                       QUIT

                   Begin DoDot:1

 +33                   SET APCHSHRN=$PIECE(^AUPNPAT(APCHSPAT,41,APCHSFP,0),U,2)

                       SET APCHSFAC=$PIECE(^DIC(4,APCHSFP,0),U,1)

 +34                   SET BSDXTMP=BSDXTMP_$SELECT(LCNT=1:" ",1:"                       ")_$EXTRACT(1000000+APCHSHRN,2,7)_"  "_APCHSFAC

                   End DoDot:1

 +35      ;SAT What is this.

           IF $GET(APCHSKP)]""

               XECUTE APCHSCKP

               IF $DATA(APCHSQIT)

                   QUIT

 +36       IF $ORDER(^BDPRECN("C",APCHSPAT,0))

               DO BDPDISP

               GOTO REM

 +37       SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_"DESIGNATED PROVIDER: "_APCHSPP_$CHAR(30)

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"

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(38-$LENGTH(A))_A_":  "_$$VAL^XBDIQ1(9002086,APCHSPAT,.25)_$CHAR(30)

 +3        IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,1)

               SET A="PRIMARY MENTAL HEALTH PROVIDER"

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(38-$LENGTH(A))_A_":  "_$EXTRACT($$VAL^XBDIQ1(9000001,APCHSPAT,1701),1,22)_$CHAR(30)

 +4        IF $PIECE($GET(^AUPNPAT(APCHSPAT,17)),U,4)

               SET A="SECONDARY MENTAL HEALTH PROVIDER"

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)=$$FILL^BSDX41(38-$LENGTH(A))_A_":  "_$$VAL^XBDIQ1(9000001,APCHSPAT,1704)_$CHAR(30)

 +5        IF APCHSRE1]""

               SET BSDXI=BSDXI+1

               SET ^BSDXTMP($JOB,BSDXI)="REMARKS: "_APCHSRE1_$CHAR(30)

               IF APCHSRE2]""

                   SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)="        "_APCHSRE2_$CHAR(30)

 +6       ;IHS/ANMC/LAB

           IF $DATA(^BCPP(APCHSPAT))

               Begin DoDot:1

 +7                SET X="BCPAPI"

                   XECUTE ^%ZOSF("TEST")

                   IF '$TEST

                       QUIT

 +8                SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)

 +9       ;IHS/ANMC/LAB - added for chronic pain registry

                   SET BSDXTMP="CHRONIC PAIN REGISTRY STATUS: "_$$VAL^XBDIQ1(90246,APCHSPAT,.02)

 +10               DO ACTAGR^BCPAPI(.APCHAG,APCHSPAT,1)

                   SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_" "_$SELECT(APCHAG:"Opioid Agreement",1:"No Opioid Agreement")_$CHAR(30)

               End DoDot:1

 +11       DO DSPCMSRG

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

 +2       ;

DSPCMSRG  ; DISPLAY MEMBERSHIP IN CMS REGISTER

 +1        IF '$DATA(^ACM(41,"D",APCHSPAT))

               QUIT

 +2        SET APCHSJ=1

 +3        FOR APCHSI=0:0

               SET APCHSI=$ORDER(^ACM(41,"AC",APCHSPAT,APCHSI))

               IF 'APCHSI

                   QUIT

               IF $PIECE(^ACM(41.1,APCHSI,0),U,7)

                   SET BSDXTMP=APCHSJ_" ON CMS REGISTER(S): "

                   Begin DoDot:1

 +4                    SET APCHSJ=0

                       SET BSDXTMP=BSDXTMP_$PIECE(^ACM(41.1,APCHSI,0),U)

 +5                    SET APCHSK=^ACM(41,"AC",APCHSPAT,APCHSI)

                       SET BSDXI=BSDXI+1

                       SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_"  Status: "_$$VAL^XBDIQ1(9002241,APCHSK,1)_$CHAR(30)

                   End DoDot:1

 +6        QUIT

 +7       ;

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      ;

BDPDISP   ;EP - display providers from desg prov package

 +1        SET BSDXI=BSDXI+1

           SET ^BSDXTMP($JOB,BSDXI)="DESIGNATED PROVIDERS"_$CHAR(30)

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

                   SET BSDXI=BSDXI+1

                   SET ^BSDXTMP($JOB,BSDXI)=A_":  "_$$VAL^XBDIQ1(90360.1,APCHSX,.03)_$CHAR(30)

 +10               QUIT

               End DoDot:1

 +11       QUIT

 +12      ;

BSDX41A.m