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

BHSHS3.m

Go to the documentation of this file. 
  1. BHSHS3 ;IHS/CIA/MGH - Health Summary for other components ;06-Aug-2018 15:44;MGH
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**2,8,15**;March 17, 2006;Build 8
  1.  ;===================================================================
  1.  ;VA health summary components for insurance, elder care, and refusals
  1.  ;Patch 8 added SNOMED reasons for refusal
  1.  ; IHS/TUCSON/LAB - PART 5 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**5,6,8,11**;JUN 24, 1997
  1.  ;Patch 2 for changes in patch 16
  1.  ;Patch 15 -changes for insurance
  1. INS ; ******************* INSURANCE * 9000003, 9000004, 9000006 *********
  1.  N BHSPAT
  1.  S BHSPAT=DFN
  1.  I $O(^AUPNMCD("B",BHSPAT,0))="",'$D(^AUPNMCR(BHSPAT)),'$D(^AUPNPRVT(BHSPAT)),'$D(^AUPNRRE(BHSPAT)) Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "INSURANCE",?25,"NUMBER",?40,"COV",?48,"EL DATE",?59,"SIG DATE",?70,"END DATE",!
  1.  D MAID^BHSINSUR,MCARE^BHSINSUR,THIRD^BHSINSUR,RR^BHSINSUR
  1. INSX K BHSSPDN,BHSSINS,BHSSEDN,BHSSN,BHSSIDN,BHSSDTL,BHSSDTN,BHSSUFF,BHSSCOV,BHSSDTS,BHSSI,BHSSJ,BHSSITB
  1.  Q
  1.  ;
  1.  ;
  1. ELDER1 ;******************** ELDER CARE 1 * 9000010.35
  1.  ;----------------------------------------------------------------
  1.  N BHSPAT,BHSSP,BHSSY
  1.  S BHSPAT=DFN
  1.  I '$D(^AUPNVELD("AA",BHSPAT)) Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "ADL",!
  1.  F BHSSY=.04,.05,.06,.07,.08,.09 Q:$D(GMTSQIT)  S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,1) D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
  1.  .Q
  1.  W !,"IADL",!
  1.  F BHSSY=.11,.12,.13,.14,.15,.16 Q:$D(GMTSQIT)  S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,1) D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
  1.  .Q
  1.  S BHSSN="CHANGE IN FUNCTIONAL STATUS",BHSSP=17,BHSSY=.17 D VAL(BHSPAT,BHSSY,BHSSP,1)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
  1.  Q
  1.  ;
  1. ELDER2 ;*********************elder care last 2 of each * 9000010.35
  1.  N BHSPAT,BHSSP,BHSSY
  1.  S BHSPAT=DFN
  1.  I '$D(^AUPNVELD("AA",BHSPAT)) Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W "ADL",!
  1.  F BHSSY=.04,.05,.06,.07,.08,.09 Q:$D(GMTSQIT)  S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,2) D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .I $G(BHSSX(2))]"" W ?28,$$D($P($G(BHSSX(2)),U)),?40,$P($G(BHSSX(2)),U,2),!
  1.  .Q
  1.  W !,"IADL",!
  1.  F BHSSY=.11,.12,.13,.14,.15,.16 Q:$D(GMTSQIT)  S BHSSP=+$P(BHSSY,".",2),BHSSN=$P(^DD(9000010.35,BHSSY,0),U) D VAL(BHSPAT,BHSSY,BHSSP,2) D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W ?2,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .I $G(BHSSX(2))]"" W ?28,$$D($P($G(BHSSX(2)),U)),?40,$P($G(BHSSX(2)),U,2),!
  1.  .Q
  1.  S BHSSN="CHANGE IN FUNCTIONAL STATUS",BHSSP=17,BHSSY=.17 D VAL(BHSPAT,BHSSY,BHSSP,2)
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W !,BHSSN,?28,$$D($P($G(BHSSX(1)),U)),?40,$P($G(BHSSX(1)),U,2),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $G(BHSSX(2))]"" W ?28,$$D($P($G(BHSSX(2)),U)),?40,$P($G(BHSSX(2)),U,2),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  Q
  1.  ;
  1. D(X) ;
  1.  I $G(X)="" Q ""
  1.  Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3))
  1. VAL(P,F,V,I) ;
  1.  K BHSSX
  1.  NEW % F %=1:1:I S BHSSX(%)=""
  1.  NEW C S C=0
  1.  NEW X,Y
  1.  S X=0 F  S X=$O(^AUPNVELD("AA",P,X)) Q:X=""!(C>I)  S Y=0 F  S Y=$O(^AUPNVELD("AA",P,X,Y)) Q:Y=""!(C>I)  I $P(^AUPNVELD(Y,0),U,V)]"" S C=C+1,BHSSX(C)=9999999-X_"^"_$$VAL^XBDIQ1(9000010.35,Y,F)
  1.  Q
  1.  ;-------------------------------------------------------------------
  1. REFUSAL ;refusal component
  1.  ;--------------------------------------------------------------------
  1.  N BHSPAT,Y,X,R,D,BHSSX
  1.  S BHSPAT=DFN
  1.  ;gather any refuals from Immunization package
  1.  K BHSSX
  1.  S Y=0 F  S Y=$O(^BIPC("AC",BHSPAT,Y)) Q:Y'=+Y  D
  1.  .S X=0 F  S X=$O(^BIPC("AC",BHSPAT,Y,X)) Q:X'=+X  D
  1.  ..S R=$P(^BIPC(X,0),U,3)
  1.  ..Q:R=""
  1.  ..Q:'$D(^BICONT(R,0))
  1.  ..Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1.  ..S D=$P(^BIPC(X,0),U,4)
  1.  ..Q:D=""
  1.  ..S D=9999999-D
  1.  ..Q:D>GMTSDLM
  1.  ..S BHSSX(D,"IMM",X)=""
  1.  I '$D(^AUPNPREF("AA",BHSPAT)),'$D(BHSSX) Q  ;no refusals
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  NEW X,F,I,D,E
  1.  S F=0 F  S F=$O(^AUPNPREF("AA",BHSPAT,F)) Q:F'=+F  D
  1.  .S E=0 F  S E=$O(^AUPNPREF("AA",BHSPAT,F,E)) Q:E'=+E  D
  1.  ..S D=0 F  S D=$O(^AUPNPREF("AA",BHSPAT,F,E,D)) Q:D'=+D!(D>GMTSDLM)  D
  1.  ...S I=0 F  S I=$O(^AUPNPREF("AA",BHSPAT,F,E,D,I)) Q:I'=+I  D
  1.  ....S BHSSX(D,"REF",I)=""
  1.  N BHSSD,BHSSI,SNO
  1.  S BHSSD=0 F  S BHSSD=$O(BHSSX(BHSSD)) Q:BHSSD'=+BHSSD!($D(GMTSQIT))  D
  1.  .S BHSSI=0 F  S BHSSI=$O(BHSSX(BHSSD,"REF",BHSSI)) Q:BHSSI'=+BHSSI!($D(GMTSQIT))  D
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ..W ?3,$$FMTE^XLFDT(9999999-BHSSD),?17,$$VAL^XBDIQ1(9000022,BHSSI,.04),"   (",$$VAL^XBDIQ1(9000022,BHSSI,.01),")",!
  1.  ..S SNO=$$GET1^DIQ(9000022,BHSSI,1.02)
  1.  ..S SNO=$P($$DESC^BSTSAPI(SNO_"^^1"),U,2)
  1.  ..I SNO="" S SNO=$$VAL^XBDIQ1(9000022,BHSSI,.07)
  1.  ..W ?5,"Refusal Type:  ",SNO,!
  1.  ..;W ?5,"Refusal Type:  ",$$VAL^XBDIQ1(9000022,BHSSI,.07),!
  1.  .S BHSSI=0 F  S BHSSI=$O(BHSSX(BHSSD,"IMM",BHSSI)) Q:BHSSI'=+BHSSI!($D(GMTSQIT))  D
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ..W ?3,$$FMTE^XLFDT(9999999-BHSSD),?17,$$VAL^XBDIQ1(9002084.11,BHSSI,.02),!
  1.  ..W ?5,"Refusal Type: "_$$VAL^XBDIQ1(9002084.11,BHSSI,.03),!
  1.  Q
  1. LER ;Refusal component patch 2
  1.  ;----------------------------------------------------------
  1.  K BHSX
  1.  S BHSPAT=DFN
  1.  S Y=0 F  S Y=$O(^BIPC("AC",BHSPAT,Y)) Q:Y'=+Y  D
  1.  .S X=0 F  S X=$O(^BIPC("AC",BHSPAT,Y,X)) Q:X'=+X  D
  1.  ..S R=$P(^BIPC(X,0),U,3)
  1.  ..Q:R=""
  1.  ..Q:'$D(^BICONT(R,0))
  1.  ..Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1.  ..S D=$P(^BIPC(X,0),U,4)
  1.  ..Q:D=""
  1.  ..S D=9999999-D
  1.  ..Q:D>GMTSDLM
  1.  ..S BHSX("REF","IMMUNIZATION",$$VAL^XBDIQ1(9002084.11,X,.02),D)=X_U_$$VAL^XBDIQ1(9002084.11,X,.03)
  1.  I '$D(^AUPNPREF("AA",BHSPAT)),'$D(BHSX) Q  ;no refusals
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  NEW X,F,I,D,E,SNO
  1.  S F=0 F  S F=$O(^AUPNPREF("AA",BHSPAT,F)) Q:F'=+F  D
  1.  .S E=0 F  S E=$O(^AUPNPREF("AA",BHSPAT,F,E)) Q:E'=+E  D
  1.  ..S D=0 F  S D=$O(^AUPNPREF("AA",BHSPAT,F,E,D)) Q:D'=+D!(D>GMTSDLM)  D
  1.  ...S I=0 F  S I=$O(^AUPNPREF("AA",BHSPAT,F,E,D,I)) Q:I'=+I  D
  1.  ....S SNO=$$GET1^DIQ(9000022,I,1.02)
  1.  ....S SNO=$P($$DESC^BSTSAPI(SNO_"^^1"),U,2)
  1.  ....I SNO="" S SNO=$$VAL^XBDIQ1(9000022,I,.07)
  1.  ....S BHSX("REF",$$VAL^XBDIQ1(9000022,I,.05),$$VAL^XBDIQ1(9000022,I,.04),D)=I_U_SNO
  1.  ....;S BHSX("REF",$$VAL^XBDIQ1(9000022,I,.05),$$VAL^XBDIQ1(9000022,I,.04),D)=I_U_$$VAL^XBDIQ1(9000022,I,.07)
  1.  NEW BHSD,BHSI,BHSC,BHSDA,BHSRT
  1.  S BHSC="" F  S BHSC=$O(BHSX("REF",BHSC)) Q:BHSC=""!($D(GMTSQIT))  D
  1.  .S BHSI="" F  S BHSI=$O(BHSX("REF",BHSC,BHSI)) Q:BHSI=""!($D(GMTSQIT))  D
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ..S BHSD=$O(BHSX("REF",BHSC,BHSI,0))
  1.  ..S BHSDA=$P(BHSX("REF",BHSC,BHSI,BHSD),U)
  1.  ..S BHSRT=$P(BHSX("REF",BHSC,BHSI,BHSD),U,2)
  1.  ..W ?3,$E(BHSI,1,30),?38,"(",$E($$UP^XLFSTR(BHSRT),1,25),")",?70,$$FMTE^XLFDT(9999999-BHSD,5),!
  1.  Q