BDMEDMUP ; IHS/CMI/LAB - EDITS FOR AUPNVSIT (VISIT:9000010) 24-MAY-1993 ; 20 Sep 2013 2:49 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**7,8,10**;JUN 14, 2007;Build 12
;
W:$D(IOF) @IOF
W !,$$CTR("DMS DATA ENTRY",80)
W !!,$$CTR("Diabetes Patient Data Update",80)
W !
S BDMEDMPT="" D GETPAT
I BDMEDMPT="" D XIT Q
W !!,"The data you enter for the above patient will be updated in the PCC",!,"database.",!
S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D XIT Q
I 'Y D XIT Q
W !!,"Okay, one more thing ... If you intend to update the DM Date of Onset, you"
W !,"must have the patient's DM problem number available from the problem list"
W !,"The problem number must be entered in the correct field in the following"
W !,"format: XXnn, where XX is the facility abbreviation and nn is the"
W !,"problem number, e.g.: MU7",!
S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D XIT Q
I 'Y D XIT Q
S BDMEDA="" D CREATE
I BDMEDA="" W !!,"Exiting..." H 2 D XIT Q
;do screenman
S DA=BDMEDA,DDSFILE=9003203.2,DR="[BDME DM UPDATE]" D ^DDS
I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***" D DEL K DIMSG H 3 D XIT Q
D UPDPCC
I $D(BDMEDMER) W !!,"the following errors occurred when updating PCC" D
.S X=0 F S X=$O(BDMEDMER(X)) Q:X'=+X W !?5,BDMEDMER(X)
.Q
D REF
D XIT
Q
;
UPDPCC ;update pcc
W !!,"Updating PCC database....hold on a moment...",!
D EN(BDMEDA,.BDMEDMER)
Q
EN(BDMEDA,BDMEDMER) ;PEP - called from DM GUI
;I DUZ=2836 S ^LORITMP(1)=BDMEDA
S BDMEERR=0
K BDMEDMER
Q:'$D(^BDMEDMUP(BDMEDA,0))
S BDMEREC=^BDMEDMUP(BDMEDA,0)
S BDMEREC1=$G(^BDMEDMUP(BDMEDA,11))
;S BDMERE14=$G(^BDMEDMUP(BDMEDA,14))
I '$G(BDMEDMPT) S (AUPNPAT,BDMEDMPT)=$P(BDMEREC,U) ;cmi/maw added 4/20/2004 for GUI Dms
D PROB
D HT
D WT
D BP^BDMEDMU2
D SMOKEHF
D TBHF^BDMEDMU2
D SGHF^BDMEDMU2
D FOOT^BDMEDMU1
D EYE^BDMEDMU1
D DEPR^BDMEDMU1
D DENTAL^BDMEDMU1
D PAP^BDMEDMU1
D MAM^BDMEDMU1
D FLU^BDMEDMU1
D PNEU^BDMEDMU1
D TD^BDMEDMU1
D HEPB^BDMEDMU1
D PPD^BDMEDMU2
D EKG^BDMEDMU2
D EDUC^BDMEDMU2
D LAB^BDMEDMU2
D MED^BDMEDMU2
D RTLHF^BDMEDMU3
D LPHF^BDMEDMU3
D BTLHF^BDMEDMU3
D ENDSHF^BDMEDMU2
DEL S DA=BDMEDA,DIK="^BDMEDMUP(" D ^DIK
Q
REF ;update refusals?
S DIR(0)="Y",DIR("A")="Do you want to enter any Patient REFUSALS/SERVICES NOT DONE",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G DEL
I 'Y G DEL
D REF^BDMEDMU3
Q
ERR(T) ;EP
S BDMEERR=BDMEERR+1,BDMEDMER(BDMEERR)=T
Q
XIT ;
D KILL^AUPNPAT
K DIADD,DLAYGO
D EN^XBVK("APCD"),EN^XBVK("AUPN")
D ^XBFMK
Q
PROB ;
I $P(BDMEREC,U,3)="" Q
I $P(BDMEREC,U,4)="" Q
S N=$P(BDMEREC,U,4) ;problem number to update
S BDMEN=$$PROBNUM(N)
I 'BDMEN S T="<<< Could not update Problem Number "_N_" with Date of DM Onset. >>>" D ERR(T) Q
S BDMED=$P(BDMEREC,U,3)
D ^XBFMK
S DA=BDMEN,DIE="^AUPNPROB(",DR=".13///"_$$FMTE^XLFDT(BDMED) D ^DIE
I $D(Y) S T="<<< Could not update Problem Number "_N_" with Date of DM Onset. DIE failed. >>>" D ERR(T)
D ^XBFMK
Q
HT ;
K BDMEVSIT
I $P(BDMEREC,U,5)="" Q
I $P(BDMEREC,U,6)="" Q
S BDMEDMDT=$P(BDMEREC,U,5)
S BDMEMTYP=$O(^AUTTMSR("B","HT",0))
D EVSIT ;get event visit
I '$G(BDMEVSIT) S T="Could not Create PCC Visit when attempting to update height." D ERR(T) Q
S (X,G)=0 F S X=$O(^AUPNVMSR("AD",BDMEVSIT,X)) Q:X'=+X!(G) I $P(^AUPNVMSR(X,0),U)=BDMEMTYP,$P(^AUPNVMSR(X,0),U,4)=$P(BDMEREC,U,6) S G=1
I G S T="Already have a height of "_$P(BDMEREC,U,6)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(BDMEVSIT,0),U)) D ERR(T) Q
K APCDALVR
S APCDALVR("APCDPAT")=BDMEDMPT
S APCDALVR("APCDVSIT")=BDMEVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
S APCDALVR("APCDTTYP")="`"_BDMEMTYP
S APCDALVR("APCDTVAL")=$P(BDMEREC,U,6)
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S T="Error creating V Measurement Entry for Height. PCC not updated." D ERR(T)
K APCDALVR
Q
WT ;
K BDMEVSIT
I $P(BDMEREC,U,7)="" Q
I $P(BDMEREC,U,8)="" Q
S BDMEDMDT=$P(BDMEREC,U,7)
S BDMEMTYP=$O(^AUTTMSR("B","WT",0))
D EVSIT ;get event visit
I '$G(BDMEVSIT) S T="Could not Create PCC Visit when attempting to update weight." D ERR(T) Q
S (X,G)=0 F S X=$O(^AUPNVMSR("AD",BDMEVSIT,X)) Q:X'=+X!(G) I $P(^AUPNVMSR(X,0),U)=BDMEMTYP,$P(^AUPNVMSR(X,0),U,4)=$P(BDMEREC,U,8) S G=1
I G S T="Already have a weight of "_$P(BDMEREC,U,8)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(BDMEVSIT,0),U)) D ERR(T) Q
K APCDALVR
S APCDALVR("APCDPAT")=BDMEDMPT
S APCDALVR("APCDVSIT")=BDMEVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
S APCDALVR("APCDTTYP")="`"_BDMEMTYP
S APCDALVR("APCDTVAL")=$P(BDMEREC,U,8)
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S T="Error creating V Measurement Entry for Weight. PCC not updated." D ERR(T)
K APCDALVR
Q
SMOKEHF ;
K BDMEVSIT
I $P(BDMEREC,U,9)="" Q
S BDMEDMDT=$S($P(BDMEREC1,U,14)]"":$P(BDMEREC1,U,14),1:DT)
S BDMEMTYP=$P(BDMEREC,U,9)
S BDMEMCAT=$P(^AUTTHF(BDMEMTYP,0),U,3)
D EVSIT ;get event visit
I '$G(BDMEVSIT) S T="Could not Create PCC Visit when attempting to update smoking health factor." D ERR(T) Q
S (X,G)=0 F S X=$O(^AUPNVHF("AD",BDMEVSIT,X)) Q:X'=+X!(G) I $P(^AUPNVHF(X,0),U)=BDMEMTYP S G=1
I G S T="Already have a health factor of "_$P(^AUTTHF($P(BDMEREC,U,9),0),U)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(BDMEVSIT,0),U)) D ERR(T) Q
K APCDALVR
S APCDALVR("APCDPAT")=BDMEDMPT
S APCDALVR("APCDVSIT")=BDMEVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
S APCDALVR("APCDTHF")="`"_BDMEMTYP
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S T="Error creating V Health Factor Entry for Smoking. PCC not updated." D ERR(T)
K APCDALVR
;;update health status
;S BDMEHSE="",X=0 F S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE) I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X
;I BDMEHSE D Q
;.D ^XBFMK K DIADD
;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE
;.I $D(Y) S T="Error updating Health Status entry for Tobacco." D ERR(T)
;.D ^XBFMK
;D ^XBFMK
;;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN
;I Y=-1 S T="Error adding health status entry for Tobacco." D ERR(T)
D ^XBFMK K DIADD,DLAYGO
Q
BSD ;
K BDMEIN
S BDMEIN("PAT")=BDMEDMPT
S BDMEIN("VISIT DATE")=BDMEDMDT_".12"
S BDMEIN("SITE")=DUZ(2)
S BDMEIN("VISIT TYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
S BDMEIN("SRV CAT")="E"
S BDMEIN("TIME RANGE")=0
S BDMEIN("USR")=DUZ
K APCDALVR
K BDMEBSDV
D GETVISIT^APCDAPI4(.BDMEIN,.BDMEBSDV)
S T=$P(BDMEBSDV(0),U,2)
I T]"" Q ;errored
S V=$O(BDMEBSDV(0)) S BDMEVSIT=V
I $G(BDMEBSDV(V))="ADD" D DEDT^APCDEA2(BDMEVSIT)
Q
EVSIT ;EP - get/create event visit
I $L($T(^BSDAPI4)) D Q
.D BSD
K BDMEVSIT
K APCDALVR
S APCDALVR("APCDAUTO")=""
S APCDALVR("APCDPAT")=BDMEDMPT
S APCDALVR("APCDCAT")="E"
S APCDALVR("APCDLOC")=DUZ(2)
S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
S APCDALVR("APCDDATE")=BDMEDMDT_".12"
D ^APCDALV
S BDMEVSIT=$G(APCDALVR("APCDVSIT"))
I $G(APCDALVR("APCDVSIT","NEW")) D DEDT^APCDEA2(BDMEVSIT)
K APCDALVR
Q
CREATE ;create entry in fileman file
S BDMEDA=""
D ^XBFMK
S X=BDMEDMPT,DIC(0)="L",DIC("DR")=".02////^S X=DT",DIC="^BDMEDMUP(",DIADD=1,DLAYGO=9003203.2 K DD,DO,D0 D FILE^DICN
I Y=-1 S T="Error creating fileman file entry. Notify programmer" D ERR(T) Q
S BDMEDA=+Y
D ^XBFMK K DIADD,DLAYGO
Q
GETPAT ;
S BDMEDMPT=""
W !
I '$P($G(^BDMESITE(DUZ(2),0)),U,34) S AUPNLK("INAC")=1
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
I $D(BDMEPARM),$P(BDMEPARM,U,3)="Y" W !?25,"Ok" S %=1 D YN^DICN Q:%'=1
S BDMEDMPT=+Y
D INAC^APCDEA(BDMEDMPT,.X) I 'X S BDMEDMPT="" Q
I DUZ("AG")="I" D ^APCDEMDI
Q
;
VSIT01 ;EP;9000010,.01 (VISIT,VISIT/ADMIT DATE&TIME)
I '$D(AUPNPAT) D:'$D(AUPNTALK)&('$D(ZTQUEUED)) EN^DDIOL(" <No direct entry allowed>") K X Q
S:$E(X,6,7)="00" X=$E(X,1,5)_"01" S:$E(X,4,5)="00" X=$E(X,1,3)_"01"_$E(X,6,7)
I $D(AUPNDOB),$D(AUPNDOD),AUPNDOB,$D(DT),DT D VSIT01B Q
I '$D(AUPNTALK),'$D(ZTQUEUED) D EN^DDIOL(" <Required variables do not exist>")
K X
Q
VSIT01B ;
I '$D(BDMEFVOK),DT_".9999"<X D:'$D(AUPNTALK)&('$D(ZTQUEUED)) EN^DDIOL(" <Future dates not allowed>") K X Q
I DUZ("AG")="I",AUPNDOD,$P(X,".",1)>AUPNDOD D:'$D(AUPNTALK)&('$D(ZTQUEUED)) EN^DDIOL(" <Patient died before this date>") K X Q
I $P(X,".",1)<AUPNDOB D:'$D(AUPNTALK)&('$D(ZTQUEUED)) EN^DDIOL(" <Patient born after this date>") K X Q
Q
;
ID ;
S:$E(BDMEDMDT,6,7)="00" BDMEDMDT=$E(BDMEDMDT,1,5)_"01" S:$E(BDMEDMDT,4,5)="00" BDMEDMDT=$E(BDMEDMDT,1,3)_"01"_$E(BDMEDMDT,6,7)
Q
PROBN ;EP
NEW BDMEPLOC,BDMEPPL,BDMEPN,BDMEPI
S X=$$UP^XLFSTR(X)
S:X["#" X=$P(X,"#")_$P(X,"#",2)
S BDMEPPL="" F BDMEPI=1:1:$L(X) Q:$E(X,BDMEPI)?1N S BDMEPPL=BDMEPPL_$E(X,BDMEPI)
I BDMEPPL="" D EN^DDIOL("No facility code has been entered.") K X Q
S BDMEPLOC="",BDMEPLOC=$O(^AUTTLOC("D",BDMEPPL,BDMEPLOC)) I BDMEPLOC="" D EN^DDIOL("NO Location Abbreviation - PLEASE NOTIFY YOUR SUPERVISOR") K X Q
S BDMEPN=$P(X,BDMEPPL,2) I BDMEPN=""!(BDMEPN<0)!(BDMEPN>999.99) D EN^DDIOL("Invalid problem number") K X Q
S BDMEPN=" "_$E("000",1,(3-$L($P(BDMEPN,"."))))_$P(BDMEPN,".")_"."_$P(BDMEPN,".",2)_$E("00",1,(2-$L($P(BDMEPN,".",2))))
I '$D(^AUPNPROB("AA",AUPNPAT,BDMEPLOC,BDMEPN)) D EN^DDIOL("No Problem Number "_BDMEPN_" on file for this patient for location "_$P(^AUTTLOC(BDMEPLOC,0),U,2)_".") K X Q
Q
PROBNUM(X) ;EP - get problem ien given problem number
I $G(X)="" Q ""
NEW BDMEPLOC,BDMEPPL,BDMEPN,BDMEPI,P
S X=$$UP^XLFSTR(X)
S:X["#" X=$P(X,"#")_$P(X,"#",2)
S BDMEPPL="" F BDMEPI=1:1:$L(X) Q:$E(X,BDMEPI)?1N S BDMEPPL=BDMEPPL_$E(X,BDMEPI)
I BDMEPPL="" Q ""
S BDMEPLOC="",BDMEPLOC=$O(^AUTTLOC("D",BDMEPPL,BDMEPLOC)) I BDMEPLOC="" Q ""
S BDMEPN=$P(X,BDMEPPL,2) I BDMEPN=""!(BDMEPN<0)!(BDMEPN>999.99) Q ""
S BDMEPN=" "_$E("000",1,(3-$L($P(BDMEPN,"."))))_$P(BDMEPN,".")_"."_$P(BDMEPN,".",2)_$E("00",1,(2-$L($P(BDMEPN,".",2))))
S P=$O(^AUPNPROB("AA",AUPNPAT,BDMEPLOC,BDMEPN,0))
Q P
N DIC,DA,D,DZ S DIC="^AUTTLOC(",DIC(0)="E",D="D",DZ="??" D DQ^DICQ K Y,DIC,D
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
BDMEDMUP ; IHS/CMI/LAB - EDITS FOR AUPNVSIT (VISIT:9000010) 24-MAY-1993 ; 20 Sep 2013 2:49 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**7,8,10**;JUN 14, 2007;Build 12
+2 ;
+3 IF $DATA(IOF)
WRITE @IOF
+4 WRITE !,$$CTR("DMS DATA ENTRY",80)
+5 WRITE !!,$$CTR("Diabetes Patient Data Update",80)
+6 WRITE !
+7 SET BDMEDMPT=""
DO GETPAT
+8 IF BDMEDMPT=""
DO XIT
QUIT
+9 WRITE !!,"The data you enter for the above patient will be updated in the PCC",!,"database.",!
+10 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)
DO XIT
QUIT
+12 IF 'Y
DO XIT
QUIT
+13 WRITE !!,"Okay, one more thing ... If you intend to update the DM Date of Onset, you"
+14 WRITE !,"must have the patient's DM problem number available from the problem list"
+15 WRITE !,"The problem number must be entered in the correct field in the following"
+16 WRITE !,"format: XXnn, where XX is the facility abbreviation and nn is the"
+17 WRITE !,"problem number, e.g.: MU7",!
+18 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+19 IF $DATA(DIRUT)
DO XIT
QUIT
+20 IF 'Y
DO XIT
QUIT
+21 SET BDMEDA=""
DO CREATE
+22 IF BDMEDA=""
WRITE !!,"Exiting..."
HANG 2
DO XIT
QUIT
+23 ;do screenman
+24 SET DA=BDMEDA
SET DDSFILE=9003203.2
SET DR="[BDME DM UPDATE]"
DO ^DDS
+25 IF $DATA(DIMSG)
WRITE !!,"ERROR IN SCREENMAN FORM!! ***NOTIFY PROGRAMMER***"
DO DEL
KILL DIMSG
HANG 3
DO XIT
QUIT
+26 DO UPDPCC
+27 IF $DATA(BDMEDMER)
WRITE !!,"the following errors occurred when updating PCC"
Begin DoDot:1
+28 SET X=0
FOR
SET X=$ORDER(BDMEDMER(X))
IF X'=+X
QUIT
WRITE !?5,BDMEDMER(X)
+29 QUIT
End DoDot:1
+30 DO REF
+31 DO XIT
+32 QUIT
+33 ;
UPDPCC ;update pcc
+1 WRITE !!,"Updating PCC database....hold on a moment...",!
+2 DO EN(BDMEDA,.BDMEDMER)
+3 QUIT
EN(BDMEDA,BDMEDMER) ;PEP - called from DM GUI
+1 ;I DUZ=2836 S ^LORITMP(1)=BDMEDA
+2 SET BDMEERR=0
+3 KILL BDMEDMER
+4 IF '$DATA(^BDMEDMUP(BDMEDA,0))
QUIT
+5 SET BDMEREC=^BDMEDMUP(BDMEDA,0)
+6 SET BDMEREC1=$GET(^BDMEDMUP(BDMEDA,11))
+7 ;S BDMERE14=$G(^BDMEDMUP(BDMEDA,14))
+8 ;cmi/maw added 4/20/2004 for GUI Dms
IF '$GET(BDMEDMPT)
SET (AUPNPAT,BDMEDMPT)=$PIECE(BDMEREC,U)
+9 DO PROB
+10 DO HT
+11 DO WT
+12 DO BP^BDMEDMU2
+13 DO SMOKEHF
+14 DO TBHF^BDMEDMU2
+15 DO SGHF^BDMEDMU2
+16 DO FOOT^BDMEDMU1
+17 DO EYE^BDMEDMU1
+18 DO DEPR^BDMEDMU1
+19 DO DENTAL^BDMEDMU1
+20 DO PAP^BDMEDMU1
+21 DO MAM^BDMEDMU1
+22 DO FLU^BDMEDMU1
+23 DO PNEU^BDMEDMU1
+24 DO TD^BDMEDMU1
+25 DO HEPB^BDMEDMU1
+26 DO PPD^BDMEDMU2
+27 DO EKG^BDMEDMU2
+28 DO EDUC^BDMEDMU2
+29 DO LAB^BDMEDMU2
+30 DO MED^BDMEDMU2
+31 DO RTLHF^BDMEDMU3
+32 DO LPHF^BDMEDMU3
+33 DO BTLHF^BDMEDMU3
+34 DO ENDSHF^BDMEDMU2
DEL SET DA=BDMEDA
SET DIK="^BDMEDMUP("
DO ^DIK
+1 QUIT
REF ;update refusals?
+1 SET DIR(0)="Y"
SET DIR("A")="Do you want to enter any Patient REFUSALS/SERVICES NOT DONE"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
GOTO DEL
+3 IF 'Y
GOTO DEL
+4 DO REF^BDMEDMU3
+5 QUIT
ERR(T) ;EP
+1 SET BDMEERR=BDMEERR+1
SET BDMEDMER(BDMEERR)=T
+2 QUIT
XIT ;
+1 DO KILL^AUPNPAT
+2 KILL DIADD,DLAYGO
+3 DO EN^XBVK("APCD")
DO EN^XBVK("AUPN")
+4 DO ^XBFMK
+5 QUIT
PROB ;
+1 IF $PIECE(BDMEREC,U,3)=""
QUIT
+2 IF $PIECE(BDMEREC,U,4)=""
QUIT
+3 ;problem number to update
SET N=$PIECE(BDMEREC,U,4)
+4 SET BDMEN=$$PROBNUM(N)
+5 IF 'BDMEN
SET T="<<< Could not update Problem Number "_N_" with Date of DM Onset. >>>"
DO ERR(T)
QUIT
+6 SET BDMED=$PIECE(BDMEREC,U,3)
+7 DO ^XBFMK
+8 SET DA=BDMEN
SET DIE="^AUPNPROB("
SET DR=".13///"_$$FMTE^XLFDT(BDMED)
DO ^DIE
+9 IF $DATA(Y)
SET T="<<< Could not update Problem Number "_N_" with Date of DM Onset. DIE failed. >>>"
DO ERR(T)
+10 DO ^XBFMK
+11 QUIT
HT ;
+1 KILL BDMEVSIT
+2 IF $PIECE(BDMEREC,U,5)=""
QUIT
+3 IF $PIECE(BDMEREC,U,6)=""
QUIT
+4 SET BDMEDMDT=$PIECE(BDMEREC,U,5)
+5 SET BDMEMTYP=$ORDER(^AUTTMSR("B","HT",0))
+6 ;get event visit
DO EVSIT
+7 IF '$GET(BDMEVSIT)
SET T="Could not Create PCC Visit when attempting to update height."
DO ERR(T)
QUIT
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",BDMEVSIT,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^AUPNVMSR(X,0),U)=BDMEMTYP
IF $PIECE(^AUPNVMSR(X,0),U,4)=$PIECE(BDMEREC,U,6)
SET G=1
+9 IF G
SET T="Already have a height of "_$PIECE(BDMEREC,U,6)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(BDMEVSIT,0),U))
DO ERR(T)
QUIT
+10 KILL APCDALVR
+11 SET APCDALVR("APCDPAT")=BDMEDMPT
+12 SET APCDALVR("APCDVSIT")=BDMEVSIT
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+14 SET APCDALVR("APCDTTYP")="`"_BDMEMTYP
+15 SET APCDALVR("APCDTVAL")=$PIECE(BDMEREC,U,6)
+16 DO ^APCDALVR
+17 IF $DATA(APCDALVR("APCDAFLG"))
SET T="Error creating V Measurement Entry for Height. PCC not updated."
DO ERR(T)
+18 KILL APCDALVR
+19 QUIT
WT ;
+1 KILL BDMEVSIT
+2 IF $PIECE(BDMEREC,U,7)=""
QUIT
+3 IF $PIECE(BDMEREC,U,8)=""
QUIT
+4 SET BDMEDMDT=$PIECE(BDMEREC,U,7)
+5 SET BDMEMTYP=$ORDER(^AUTTMSR("B","WT",0))
+6 ;get event visit
DO EVSIT
+7 IF '$GET(BDMEVSIT)
SET T="Could not Create PCC Visit when attempting to update weight."
DO ERR(T)
QUIT
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",BDMEVSIT,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^AUPNVMSR(X,0),U)=BDMEMTYP
IF $PIECE(^AUPNVMSR(X,0),U,4)=$PIECE(BDMEREC,U,8)
SET G=1
+9 IF G
SET T="Already have a weight of "_$PIECE(BDMEREC,U,8)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(BDMEVSIT,0),U))
DO ERR(T)
QUIT
+10 KILL APCDALVR
+11 SET APCDALVR("APCDPAT")=BDMEDMPT
+12 SET APCDALVR("APCDVSIT")=BDMEVSIT
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+14 SET APCDALVR("APCDTTYP")="`"_BDMEMTYP
+15 SET APCDALVR("APCDTVAL")=$PIECE(BDMEREC,U,8)
+16 DO ^APCDALVR
+17 IF $DATA(APCDALVR("APCDAFLG"))
SET T="Error creating V Measurement Entry for Weight. PCC not updated."
DO ERR(T)
+18 KILL APCDALVR
+19 QUIT
SMOKEHF ;
+1 KILL BDMEVSIT
+2 IF $PIECE(BDMEREC,U,9)=""
QUIT
+3 SET BDMEDMDT=$SELECT($PIECE(BDMEREC1,U,14)]"":$PIECE(BDMEREC1,U,14),1:DT)
+4 SET BDMEMTYP=$PIECE(BDMEREC,U,9)
+5 SET BDMEMCAT=$PIECE(^AUTTHF(BDMEMTYP,0),U,3)
+6 ;get event visit
DO EVSIT
+7 IF '$GET(BDMEVSIT)
SET T="Could not Create PCC Visit when attempting to update smoking health factor."
DO ERR(T)
QUIT
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNVHF("AD",BDMEVSIT,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^AUPNVHF(X,0),U)=BDMEMTYP
SET G=1
+9 IF G
SET T="Already have a health factor of "_$PIECE(^AUTTHF($PIECE(BDMEREC,U,9),0),U)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(BDMEVSIT,0),U))
DO ERR(T)
QUIT
+10 KILL APCDALVR
+11 SET APCDALVR("APCDPAT")=BDMEDMPT
+12 SET APCDALVR("APCDVSIT")=BDMEVSIT
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
+14 SET APCDALVR("APCDTHF")="`"_BDMEMTYP
+15 DO ^APCDALVR
+16 IF $DATA(APCDALVR("APCDAFLG"))
SET T="Error creating V Health Factor Entry for Smoking. PCC not updated."
DO ERR(T)
+17 KILL APCDALVR
+18 ;;update health status
+19 ;S BDMEHSE="",X=0 F S X=$O(^AUPNHF("AC",BDMEDMPT,X)) Q:X'=+X!(BDMEHSE) I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=BDMEMCAT S BDMEHSE=X
+20 ;I BDMEHSE D Q
+21 ;.D ^XBFMK K DIADD
+22 ;.S DA=BDMEHSE,DIE="^AUPNHF(",DR=".01///`"_BDMEMTYP_";.03////"_DT D ^DIE
+23 ;.I $D(Y) S T="Error updating Health Status entry for Tobacco." D ERR(T)
+24 ;.D ^XBFMK
+25 ;D ^XBFMK
+26 ;;S X=BDMEMTYP,DIC("DR")=".02////"_BDMEDMPT_";.03////"_DT,DIC(0)="L",DIADD=1,DLAYGO=9000019,DIC="^AUPNHF(" D FILE^DICN
+27 ;I Y=-1 S T="Error adding health status entry for Tobacco." D ERR(T)
+28 DO ^XBFMK
KILL DIADD,DLAYGO
+29 QUIT
BSD ;
+1 KILL BDMEIN
+2 SET BDMEIN("PAT")=BDMEDMPT
+3 SET BDMEIN("VISIT DATE")=BDMEDMDT_".12"
+4 SET BDMEIN("SITE")=DUZ(2)
+5 SET BDMEIN("VISIT TYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+6 SET BDMEIN("SRV CAT")="E"
+7 SET BDMEIN("TIME RANGE")=0
+8 SET BDMEIN("USR")=DUZ
+9 KILL APCDALVR
+10 KILL BDMEBSDV
+11 DO GETVISIT^APCDAPI4(.BDMEIN,.BDMEBSDV)
+12 SET T=$PIECE(BDMEBSDV(0),U,2)
+13 ;errored
IF T]""
QUIT
+14 SET V=$ORDER(BDMEBSDV(0))
SET BDMEVSIT=V
+15 IF $GET(BDMEBSDV(V))="ADD"
DO DEDT^APCDEA2(BDMEVSIT)
+16 QUIT
EVSIT ;EP - get/create event visit
+1 IF $LENGTH($TEXT(^BSDAPI4))
Begin DoDot:1
+2 DO BSD
End DoDot:1
QUIT
+3 KILL BDMEVSIT
+4 KILL APCDALVR
+5 SET APCDALVR("APCDAUTO")=""
+6 SET APCDALVR("APCDPAT")=BDMEDMPT
+7 SET APCDALVR("APCDCAT")="E"
+8 SET APCDALVR("APCDLOC")=DUZ(2)
+9 SET APCDALVR("APCDTYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+10 SET APCDALVR("APCDDATE")=BDMEDMDT_".12"
+11 DO ^APCDALV
+12 SET BDMEVSIT=$GET(APCDALVR("APCDVSIT"))
+13 IF $GET(APCDALVR("APCDVSIT","NEW"))
DO DEDT^APCDEA2(BDMEVSIT)
+14 KILL APCDALVR
+15 QUIT
CREATE ;create entry in fileman file
+1 SET BDMEDA=""
+2 DO ^XBFMK
+3 SET X=BDMEDMPT
SET DIC(0)="L"
SET DIC("DR")=".02////^S X=DT"
SET DIC="^BDMEDMUP("
SET DIADD=1
SET DLAYGO=9003203.2
KILL DD,DO,D0
DO FILE^DICN
+4 IF Y=-1
SET T="Error creating fileman file entry. Notify programmer"
DO ERR(T)
QUIT
+5 SET BDMEDA=+Y
+6 DO ^XBFMK
KILL DIADD,DLAYGO
+7 QUIT
GETPAT ;
+1 SET BDMEDMPT=""
+2 WRITE !
+3 IF '$PIECE($GET(^BDMESITE(DUZ(2),0)),U,34)
SET AUPNLK("INAC")=1
+4 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+5 IF Y<0
QUIT
+6 IF $DATA(BDMEPARM)
IF $PIECE(BDMEPARM,U,3)="Y"
WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
QUIT
+7 SET BDMEDMPT=+Y
+8 DO INAC^APCDEA(BDMEDMPT,.X)
IF 'X
SET BDMEDMPT=""
QUIT
+9 IF DUZ("AG")="I"
DO ^APCDEMDI
+10 QUIT
+11 ;
VSIT01 ;EP;9000010,.01 (VISIT,VISIT/ADMIT DATE&TIME)
+1 IF '$DATA(AUPNPAT)
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
DO EN^DDIOL(" <No direct entry allowed>")
KILL X
QUIT
+2 IF $EXTRACT(X,6,7)="00"
SET X=$EXTRACT(X,1,5)_"01"
IF $EXTRACT(X,4,5)="00"
SET X=$EXTRACT(X,1,3)_"01"_$EXTRACT(X,6,7)
+3 IF $DATA(AUPNDOB)
IF $DATA(AUPNDOD)
IF AUPNDOB
IF $DATA(DT)
IF DT
DO VSIT01B
QUIT
+4 IF '$DATA(AUPNTALK)
IF '$DATA(ZTQUEUED)
DO EN^DDIOL(" <Required variables do not exist>")
+5 KILL X
+6 QUIT
VSIT01B ;
+1 IF '$DATA(BDMEFVOK)
IF DT_".9999"<X
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
DO EN^DDIOL(" <Future dates not allowed>")
KILL X
QUIT
+2 IF DUZ("AG")="I"
IF AUPNDOD
IF $PIECE(X,".",1)>AUPNDOD
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
DO EN^DDIOL(" <Patient died before this date>")
KILL X
QUIT
+3 IF $PIECE(X,".",1)<AUPNDOB
IF '$DATA(AUPNTALK)&('$DATA(ZTQUEUED))
DO EN^DDIOL(" <Patient born after this date>")
KILL X
QUIT
+4 QUIT
+5 ;
ID ;
+1 IF $EXTRACT(BDMEDMDT,6,7)="00"
SET BDMEDMDT=$EXTRACT(BDMEDMDT,1,5)_"01"
IF $EXTRACT(BDMEDMDT,4,5)="00"
SET BDMEDMDT=$EXTRACT(BDMEDMDT,1,3)_"01"_$EXTRACT(BDMEDMDT,6,7)
+2 QUIT
PROBN ;EP
+1 NEW BDMEPLOC,BDMEPPL,BDMEPN,BDMEPI
+2 SET X=$$UP^XLFSTR(X)
+3 IF X["#"
SET X=$PIECE(X,"#")_$PIECE(X,"#",2)
+4 SET BDMEPPL=""
FOR BDMEPI=1:1:$LENGTH(X)
IF $EXTRACT(X,BDMEPI)?1N
QUIT
SET BDMEPPL=BDMEPPL_$EXTRACT(X,BDMEPI)
+5 IF BDMEPPL=""
DO EN^DDIOL("No facility code has been entered.")
KILL X
QUIT
+6 SET BDMEPLOC=""
SET BDMEPLOC=$ORDER(^AUTTLOC("D",BDMEPPL,BDMEPLOC))
IF BDMEPLOC=""
DO EN^DDIOL("NO Location Abbreviation - PLEASE NOTIFY YOUR SUPERVISOR")
KILL X
QUIT
+7 SET BDMEPN=$PIECE(X,BDMEPPL,2)
IF BDMEPN=""!(BDMEPN<0)!(BDMEPN>999.99)
DO EN^DDIOL("Invalid problem number")
KILL X
QUIT
+8 SET BDMEPN=" "_$EXTRACT("000",1,(3-$LENGTH($PIECE(BDMEPN,"."))))_$PIECE(BDMEPN,".")_"."_$PIECE(BDMEPN,".",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(BDMEPN,".",2))))
+9 IF '$DATA(^AUPNPROB("AA",AUPNPAT,BDMEPLOC,BDMEPN))
DO EN^DDIOL("No Problem Number "_BDMEPN_" on file for this patient for location "_$PIECE(^AUTTLOC(BDMEPLOC,0),U,2)_".")
KILL X
QUIT
+10 QUIT
PROBNUM(X) ;EP - get problem ien given problem number
+1 IF $GET(X)=""
QUIT ""
+2 NEW BDMEPLOC,BDMEPPL,BDMEPN,BDMEPI,P
+3 SET X=$$UP^XLFSTR(X)
+4 IF X["#"
SET X=$PIECE(X,"#")_$PIECE(X,"#",2)
+5 SET BDMEPPL=""
FOR BDMEPI=1:1:$LENGTH(X)
IF $EXTRACT(X,BDMEPI)?1N
QUIT
SET BDMEPPL=BDMEPPL_$EXTRACT(X,BDMEPI)
+6 IF BDMEPPL=""
QUIT ""
+7 SET BDMEPLOC=""
SET BDMEPLOC=$ORDER(^AUTTLOC("D",BDMEPPL,BDMEPLOC))
IF BDMEPLOC=""
QUIT ""
+8 SET BDMEPN=$PIECE(X,BDMEPPL,2)
IF BDMEPN=""!(BDMEPN<0)!(BDMEPN>999.99)
QUIT ""
+9 SET BDMEPN=" "_$EXTRACT("000",1,(3-$LENGTH($PIECE(BDMEPN,"."))))_$PIECE(BDMEPN,".")_"."_$PIECE(BDMEPN,".",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(BDMEPN,".",2))))
+10 SET P=$ORDER(^AUPNPROB("AA",AUPNPAT,BDMEPLOC,BDMEPN,0))
+11 QUIT P
+12 NEW DIC,DA,D,DZ
SET DIC="^AUTTLOC("
SET DIC(0)="E"
SET D="D"
SET DZ="??"
DO DQ^DICQ
KILL Y,DIC,D
+13 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
