APCDDMUP ; IHS/CMI/LAB - EDITS FOR AUPNVSIT (VISIT:9000010) 24-MAY-1993 ;
;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009
;
W:$D(IOF) @IOF
W !,$$CTR("PCC DATA ENTRY",80)
W !!,$$CTR("Diabetes Patient Data Update",80)
W !
S APCDDMPT="" D GETPAT
I APCDDMPT="" 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 APCDDA="" D CREATE
I APCDDA="" W !!,"Exiting..." H 2 D XIT Q
;do screenman
S DA=APCDDA,DDSFILE=9001002.2,DR="[APCD 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(APCDDMER) W !!,"the following errors occurred when updating PCC" D
.S X=0 F S X=$O(APCDDMER(X)) Q:X'=+X W !?5,APCDDMER(X)
.Q
D REF
D XIT
Q
;
UPDPCC ;update pcc
W !!,"Updating PCC database....hold on a moment...",!
D EN(APCDDA,.APCDDMER)
Q
EN(APCDDA,APCDDMER) ;PEP - called from DM GUI
S APCDERR=0
K APCDDMER
S APCDREC=^APCDDMUP(APCDDA,0)
S APCDREC1=$G(^APCDDMUP(APCDDA,11))
;S APCDRE14=$G(^APCDDMUP(APCDDA,14))
I '$G(APCDDMPT) S (AUPNPAT,APCDDMPT)=$P(APCDREC,U) ;cmi/maw added 4/20/2004 for GUI Dms
D PROB
D HT
D WT
D BP^APCDDMU2
D SMOKEHF
D TBHF^APCDDMU2
D SGHF^APCDDMU2
D FOOT^APCDDMU1
D EYE^APCDDMU1
D DEPR^APCDDMU1
D DENTAL^APCDDMU1
D PAP^APCDDMU1
D MAM^APCDDMU1
D FLU^APCDDMU1
D PNEU^APCDDMU1
D TD^APCDDMU1
D PPD^APCDDMU2
D EKG^APCDDMU2
D EDUC^APCDDMU2
D LAB^APCDDMU2
D MED^APCDDMU2
D RTLHF^APCDDMU3
D LPHF^APCDDMU3
D BTLHF^APCDDMU3
DEL S DA=APCDDA,DIK="^APCDDMUP(" 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^APCDDMU3
Q
ERR(T) ;EP
S APCDERR=APCDERR+1,APCDDMER(APCDERR)=T
Q
XIT ;
D KILL^AUPNPAT
K DIADD,DLAYGO
D EN^XBVK("APCD"),EN^XBVK("AUPN")
D ^XBFMK
Q
PROB ;
I $P(APCDREC,U,3)="" Q
I $P(APCDREC,U,4)="" Q
S N=$P(APCDREC,U,4) ;problem number to update
S APCDN=$$PROBNUM(N)
I 'APCDN S T="<<< Could not update Problem Number "_N_" with Date of DM Onset. >>>" D ERR(T) Q
S APCDD=$P(APCDREC,U,3)
D ^XBFMK
S DA=APCDN,DIE="^AUPNPROB(",DR=".13///"_$$FMTE^XLFDT(APCDD) 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 APCDVSIT
I $P(APCDREC,U,5)="" Q
I $P(APCDREC,U,6)="" Q
S APCDDMDT=$P(APCDREC,U,5)
S APCDMTYP=$O(^AUTTMSR("B","HT",0))
D EVSIT ;get event visit
I '$G(APCDVSIT) 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",APCDVSIT,X)) Q:X'=+X!(G) I $P(^AUPNVMSR(X,0),U)=APCDMTYP,$P(^AUPNVMSR(X,0),U,4)=$P(APCDREC,U,6) S G=1
I G S T="Already have a height of "_$P(APCDREC,U,6)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(APCDVSIT,0),U)) D ERR(T) Q
K APCDALVR
S APCDALVR("APCDPAT")=APCDDMPT
S APCDALVR("APCDVSIT")=APCDVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
S APCDALVR("APCDTTYP")="`"_APCDMTYP
S APCDALVR("APCDTVAL")=$P(APCDREC,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 APCDVSIT
I $P(APCDREC,U,7)="" Q
I $P(APCDREC,U,8)="" Q
S APCDDMDT=$P(APCDREC,U,7)
S APCDMTYP=$O(^AUTTMSR("B","WT",0))
D EVSIT ;get event visit
I '$G(APCDVSIT) 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",APCDVSIT,X)) Q:X'=+X!(G) I $P(^AUPNVMSR(X,0),U)=APCDMTYP,$P(^AUPNVMSR(X,0),U,4)=$P(APCDREC,U,8) S G=1
I G S T="Already have a weight of "_$P(APCDREC,U,8)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(APCDVSIT,0),U)) D ERR(T) Q
K APCDALVR
S APCDALVR("APCDPAT")=APCDDMPT
S APCDALVR("APCDVSIT")=APCDVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
S APCDALVR("APCDTTYP")="`"_APCDMTYP
S APCDALVR("APCDTVAL")=$P(APCDREC,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 APCDVSIT
I $P(APCDREC,U,9)="" Q
S APCDDMDT=$S($P(APCDREC1,U,14)]"":$P(APCDREC1,U,14),1:DT)
S APCDMTYP=$P(APCDREC,U,9)
S APCDMCAT=$P(^AUTTHF(APCDMTYP,0),U,3)
D EVSIT ;get event visit
I '$G(APCDVSIT) 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",APCDVSIT,X)) Q:X'=+X!(G) I $P(^AUPNVHF(X,0),U)=APCDMTYP S G=1
I G S T="Already have a health factor of "_$P(^AUTTHF($P(APCDREC,U,9),0),U)_" on Visit Date "_$$FMTE^XLFDT($P(^AUPNVSIT(APCDVSIT,0),U)) D ERR(T) Q
K APCDALVR
S APCDALVR("APCDPAT")=APCDDMPT
S APCDALVR("APCDVSIT")=APCDVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
S APCDALVR("APCDTHF")="`"_APCDMTYP
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 APCDHSE="",X=0 F S X=$O(^AUPNHF("AC",APCDDMPT,X)) Q:X'=+X!(APCDHSE) I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=APCDMCAT S APCDHSE=X
;I APCDHSE D Q
;.D ^XBFMK K DIADD
;.S DA=APCDHSE,DIE="^AUPNHF(",DR=".01///`"_APCDMTYP_";.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=APCDMTYP,DIC("DR")=".02////"_APCDDMPT_";.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 APCDIN
S APCDIN("PAT")=APCDDMPT
S APCDIN("VISIT DATE")=APCDDMDT_".12"
S APCDIN("SITE")=DUZ(2)
S APCDIN("VISIT TYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
S APCDIN("SRV CAT")="E"
S APCDIN("TIME RANGE")=0
S APCDIN("USR")=DUZ
K APCDALVR
K APCDBSDV
D GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
S T=$P(APCDBSDV(0),U,2)
I T]"" Q ;errored
S V=$O(APCDBSDV(0)) S APCDVSIT=V
I $G(APCDBSDV(V))="ADD" D DEDT^APCDEA2(APCDVSIT)
Q
EVSIT ;EP - get/create event visit
I $L($T(^BSDAPI4)) D Q
.D BSD
K APCDVSIT
K APCDALVR
S APCDALVR("APCDAUTO")=""
S APCDALVR("APCDPAT")=APCDDMPT
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")=APCDDMDT_".12"
D ^APCDALV
S APCDVSIT=$G(APCDALVR("APCDVSIT"))
I $G(APCDALVR("APCDVSIT","NEW")) D DEDT^APCDEA2(APCDVSIT)
K APCDALVR
Q
CREATE ;create entry in fileman file
S APCDDA=""
D ^XBFMK
S X=APCDDMPT,DIC(0)="L",DIC("DR")=".02////^S X=DT",DIC="^APCDDMUP(",DIADD=1,DLAYGO=9001002.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 APCDDA=+Y
D ^XBFMK K DIADD,DLAYGO
Q
GETPAT ;
S APCDDMPT=""
W !
I '$P($G(^APCDSITE(DUZ(2),0)),U,34) S AUPNLK("INAC")=1
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
I $D(APCDPARM),$P(APCDPARM,U,3)="Y" W !?25,"Ok" S %=1 D YN^DICN Q:%'=1
S APCDDMPT=+Y
D INAC^APCDEA(APCDDMPT,.X) I 'X S APCDDMPT="" 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(APCDFVOK),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(APCDDMDT,6,7)="00" APCDDMDT=$E(APCDDMDT,1,5)_"01" S:$E(APCDDMDT,4,5)="00" APCDDMDT=$E(APCDDMDT,1,3)_"01"_$E(APCDDMDT,6,7)
Q
PROBN ;EP
NEW APCDPLOC,APCDPPL,APCDPN,APCDPI
S X=$$UP^XLFSTR(X)
S:X["#" X=$P(X,"#")_$P(X,"#",2)
S APCDPPL="" F APCDPI=1:1:$L(X) Q:$E(X,APCDPI)?1N S APCDPPL=APCDPPL_$E(X,APCDPI)
I APCDPPL="" D EN^DDIOL("No facility code has been entered.") K X Q
S APCDPLOC="",APCDPLOC=$O(^AUTTLOC("D",APCDPPL,APCDPLOC)) I APCDPLOC="" D EN^DDIOL("NO Location Abbreviation - PLEASE NOTIFY YOUR SUPERVISOR") K X Q
S APCDPN=$P(X,APCDPPL,2) I APCDPN=""!(APCDPN<0)!(APCDPN>999.99) D EN^DDIOL("Invalid problem number") K X Q
S APCDPN=" "_$E("000",1,(3-$L($P(APCDPN,"."))))_$P(APCDPN,".")_"."_$P(APCDPN,".",2)_$E("00",1,(2-$L($P(APCDPN,".",2))))
I '$D(^AUPNPROB("AA",AUPNPAT,APCDPLOC,APCDPN)) D EN^DDIOL("No Problem Number "_APCDPN_" on file for this patient for location "_$P(^AUTTLOC(APCDPLOC,0),U,2)_".") K X Q
Q
PROBNUM(X) ;EP - get problem ien given problem number
I $G(X)="" Q ""
NEW APCDPLOC,APCDPPL,APCDPN,APCDPI,P
S X=$$UP^XLFSTR(X)
S:X["#" X=$P(X,"#")_$P(X,"#",2)
S APCDPPL="" F APCDPI=1:1:$L(X) Q:$E(X,APCDPI)?1N S APCDPPL=APCDPPL_$E(X,APCDPI)
I APCDPPL="" Q ""
S APCDPLOC="",APCDPLOC=$O(^AUTTLOC("D",APCDPPL,APCDPLOC)) I APCDPLOC="" Q ""
S APCDPN=$P(X,APCDPPL,2) I APCDPN=""!(APCDPN<0)!(APCDPN>999.99) Q ""
S APCDPN=" "_$E("000",1,(3-$L($P(APCDPN,"."))))_$P(APCDPN,".")_"."_$P(APCDPN,".",2)_$E("00",1,(2-$L($P(APCDPN,".",2))))
S P=$O(^AUPNPROB("AA",AUPNPAT,APCDPLOC,APCDPN,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
;----------
APCDDMUP ; IHS/CMI/LAB - EDITS FOR AUPNVSIT (VISIT:9000010) 24-MAY-1993 ;
+1 ;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009
+2 ;
+3 IF $DATA(IOF)
WRITE @IOF
+4 WRITE !,$$CTR("PCC DATA ENTRY",80)
+5 WRITE !!,$$CTR("Diabetes Patient Data Update",80)
+6 WRITE !
+7 SET APCDDMPT=""
DO GETPAT
+8 IF APCDDMPT=""
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 APCDDA=""
DO CREATE
+22 IF APCDDA=""
WRITE !!,"Exiting..."
HANG 2
DO XIT
QUIT
+23 ;do screenman
+24 SET DA=APCDDA
SET DDSFILE=9001002.2
SET DR="[APCD 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(APCDDMER)
WRITE !!,"the following errors occurred when updating PCC"
Begin DoDot:1
+28 SET X=0
FOR
SET X=$ORDER(APCDDMER(X))
IF X'=+X
QUIT
WRITE !?5,APCDDMER(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(APCDDA,.APCDDMER)
+3 QUIT
EN(APCDDA,APCDDMER) ;PEP - called from DM GUI
+1 SET APCDERR=0
+2 KILL APCDDMER
+3 SET APCDREC=^APCDDMUP(APCDDA,0)
+4 SET APCDREC1=$GET(^APCDDMUP(APCDDA,11))
+5 ;S APCDRE14=$G(^APCDDMUP(APCDDA,14))
+6 ;cmi/maw added 4/20/2004 for GUI Dms
IF '$GET(APCDDMPT)
SET (AUPNPAT,APCDDMPT)=$PIECE(APCDREC,U)
+7 DO PROB
+8 DO HT
+9 DO WT
+10 DO BP^APCDDMU2
+11 DO SMOKEHF
+12 DO TBHF^APCDDMU2
+13 DO SGHF^APCDDMU2
+14 DO FOOT^APCDDMU1
+15 DO EYE^APCDDMU1
+16 DO DEPR^APCDDMU1
+17 DO DENTAL^APCDDMU1
+18 DO PAP^APCDDMU1
+19 DO MAM^APCDDMU1
+20 DO FLU^APCDDMU1
+21 DO PNEU^APCDDMU1
+22 DO TD^APCDDMU1
+23 DO PPD^APCDDMU2
+24 DO EKG^APCDDMU2
+25 DO EDUC^APCDDMU2
+26 DO LAB^APCDDMU2
+27 DO MED^APCDDMU2
+28 DO RTLHF^APCDDMU3
+29 DO LPHF^APCDDMU3
+30 DO BTLHF^APCDDMU3
DEL SET DA=APCDDA
SET DIK="^APCDDMUP("
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^APCDDMU3
+5 QUIT
ERR(T) ;EP
+1 SET APCDERR=APCDERR+1
SET APCDDMER(APCDERR)=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(APCDREC,U,3)=""
QUIT
+2 IF $PIECE(APCDREC,U,4)=""
QUIT
+3 ;problem number to update
SET N=$PIECE(APCDREC,U,4)
+4 SET APCDN=$$PROBNUM(N)
+5 IF 'APCDN
SET T="<<< Could not update Problem Number "_N_" with Date of DM Onset. >>>"
DO ERR(T)
QUIT
+6 SET APCDD=$PIECE(APCDREC,U,3)
+7 DO ^XBFMK
+8 SET DA=APCDN
SET DIE="^AUPNPROB("
SET DR=".13///"_$$FMTE^XLFDT(APCDD)
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 APCDVSIT
+2 IF $PIECE(APCDREC,U,5)=""
QUIT
+3 IF $PIECE(APCDREC,U,6)=""
QUIT
+4 SET APCDDMDT=$PIECE(APCDREC,U,5)
+5 SET APCDMTYP=$ORDER(^AUTTMSR("B","HT",0))
+6 ;get event visit
DO EVSIT
+7 IF '$GET(APCDVSIT)
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",APCDVSIT,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^AUPNVMSR(X,0),U)=APCDMTYP
IF $PIECE(^AUPNVMSR(X,0),U,4)=$PIECE(APCDREC,U,6)
SET G=1
+9 IF G
SET T="Already have a height of "_$PIECE(APCDREC,U,6)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(APCDVSIT,0),U))
DO ERR(T)
QUIT
+10 KILL APCDALVR
+11 SET APCDALVR("APCDPAT")=APCDDMPT
+12 SET APCDALVR("APCDVSIT")=APCDVSIT
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+14 SET APCDALVR("APCDTTYP")="`"_APCDMTYP
+15 SET APCDALVR("APCDTVAL")=$PIECE(APCDREC,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 APCDVSIT
+2 IF $PIECE(APCDREC,U,7)=""
QUIT
+3 IF $PIECE(APCDREC,U,8)=""
QUIT
+4 SET APCDDMDT=$PIECE(APCDREC,U,7)
+5 SET APCDMTYP=$ORDER(^AUTTMSR("B","WT",0))
+6 ;get event visit
DO EVSIT
+7 IF '$GET(APCDVSIT)
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",APCDVSIT,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^AUPNVMSR(X,0),U)=APCDMTYP
IF $PIECE(^AUPNVMSR(X,0),U,4)=$PIECE(APCDREC,U,8)
SET G=1
+9 IF G
SET T="Already have a weight of "_$PIECE(APCDREC,U,8)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(APCDVSIT,0),U))
DO ERR(T)
QUIT
+10 KILL APCDALVR
+11 SET APCDALVR("APCDPAT")=APCDDMPT
+12 SET APCDALVR("APCDVSIT")=APCDVSIT
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+14 SET APCDALVR("APCDTTYP")="`"_APCDMTYP
+15 SET APCDALVR("APCDTVAL")=$PIECE(APCDREC,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 APCDVSIT
+2 IF $PIECE(APCDREC,U,9)=""
QUIT
+3 SET APCDDMDT=$SELECT($PIECE(APCDREC1,U,14)]"":$PIECE(APCDREC1,U,14),1:DT)
+4 SET APCDMTYP=$PIECE(APCDREC,U,9)
+5 SET APCDMCAT=$PIECE(^AUTTHF(APCDMTYP,0),U,3)
+6 ;get event visit
DO EVSIT
+7 IF '$GET(APCDVSIT)
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",APCDVSIT,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^AUPNVHF(X,0),U)=APCDMTYP
SET G=1
+9 IF G
SET T="Already have a health factor of "_$PIECE(^AUTTHF($PIECE(APCDREC,U,9),0),U)_" on Visit Date "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(APCDVSIT,0),U))
DO ERR(T)
QUIT
+10 KILL APCDALVR
+11 SET APCDALVR("APCDPAT")=APCDDMPT
+12 SET APCDALVR("APCDVSIT")=APCDVSIT
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
+14 SET APCDALVR("APCDTHF")="`"_APCDMTYP
+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 APCDHSE="",X=0 F S X=$O(^AUPNHF("AC",APCDDMPT,X)) Q:X'=+X!(APCDHSE) I $P(^AUTTHF($P(^AUPNHF(X,0),U),0),U,3)=APCDMCAT S APCDHSE=X
+20 ;I APCDHSE D Q
+21 ;.D ^XBFMK K DIADD
+22 ;.S DA=APCDHSE,DIE="^AUPNHF(",DR=".01///`"_APCDMTYP_";.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=APCDMTYP,DIC("DR")=".02////"_APCDDMPT_";.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 APCDIN
+2 SET APCDIN("PAT")=APCDDMPT
+3 SET APCDIN("VISIT DATE")=APCDDMDT_".12"
+4 SET APCDIN("SITE")=DUZ(2)
+5 SET APCDIN("VISIT TYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+6 SET APCDIN("SRV CAT")="E"
+7 SET APCDIN("TIME RANGE")=0
+8 SET APCDIN("USR")=DUZ
+9 KILL APCDALVR
+10 KILL APCDBSDV
+11 DO GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
+12 SET T=$PIECE(APCDBSDV(0),U,2)
+13 ;errored
IF T]""
QUIT
+14 SET V=$ORDER(APCDBSDV(0))
SET APCDVSIT=V
+15 IF $GET(APCDBSDV(V))="ADD"
DO DEDT^APCDEA2(APCDVSIT)
+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 APCDVSIT
+4 KILL APCDALVR
+5 SET APCDALVR("APCDAUTO")=""
+6 SET APCDALVR("APCDPAT")=APCDDMPT
+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")=APCDDMDT_".12"
+11 DO ^APCDALV
+12 SET APCDVSIT=$GET(APCDALVR("APCDVSIT"))
+13 IF $GET(APCDALVR("APCDVSIT","NEW"))
DO DEDT^APCDEA2(APCDVSIT)
+14 KILL APCDALVR
+15 QUIT
CREATE ;create entry in fileman file
+1 SET APCDDA=""
+2 DO ^XBFMK
+3 SET X=APCDDMPT
SET DIC(0)="L"
SET DIC("DR")=".02////^S X=DT"
SET DIC="^APCDDMUP("
SET DIADD=1
SET DLAYGO=9001002.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 APCDDA=+Y
+6 DO ^XBFMK
KILL DIADD,DLAYGO
+7 QUIT
GETPAT ;
+1 SET APCDDMPT=""
+2 WRITE !
+3 IF '$PIECE($GET(^APCDSITE(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(APCDPARM)
IF $PIECE(APCDPARM,U,3)="Y"
WRITE !?25,"Ok"
SET %=1
DO YN^DICN
IF %'=1
QUIT
+7 SET APCDDMPT=+Y
+8 DO INAC^APCDEA(APCDDMPT,.X)
IF 'X
SET APCDDMPT=""
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(APCDFVOK)
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(APCDDMDT,6,7)="00"
SET APCDDMDT=$EXTRACT(APCDDMDT,1,5)_"01"
IF $EXTRACT(APCDDMDT,4,5)="00"
SET APCDDMDT=$EXTRACT(APCDDMDT,1,3)_"01"_$EXTRACT(APCDDMDT,6,7)
+2 QUIT
PROBN ;EP
+1 NEW APCDPLOC,APCDPPL,APCDPN,APCDPI
+2 SET X=$$UP^XLFSTR(X)
+3 IF X["#"
SET X=$PIECE(X,"#")_$PIECE(X,"#",2)
+4 SET APCDPPL=""
FOR APCDPI=1:1:$LENGTH(X)
IF $EXTRACT(X,APCDPI)?1N
QUIT
SET APCDPPL=APCDPPL_$EXTRACT(X,APCDPI)
+5 IF APCDPPL=""
DO EN^DDIOL("No facility code has been entered.")
KILL X
QUIT
+6 SET APCDPLOC=""
SET APCDPLOC=$ORDER(^AUTTLOC("D",APCDPPL,APCDPLOC))
IF APCDPLOC=""
DO EN^DDIOL("NO Location Abbreviation - PLEASE NOTIFY YOUR SUPERVISOR")
KILL X
QUIT
+7 SET APCDPN=$PIECE(X,APCDPPL,2)
IF APCDPN=""!(APCDPN<0)!(APCDPN>999.99)
DO EN^DDIOL("Invalid problem number")
KILL X
QUIT
+8 SET APCDPN=" "_$EXTRACT("000",1,(3-$LENGTH($PIECE(APCDPN,"."))))_$PIECE(APCDPN,".")_"."_$PIECE(APCDPN,".",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(APCDPN,".",2))))
+9 IF '$DATA(^AUPNPROB("AA",AUPNPAT,APCDPLOC,APCDPN))
DO EN^DDIOL("No Problem Number "_APCDPN_" on file for this patient for location "_$PIECE(^AUTTLOC(APCDPLOC,0),U,2)_".")
KILL X
QUIT
+10 QUIT
PROBNUM(X) ;EP - get problem ien given problem number
+1 IF $GET(X)=""
QUIT ""
+2 NEW APCDPLOC,APCDPPL,APCDPN,APCDPI,P
+3 SET X=$$UP^XLFSTR(X)
+4 IF X["#"
SET X=$PIECE(X,"#")_$PIECE(X,"#",2)
+5 SET APCDPPL=""
FOR APCDPI=1:1:$LENGTH(X)
IF $EXTRACT(X,APCDPI)?1N
QUIT
SET APCDPPL=APCDPPL_$EXTRACT(X,APCDPI)
+6 IF APCDPPL=""
QUIT ""
+7 SET APCDPLOC=""
SET APCDPLOC=$ORDER(^AUTTLOC("D",APCDPPL,APCDPLOC))
IF APCDPLOC=""
QUIT ""
+8 SET APCDPN=$PIECE(X,APCDPPL,2)
IF APCDPN=""!(APCDPN<0)!(APCDPN>999.99)
QUIT ""
+9 SET APCDPN=" "_$EXTRACT("000",1,(3-$LENGTH($PIECE(APCDPN,"."))))_$PIECE(APCDPN,".")_"."_$PIECE(APCDPN,".",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(APCDPN,".",2))))
+10 SET P=$ORDER(^AUPNPROB("AA",AUPNPAT,APCDPLOC,APCDPN,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 ;----------
