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

BDMVRL5.m

Go to the documentation of this file. 
  1. BDMVRL5 ; IHS/CMI/LAB - VIEW PT RECORD LT ;
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**4,12**;JUN 14, 2007;Build 51
  1.  ;
  1. PAUSE ;EP; -- end of action pause
  1.  D RETURN^BDMVU
  1.  Q
  1.  ;
  1. GETPAT ;EP; -- ask user to select patient
  1.  K DIC,DFN,BDMQUIT
  1.  S DIC=9000001
  1.  S DIC(0)="AEMQZ"
  1.  S AUPNLK("INAC")=""  ;1/25/2007 allow lookup of inactive patients
  1.  D DIC^BDMFDIC
  1.  I $G(Y)<1 S BDMQUIT="" K AUPNLK("INAC") Q
  1.  K AUPNLK("INAC")  ;1/25/2007 allow lookup of inactive patients
  1.  S DFN=+Y
  1.  S BDMPAT0=$G(Y(0,0))
  1.  D REGPAT
  1.  Q:$D(BDMQUIT)
  1.  D DOB
  1.  D AGE
  1.  D HRN
  1.  D RES(DFN)
  1.  D DX
  1.  D COMP
  1.  K BDMQUIT
  1.  Q
  1.  ;
  1. GETHSTYP ;EP; -- ask user for health summary type
  1.  N DIC,DR,DD,X
  1.  S X=""
  1.  I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
  1.  S:X="" X="ADULT REGULAR"
  1.  S DIC="^APCHSCTL("
  1.  S DIC(0)="AEMQ"
  1.  S DIC("B")=X
  1.  W !
  1.  D DIC^BDMFDIC
  1.  Q:Y<1
  1.  S APCHSTYP=+Y
  1.  Q
  1. REGPAT ;REGISTER AND PATIENT VARIABLES
  1.  D REG^BDMFUTIL
  1.  Q:$D(BDMQUIT)
  1.  S BDMRPDA=$G(^ACM(41,"AC",DFN,BDMRDA))
  1.  I 'BDMRPDA D NEWPAT
  1.  D PAT^BDMVRL4(DFN,BDMRPDA)
  1.  ;D INA(DFN,BDMRPDA)
  1.  Q
  1.  ;
  1. INA(DFN,ACMRPDA) ;EP - check to see if patient is inactive
  1.  ;cmi/anch/maw 1/25/2007 added per DKR
  1.  Q:'ACMRPDA
  1.  Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)=""
  1.  Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)'="I"
  1.  S DA=ACMRPDA
  1.  S DIE="^ACM(41,"
  1.  S DR="1////I"
  1.  D DIE^BDMFDIC
  1.  Q
  1.  ;
  1. NEWPAT ;EP;CREATE ENTRY FOR NEW REGISTER PATIENT
  1.  D NEWPAT^BDMVRL2
  1.  Q
  1. DXUPD ;EP;UPDATE PATIENT'S DIABETIC DIAGNOSIS
  1.  N X,Y,Z
  1.  I BDMEXT=""!(BDMEXT'=BDMEXTIN) D  Q:BDMEXT=""
  1.  .S DA=$P($G(BDM("DX",1)),U,2)
  1.  .Q:'DA
  1.  .S DIK="^ACM(44,"
  1.  .D ^DIK
  1.  S:'$D(BDM("DX",1)) $P(BDM("DX",1),U)=$P($G(BDMEXT),U)
  1.  S Y=$P(BDM("DX",1),U)
  1.  I Y=$G(BDMDX) K BDMDX Q
  1.  S:$G(BDMEXT)]"" BDMX=$O(^ACM(44.1,"B",$P(BDMEXT,U),0))
  1.  I $G(BDMX) S BDMX=$P(^ACM(44.1,BDMX,0),U)  ;cmi/maw 9/7/06 added due to not allowed 4 slash on .01 below
  1.  Q:$G(BDMX)=""
  1.  S DA=""
  1.  S X=0
  1.  F  S X=$O(BDM("DX",X)) Q:'X  D
  1.  .I $P(BDM("DX",X),U)=$P(BDMEXT,U) S DA=$P(BDM("DX",X),U,2)
  1.  I DA D  Q
  1.  .S DIE="^ACM(44,"
  1.  .S DR=".01///"_BDMX_";2////"_$G(BDM("ONSET"))
  1.  .D DIE^BDMFDIC
  1.  S X=BDMX
  1.  S DIC="^ACM(44,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_DFN_";.03////"_BDMRPDA_";.04////"_BDMRDA_";2////"_$G(BDM("ONSET"))
  1.  D FILE^BDMFDIC
  1.  Q
  1. GRD ;EP;PATIENT REGISTER DATA
  1.  Q:'$G(BDMRPDA)
  1.  N X,Y,Z
  1.  S BDMREG0=$G(^ACM(41,BDMRPDA,0))
  1.  S BDMREGDT=$G(^ACM(41,BDMRPDA,"DT"))
  1.  S BDMCH=$G(^ACM(41,BDMRPDA,"CH"))
  1.  S:'$G(DFN) DFN=$P(BDMREG0,U,2)
  1.  S X=$P($G(^DPT(+DFN,0)),U)
  1.  D 30
  1.  S BDM("PATIENT")=X
  1.  S X=$P(BDMREGDT,U)
  1.  S X=$P($P($P(^DD(9002241,1,0),U,3),(X_":"),2),";")
  1.  D 30
  1.  S BDM("STATUS")=X
  1.  S X=$P(BDMREGDT,U,5)
  1.  S X=$P($P($P(^DD(9002241,5,0),U,3),(X_":"),2),";")
  1.  D 30
  1.  S BDM("CASE PRIORITY")=X
  1.  S X=$P(BDMREGDT,U,6)
  1.  S X=$P($G(^VA(200,+X,0)),U)
  1.  D 30
  1.  S BDM("CASE MANAGER")=X
  1.  S X=$P(BDMREGDT,U,7)
  1.  S X=$P($G(^VA(200,+X,0)),U)
  1.  D 30
  1.  S BDM("PUBLIC HLTH NURSE")=X
  1.  S X=$P(BDMREGDT,U,10)
  1.  S X=$P($G(^DIC(4,+X,0)),U)
  1.  D 30
  1.  S BDM("WHERE FOLLOWED")=X
  1.  S X=$P(BDMREGDT,U,13)
  1.  D 30
  1.  S BDM("CLIENT CONTACT")=X
  1.  S X=$P($G(^AUPNPAT(DFN,0)),U,14)
  1.  S X=$S($G(^DD(9000001,.14,0))[200:$P($G(^VA(200,+X,0)),U),1:$P($G(^DIC(16,+X,0)),U))
  1.  D 30
  1.  S BDM("PRIMARY PROVIDER")=X
  1.  S X=$P(BDMREGDT,U,15)
  1.  S X=$P($G(^VA(200,+X,0)),U)
  1.  D 30
  1.  S BDM("REGISTER PROVIDER")=X
  1.  S X=$P(BDMREGDT,U,14)
  1.  S X=$P($P($P(^DD(9002241,15.1,0),U,3),(X_":"),2),";")
  1.  D 30
  1.  S BDM("PROVIDER CATEGORY")=X
  1.  S Y=$P(BDMREGDT,U,2)
  1.  X ^DD("DD")
  1.  D 15
  1.  S BDM("DATE ACTIVATED")=Y
  1.  S Y=$P(BDMREGDT,U,3)
  1.  X ^DD("DD")
  1.  D 15
  1.  S BDM("DATE INACTIVATED")=Y
  1.  S Y=$P(BDMREGDT,U,4)
  1.  X ^DD("DD")
  1.  D 15
  1.  S BDM("INITIAL ENTRY DATE")=Y
  1.  S Y=$P(BDMREGDT,U,11)
  1.  X ^DD("DD")
  1.  D 15
  1.  S BDM("DATE LAST EDITED")=Y
  1.  S Y=$P(BDMREGDT,U,8)
  1.  X ^DD("DD")
  1.  D 15
  1.  S BDM("LAST REVIEW DATE")=Y
  1.  S Y=$P(BDMREGDT,U,9)
  1.  X ^DD("DD")
  1.  D 15
  1.  S BDM("NEXT REVIEW DATE")=Y
  1.  D DOB
  1.  D AGE
  1.  D HRN
  1.  D RES(DFN)
  1.  D DX
  1.  D COMP
  1.  Q
  1. DOB ;DATE OF BIRTH
  1.  N X,Y,Z
  1.  K BDM("DOB")
  1.  S Y=$P(^DPT(DFN,0),U,3)
  1.  S BDM("DOB")=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$S($E(Y,1,3)>299:20_$E(Y,2,3),1:(19_$E(Y,2,3)))
  1.  S Z=""
  1.  S X=$G(^DPT(DFN,.11))
  1.  F J=1:1:6 I $P(X,U,J)]"" S Y=$P(X,U,J) S:J=5 Y=$P($G(^DIC(5,+Y,0)),U,2) S Z=Z_Y S:J'=6 Z=Z_","
  1.  S BDM("ADDRESS")=Z
  1.  S BDM("PHONE")=$P($G(^DPT(DFN,.13)),U)
  1.  Q
  1. AGE ;PATIENT AGE
  1.  N X,Y,Z
  1.  K BDM("AGE")
  1.  S X=$P(^DPT(DFN,0),U,3)
  1.  S Y=$E(DT,1,3)
  1.  S Z=$E(Y,1,3)-$E(X,1,3)
  1.  S:$E(X,4,7)>$E(DT,4,7) Z=Z-1
  1.  S BDM("AGE")=Z
  1.  Q
  1. HRN ;HRN
  1.  S BDM("HRN")=$P($G(^AUPNPAT(DFN,41,+$G(DUZ(2)),0)),U,2)
  1.  Q
  1. RES(DFN) ;EP;CURRENT RESIDENCE      
  1.  N X
  1.  S X=$O(^AUPNPAT(DFN,51,99999999),-1)
  1.  S:X X=$P($G(^AUPNPAT(DFN,51,X,0)),U,3)
  1.  S:'X X=+$P($G(^AUPNPAT(DFN,11)),U,17)
  1.  I 'X S X=$P($G(^AUPNPAT(DFN,11)),U,18) S:X]"" X=$O(^AUTTCOM("B",X,0))
  1.  S (BDM,BDM("RES"))=X
  1.  Q
  1. DX ;DIABETIC DIAGNOSES
  1.  K BDM("DX")
  1.  N X,Y,Z
  1.  S (BDMEXT,BDMEXTIN)=""
  1.  S (X,Z)=0
  1.  F  S X=$O(^ACM(44,"C",DFN,X)) Q:'X  D
  1.  .S Y=$G(^ACM(44,X,0))
  1.  .Q:'Y
  1.  .Q:$P(Y,U,4)'=BDMRDA
  1.  .S Y=$G(^ACM(44.1,+Y,0))
  1.  .S Z=Z+1
  1.  .D DD
  1.  .S BDM("DX",Z)=$P(Y,U)_U_X_U_BDM("ONSET DISPLAY")
  1.  .S:Z=1 (BDMEXT,BDMEXTIN)=$P(Y,U)
  1.  S Z=1
  1.  S X=$O(^ACM(44,"C",DFN,X))
  1.  D:X DD
  1.  Q
  1.  S BDMX=1
  1.  F  S BDMX=$O(BDM("DX",BDMX)) Q:'BDMX  D
  1.  .S DA=$P(BDM("DX",BDMX),U,2)
  1.  .Q:'DA
  1.  .S DIK="^ACM(44.,"
  1.  .D DIK^BDMFDIC
  1.  .K BDM("DX",BDMX)
  1.  Q
  1. DD ;ONSET DATE
  1.  N Y
  1.  S Y=$P($G(^ACM(44,X,"SV")),U,2)
  1.  X:Y ^DD("DD")
  1.  S BDM("ONSET DISPLAY")=Y
  1.  Q
  1. 30 ;PAD TO 30 CHARACTERS
  1.  S X=X_$E("                              ",1,30-$L(X))
  1.  Q
  1. 15 ;PAD TO 15 CHARACTERS
  1.  S Y=Y_$E("               ",1,15-$L(Y))
  1.  Q
  1. COMP ;PATIENT'S COMPLICATIONS
  1.  K BDM("COMP")
  1.  N X,Y,Z
  1.  S (X,Z)=0
  1.  F  S X=$O(^ACM(42,"C",DFN,X)) Q:'X  D
  1.  .S ACM0=$G(^ACM(42,X,0))
  1.  .Q:'ACM0
  1.  .Q:$P(ACM0,U,4)'=BDMRDA
  1.  .S Y=$G(^ACM(42.1,+ACM0,0))
  1.  .S Z=Z+1
  1.  .S BDM("COMP",Z)=$P(Y,U)
  1.  .S Y=$P($G(^ACM(42,X,"DT")),U)
  1.  .X ^DD("DD")
  1.  .S BDM("COMP",Z)=BDM("COMP",Z)_U_Y
  1.  Q
  1. PP ;EP;PRIMARY CARE PROVIDER
  1.  Q
  1.  Q:$G(^DD(9000001,.14,0))[200
  1.  N BDMPP,BDMPP6
  1.  I $P($G(^AUPNPAT(+$G(DFN),0)),U,14) D
  1.  .S BDMPP6=$P(^AUPNPAT(DFN,0),U,14)
  1.  .S BDMPP=$O(^VA(200,"A16",+$G(BDMPP6),0))
  1.  I '$G(BDMPP) D
  1.  .S BDMPP=$P($G(^ACM(41,BDMRPDA,"DT")),U,15)
  1.  .Q:'BDMPP
  1.  .S BDMPP6=$P($G(^VA(200,BDMPP,0)),U,16)
  1.  .S DA=DFN
  1.  .S DIE="^AUPNPAT("
  1.  .S DR=".14////"_BDMPP6
  1.  .D DIE^BDMFDIC
  1.  Q:$P($G(^ACM(41,BDMRPDA,"DT")),U,15)
  1.  S DA=BDMRPDA
  1.  S DIE="^ACM(41,"
  1.  S DR="15////"_BDMPP
  1.  D DIE^BDMFDIC
  1.  Q
  1. CONTACT ;CLIENT CONTACT INFO
  1.  Q:$P($G(^ACM(41,BDMRPDA,"DT")),U,13)]""
  1.  N X,Y,Z
  1.  S Z=""
  1.  S X=$G(^DPT(DFN,.11))
  1.  F J=1:1:6 I $P(X,U,J)]"" S Y=$P(X,U,J) S:J=5 Y=$P($G(^DIC(5,+Y,0)),U,2) S Z=Z_Y_","
  1.  S X=$P($G(^DPT(DFN,.13)),U)
  1.  S DA=BDMRPDA
  1.  S DIE="^ACM(41,"
  1.  S DR="14////"_Z_"  "_X
  1.  D DIE^BDMFDIC
  1.  Q
  1. NOREG ;EP;NO DIABETES REGISTER ON THE SYSTEM
  1.  D CLEAR^VALM1
  1.  W !!,"There is no IHS DIABETES REGISTER on this system."
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Create the IHS DIABETES REGISTER now?"
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^BDMFDIC
  1.  I Y'=1 S BDMQUIT="" Q
  1. NR1 ;EP;CREATE NEW IHS DIABETES REGISTER
  1.  D NEWREG
  1.  D NEWDIAG
  1.  D NEWCOMP
  1.  D NEWHS
  1.  Q
  1. NEWREG ;CREATE IHS DIABETES REGISTER
  1.  S X=BDMREGNM
  1.  I $D(^ACM(41.1,"B",X)) S BDMRDA=$O(^(X,0)) Q:BDMRDA
  1.  S DIC="^ACM(41.1,"
  1.  S DIC(0)="L"
  1.  D FILE^BDMFDIC
  1.  S BDMRDA=+Y
  1.  Q
  1. NEWDIAG ;IHS DIABETES REGISTER DIAGNOSES
  1.  F BDMX="TYPE 1","TYPE 2","GESTATIONAL DM","IMPAIRED GLUCOSE TOLERANCE" D
  1.  .S BDMY=$O(^ACM(44.1,"B",BDMX,0))
  1.  .I BDMY,$D(^ACM(44.1,BDMY,"RG","B",BDMRDA)) Q
  1.  .I 'BDMY D
  1.  ..S X=BDMX
  1.  ..S DIC="^ACM(44.1,"
  1.  ..S DIC(0)="L"
  1.  ..D FILE^BDMFDIC
  1.  ..S BDMY=+Y
  1.  .S X=BDMRDA
  1.  .S DA=+Y
  1.  .S DA(1)=+Y
  1.  .S $P(^ACM(44.1,BDMY,"RG",0),U,2)="9002244.11P"
  1.  .S DIC="^ACM(44.1,"_DA_",""RG"","
  1.  .S DIC(0)="L"
  1.  .D FILE^BDMFDIC
  1.  Q
  1. NEWCOMP ;IHS DIABETES REGISTER COMPLICATIONS
  1.  S:'$G(BDMRDA) BDMRDA=$O(^ACM(41.1,"B",BDMREGNM,0))
  1.  Q:'BDMRDA
  1.  F BDMX="CVA (STROKE)","END STAGE RENAL DISEASE","FIXED PROTEINURIA","HIGH RISK FOOT","HYPERTENSION","LASER TX FOR RETINOPATHY","MAJOR AMPUTATION(S)","MINOR AMPUTATION(S)","RETINOPATHY" D
  1.  .S BDMY=$O(^ACM(42.1,"B",BDMX,0))
  1.  .I BDMY,$D(^ACM(42.1,BDMY,"RG","B",BDMRDA)) Q
  1.  .I 'BDMY D
  1.  ..S X=BDMX
  1.  ..S DIC="^ACM(42.1,"
  1.  ..S DIC(0)="L"
  1.  ..D FILE^BDMFDIC
  1.  ..S BDMY=+Y
  1.  .S X=BDMRDA
  1.  .S DA=+Y
  1.  .S DA(1)=+Y
  1.  .S $P(^ACM(42.1,DA,"RG",0),U,2)="9002242.11P"
  1.  .S DIC="^ACM(42.1,"_DA_",""RG"","
  1.  .S DIC(0)="L"
  1.  .D FILE^BDMFDIC
  1.  Q
  1. NEWHS ;EP;NEW HEALTH SUMMARIES FOR DMS
  1.  N BDMX,BDMDA
  1.  F BDMX="DMS LAB REPORT","DMS DIABETES LAB REPORT","DMS DIABETIC FLOWSHEET" D
  1.  .S BDMDA=""
  1.  .I $D(^APCHSCTL("B",BDMX)) S BDMDA=$O(^APCHSCTL("B",BDMX,0))
  1.  .I '$G(BDMDA) D
  1.  ..S X=BDMX
  1.  ..S DIC="^APCHSCTL("
  1.  ..S DIC(0)="LZ"
  1.  ..D FILE^BDMFDIC
  1.  ..S BDMDA=+Y
  1.  .Q:BDMDA<1
  1.  .I BDMX["LAB REPORT" D LAB
  1.  .I BDMX["FLOWSHEET" D FS
  1.  Q
  1. LAB S X=$O(^APCHSCMP("B","LABORATORY DATA",0))
  1.  Q:'X
  1.  K BDMQUIT
  1.  S Y=0
  1.  F  S Y=$O(^APCHSCTL(BDMDA,1,Y)) Q:'Y  D
  1.  .I $P($G(^APCHSCTL(BDMDA,1,Y,0)),U,2)=X S BDMQUIT=""
  1.  I $D(BDMQUIT) K BDMQUIT Q
  1.  S $P(^APCHSCTL(BDMDA,1,0),U,2)="9001015.01IA"
  1.  S (DA,DA(1))=BDMDA
  1.  S DIC="^APCHSCTL("_DA_",1,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")="1////"_X_";2////30;3////1Y"
  1.  S X=5
  1.  D FILE^BDMFDIC
  1.  Q:Y<1
  1.  D DMLAB^BDMFUTIL:BDMX["DIABETES LAB"
  1.  Q
  1. FS S X=$O(^APCHSCMP("B","FLOWSHEETS",0))
  1.  Q:'X
  1.  K BDMQUIT
  1.  S Y=0
  1.  F  S Y=$O(^APCHSCTL(BDMDA,1,Y)) Q:'Y  D
  1.  .I $P($G(^APCHSCTL(BDMDA,1,Y,0)),U,2)=X S BDMQUIT=""
  1.  I $D(BDMQUIT) K BDMQUIT Q
  1.  S $P(^APCHSCTL(BDMDA,1,0),U,2)="9001015.01IA"
  1.  S (DA,DA(1))=BDMDA
  1.  S DIC="^APCHSCTL("_DA_",1,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")="1////"_X_";2////10;3////1Y"
  1.  S X=5
  1.  D FILE^BDMFDIC
  1.  Q:Y<1
  1.  S X=$O(^APCHSFLC("B","DIABETIC FLOWSHEET",0))
  1.  Q:'X
  1.  K BDMQUIT
  1.  S Y=0
  1.  F  S Y=$O(^APCHSCTL(BDMDA,6,Y)) Q:'Y  D
  1.  .I $P($G(^APCHSCTL(BDMDA,6,Y,0)),U,2)=X S BDMQUIT=""
  1.  I $D(BDMQUIT) K BDMQUIT Q
  1.  S (DA,DA(1))=BDMDA
  1.  S $P(^APCHSCTL(DA,6,0),U,2)="9001015.07IA"
  1.  S DIC="^APCHSCTL("_DA_",6,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")="1////"_X
  1.  S X=5
  1.  D FILE^BDMFDIC
  1.  Q