APCDAPRB ; IHS/CMI/LAB - PROMPT FOR PROBLEM ;
;;2.0;IHS PCC SUITE;**5,6,10,11,16,17**;MAY 14, 2009;Build 18
;
START ;EP
X:$D(^DD(9000011,.01,12.1)) ^DD(9000011,.01,12.1) S DIC="^ICD9(",DIC(0)="AEMQ",DIC("A")="Enter Problem Diagnosis: " D ^DIC K DIC
G:Y="" XIT
I Y=-1,X=""!(X="^") S APCDTSKI=1,APCDLOOK="" G XIT
I Y=-1 S APCDTERR=1,APCDLOOK="" G XIT
S APCDLOOK="`"_+Y,APCDTNQP=X
XIT K Y,X,DO,D,DD,DIPGM
Q
PL ;EP
I $G(APCDDATE)="" S APCDDATE=DT
I $G(APCDLOC)="" S APCDLOC=DUZ(2)
S DFN=APCDPAT,Y=APCDPAT D ^AUPNPAT K Y
S APCDPLL=APCDLOC,APCDPLD=$P(APCDDATE,".")
S APCDPLV=$G(APCDVSIT)
I APCDPLV<0 S APCDPLV=""
D EN^XBNEW("PL1^APCDAPRB","DFN;APCDPLL;APCDPLD;APCDPLV;VALM*")
Q
PL1 ;EP
D TERM^VALM0
D ENDE^APCDPL
Q
PO ;EP
S DIE="^AUPNPAT(",DR="[APCD PO (ADD)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
MPO ;EP
S DIE="^AUPNPAT(",DR="[APCD MPO (MPO)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
RPO ;EP
S DIE="^AUPNPAT(",DR="[APCD RPO (RPO)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
IPO ;EP
S DIE="^AUPNPAT(",DR="[APCD IPO (IPO)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
APO ;EP
S DIE="^AUPNPAT(",DR="[APCD APO (APO)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
MNN ;EP
S DIE="^AUPNPAT(",DR="[APCD MNN (MNN)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
RNO ;EP
S DIE="^AUPNPAT(",DR="[APCD RNO (RNO)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
PDSP ;EP
S DIE="^AUPNPAT(",DR="[APCD PDSP (PDSP)]",DA=APCDPAT D ^DIE K DA,DR,DIE
Q
NON ;EP called from APCD NO (ADD) template
D ^XBNEW("NO^APCDAPRB:APCD*")
Q
NOP ;EP called from APCD PO (ADD) template
NEW APCDADDP
S APCDADDP=1
D ^XBNEW("NO1^APCDAPRB:APCD*")
Q
NO ;EP add a note to a problem
D ^APCDPROB
K DIR,DIRUT S DIR(0)="F^1:12",DIR("A")="Enter Problem Number" K DA D ^DIR K DIR
G:$D(DIRUT) NOX
S APCDPR=Y
D ^APCDPLK
I APCDPERR=1 W $C(7),$C(7),"Not a valid problem number.",! K APCDPERR G NO
;display existing notes, get next note number
NO1 ;EP
S APCDPROB=APCDPDFN
I APCDPROB["`" S APCDPROB=$P(APCDPROB,"`",2)
I $G(APCDPR)]"" W !!,"Problem Number: ",APCDPR,?40,"Diagnosis: ",$P($$ICDDX^ICDEX($P(^AUPNPROB(APCDPROB,0),U)),U,2)
I $O(^AUPNPROB(APCDPROB,11,0)) D
.W !,"Problem Notes: " S L=0 F S L=$O(^AUPNPROB(APCDPROB,11,L)) Q:L'=+L I $O(^AUPNPROB(APCDPROB,11,L,11,0)) W !?5,$P(^DIC(4,$P(^AUPNPROB(APCDPROB,11,L,0),U),0),U) D
..S X=0 F S X=$O(^AUPNPROB(APCDPROB,11,L,11,X)) Q:X'=+X W !?10,"Note#",$P(^AUPNPROB(APCDPROB,11,L,11,X,0),U)," ",$$FMTE^XLFDT($P(^(0),U,5),5),?28,$P(^AUPNPROB(APCDPROB,11,L,11,X,0),U,3)
W ! S DIR(0)="Y",DIR("A")="Add a new Problem Note for this Problem",DIR("B")="N" K DA D ^DIR K DIR
G:$D(DIRUT) NOX
G:Y=0 NOX
;get next note number
NUM ;
;add location multiple if necessary, otherwise get ien in multiple
S APCDNIEN=$O(^AUPNPROB(APCDPROB,11,"B",APCDLOC,0))
I APCDNIEN="" S X="`"_APCDLOC,DIC="^AUPNPROB("_APCDPROB_",11,",DA(1)=APCDPROB,DIC(0)="L",DIC("P")=$P(^DD(9000011,1101,0),U,2) D ^DIC K DIC,DA,DR,Y,X S APCDNIEN=$O(^AUPNPROB(APCDPROB,11,"B",APCDLOC,0))
I APCDNIEN="" W $C(7),$C(7),"ERROR UPDATING NOTE LOCATION MULTIPLE" G NOX
S (Y,X)=0 F S Y=$O(^AUPNPROB(APCDPROB,11,APCDNIEN,11,"B",Y)) S:Y X=Y I 'Y S X=X+1 K Y Q
S APCDNUM=X
W !!,"Adding ",$P(^DIC(4,APCDLOC,0),U)," Note #",X
K DIC S X=APCDNUM,DA(1)=APCDNIEN,DA(2)=APCDPROB,DIC="^AUPNPROB("_APCDPROB_",11,"_APCDNIEN_",11,",DIC("P")=$P(^DD(9000011.11,1101,0),U,2),DIC(0)="L" D ^DIC K DA,DR
I Y=-1 W !!,$C(7),$C(7),"ERROR when updating note number multiple",! G NOX
S DIE=DIC K DIC W ?10 S %=$S($G(APCDDATE):$P(APCDDATE,"."),1:DT),DA=+Y,DR=".03;.04////A;;.09////^S X=DUZ;.05///^S X=%" D ^DIE K DIE,DR,DA,Y W !!
S DIE="^AUPNPROB(",DA=APCDPROB,%=$S($G(APCDDATE):$P(APCDDATE,"."),1:DT),DR=".03////"_%_";.14////"_DUZ D ^DIE K DIE,DA,DR,Y
S DA=APCDPROB
I '$G(APCDADDP) D PLUDE
G NO1
Q
NOX ;
K Y,APCDPROB,X,L,APCDNUM,APCDNIEN,DIC,DA,DD
Q
PLUDE ;EP - called from data entry input templates
;get provider who updated and date
;NEW APCDPRBI
S APCDTPRD=$G(APCDTPRD)
S APCDPRBI=DA
S APCDP=$G(APCDPAT)
I 'APCDP S APCDP=$G(DFN)
S APCDV=$G(APCDVSIT)
I APCDV<0 S APCDV=""
S APCDD=$G(APCDDATE)
;
D EN^XBNEW("PLUDE1^APCDAPRB","APCDP;APCDV;APCDD;APCDPRBI;APCDTPRD")
Q
QUALP ;EP - called from input templates
NEW APCDADDP
S APCDADDP=1
D ^XBNEW("QUAL1^APCDAPRB:APCD*")
Q
QUAL ;EP add a note to a problem
D ^APCDPROB
K DIR,DIRUT S DIR(0)="F^1:12",DIR("A")="Enter Problem Number" K DA D ^DIR K DIR
G:$D(DIRUT) NOX
S APCDPR=Y
D ^APCDPLK
I APCDPERR=1 W $C(7),$C(7),"Not a valid problem number.",! K APCDPERR G NO
;display existing notes, get next note number
QUAL1 ;EP
S APCDPROB=APCDPDFN
I APCDPROB["`" S APCDPROB=$P(APCDPROB,"`",2)
QUAL2 W !!?3,"Severity:"
I '$O(^AUPNPROB(APCDPROB,13,0)) S APCDC=0 W " None recorded" G FM12
D EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?3")
K APCDCM S X=0,APCDC=0 F S X=$O(^AUPNPROB(APCDPROB,13,X)) Q:X'=+X D
.S APCDC=APCDC+1,APCDCM(APCDC)=X
.W !?2,APCDC,") ",$$GET1^DIQ(9000011.13,X_","_APCDPROB,.01)
FM12 ;
D EN^DDIOL("","","!!")
K DIR
S DIR(0)="S^A:Add a Severity"_$S(APCDC:";E:Edit an Existing Severity;D:Delete an Existing Severity",1:"")_";N:No Change"
S DIR("A")="Which action",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G FM13
I Y="N" S APCDDONE=1 G FM13
S Y="FM"_Y
D @Y
G QUAL2
FM13 ;
K Y
Q
;
FME ;
D EN^DDIOL("","","!")
K DIR
S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Edit Which One" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
K DIC,DA,DR
I $P(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)]"",$P(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)'=DUZ D Q
.W !!,"You did not enter that Severity, therefore you cannot edit it. It was entered by:",!,$P(^VA(200,$P(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2),0),U,1),! Q
S DA=APCDCM(Y),DR=".01",DA(1)=APCDPROB
S DIE="^AUPNPROB("_APCDPROB_",13,"
D ^DIE
K DIE
Q
FMD ;
D EN^DDIOL("","","!")
K DIR
S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Delete Which One" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I $P(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)]"",$P(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)'=DUZ D Q
.W !!,"You did not enter that qualifier, therefore you cannot delete it. It was entered by:",!,$P(^VA(200,$P(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2),0),U,1),! Q
K DIC,DA,DR
S DA=APCDCM(Y),DA(1)=APCDPROB,DIK="^AUPNPROB("_APCDPROB_",13," D ^DIK K DA,DIK
Q
FMA ;
S DIR(0)="FO^1:30",DIR("A")="Enter Qualifier" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I Y="" Q
S DIC(0)="L",DIC="^AUPNPROB("_APCDPROB_",13,",DIC("DR")=".02////"_DUZ_";.03///^S X=$$NOW^XLFDT;.04////"_DUZ_";.05///^S X=$$NOW^XLFDT",DA(1)=APCDPROB
D FILE^DICN
Q
;
PLUDE1 ;EP - called from xbnew
;get date pl updated
S DIR(0)="D^::EPTSX",DIR("A")="Enter the Date the Problem List was Updated by the Provider"
S DIR("B")=$S($G(APCDD):$$FMTE^XLFDT($P(APCDD,".")),$G(APCDV):$$FMTE^XLFDT($$VD^APCLV(APCDV)),1:$$FMTE^XLFDT(DT)),DIR("?")="This is the visit date or the date the provider updated the problem list."
KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G PLUDE1
I $P(Y,".")>DT W !!,"Future Dates now allowed.",! G PLUDE1
S APCDD=Y
PLUDE1P ;GET PROVIDER
S DIR(0)="9000010.54,1204",DIR("A")="Enter the INDIVIDUAL who Updated the Problem List"
S DIR("A",1)="Enter the individual that updated the problem list. "
S DIR("A",2)="If you are transcribing an update from a PCC Provider, then enter"
S DIR("A",3)="the individual who requested the change. If you are data "
S DIR("A",4)="entry/coder correcting the problem entry such as correcting the "
S DIR("A",5)="ICD9 code, then enter yourself."
S DIR("B")=$S($G(APCDTPRD):$P(^VA(200,APCDTPRD,0),U,1),$G(APCDV):$$PRIMPROV^APCLV(APCDV,"N"),1:"") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G PLUDE1P
S APCDPRV=+Y
D PLU($G(APCDPRBI),APCDV,APCDP,APCDD,APCDPRV,.APCDRET)
I $P(APCDRET,U,1)=0 W !!,"error: ",$P(APCDRET,U,2)
Q
PLU(APCDPIEN,APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update Problem list update fields
;this API can be called to have a V UPDATED/REVIEWED entry and populate the
;.11, .12, and .13 fields
;input: APCDPIEN - ien of problem list entry
; APCDV - ien of visit, if in the context of a visit
; APCDP - DFN
; APCDD - Date and optionally time of problem list update (fileman format)
; APCDPRV = ien of provider updating the problem list
;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
;for Provider APCDP on date APCDD
;if not in the context of a visit (APCDV = null) then an event visit will be created
;with a V UPDATED/REVIEWED v file entry
;
;RETURN VALUE:
; ien of V UPDATED/REVIEWED entry that was created
; or 0^error message
S APCDPIEN=$G(APCDPIEN)
S APCDV=$G(APCDV)
S APCDP=$G(APCDP)
I 'APCDP S RETVAL="0^not a valid patient DFN" Q
I '$D(^AUPNPAT(APCDP,0)) S RETVAL="0^not a valid patient DFN" Q
S APCDD=$G(APCDD)
I 'APCDD S RETVAL="0^no valid date passed" Q
S APCDPRV=$G(APCDPRV)
I 'APCDPRV S RETVAL="0^no valid provider ien passed" Q
S RETVAL=""
;
I APCDV D PLUV Q
;NO VISIT SO CREATE EVENT VISIT AND CALL PLUV
D EVSIT
Q
PLUV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
;not exist on this visit already.
NEW APCDX,APCDVD,APCDVRI,APCDVAL
S APCDVAL=$O(^AUTTCRA("C","PLU",0))
I APCDVAL="" S RETVAL="0^action item missing" Q
S APCDVRI=""
S APCDX=0 F S APCDX=$O(^AUPNVRUP("AD",APCDV,APCDX)) Q:APCDX=""!(APCDVRI) D
.;is this entry a problem list review entry?
.Q:$P(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL ;this one isn't a PLU entry
.Q:$P($G(^AUPNVRUP(APCDX,2)),U,1)
.Q:$P($G(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV ;not this provider
.S APCDVRI=APCDX ;found one so don't create one
.Q
I APCDVRI S RETVAL=APCDVRI Q
;create V UPDATED/REVIEWED entry
NEW APCDALVR
S APCDALVR("APCDPAT")=APCDP
S APCDALVR("APCDVSIT")=APCDV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
S APCDALVR("APCDTCLA")="`"_APCDVAL
S APCDALVR("APCDTCDT")=APCDD
S APCDALVR("APCDTEPR")="`"_APCDPRV
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
K APCDALVR
Q
BSD ;
NEW APCDBSDV
K APCDIN
S APCDIN("PAT")=APCDP
S APCDIN("VISIT DATE")=APCDD_".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]"" S RETVAL="0^could not create event visit" Q ;errored
S V=$O(APCDBSDV(0)) S APCDV=V
I $G(APCDBSDV(V))="ADD" D DEDT^APCDEA2(APCDV)
Q
EVSIT ;EP - get/create event visit
I $L($T(^BSDAPI4)) D Q
.D BSD
.D PLUV
K APCDVSIT
K APCDALVR
S APCDALVR("APCDAUTO")=""
S APCDALVR("APCDPAT")=APCDP
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")=APCDD_".12"
D ^APCDALV
S APCDV=$G(APCDALVR("APCDVSIT"))
I $G(APCDALVR("APCDVSIT","NEW")) D DEDT^APCDEA2(APCDVSIT)
K APCDALVR
D PLUV
Q
ANYACTP(P,EDATE) ;EP - does this patient have any active problems?
I '$G(P) Q 0
S EDATE=$G(EDATE)
NEW X,Y,Z
S Z=0
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(Z) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I EDATE,$P(^AUPNPROB(X,0),U,8)>EDATE Q
.S Z=1
.Q
Q Z
PLR(APCDTDA) ;EP - called from nap template to create PLR entry
D EN^XBNEW("PLR1^APCDAPRB","APCDTDA")
Q
PLR1 ;
;create PLR entry on this visit
;create V UPDATED/REVIEWED entry
NEW APCDALVR,APCDVAL
S APCDVAL=$O(^AUTTCRA("C","PLR",0))
S APCDALVR("APCDPAT")=$P(^AUPNVRUP(APCDTDA,0),U,2)
S APCDALVR("APCDVSIT")=$P(^AUPNVRUP(APCDTDA,0),U,3)
S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
S APCDALVR("APCDTCLA")="`"_APCDVAL
S APCDALVR("APCDTCDT")=$P($G(^AUPNVRUP(APCDTDA,12)),U,1)
I $P($G(^AUPNVRUP(APCDTDA,12)),U,4) S APCDALVR("APCDTEPR")="`"_$P(^AUPNVRUP(APCDTDA,12),U,4)
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
K APCDALVR
Q
CPS ;EP - CALLED FROM INPUT TEMPLATE APCD CPS TO UPDATE PROBLEM STATUS
NEW APCDADFN
S APCDADFN=DA
D EN^XBNEW("CPS1^APCDAPRB","APCDADFN")
K APCDADFN
Q
CPS1 ;EP
;CALL READER TO GET VALUE
S DIR(0)="SBA^A:CHRONIC;I:INACTIVE;S:SUB-ACUTE;E:EPISODIC;O:SOCIAL;R:ROUTINE/ADMIN"
S DIR("A")=" STATUS: ",DIR("B")=$$VAL^XBDIQ1(9000011,APCDADFN,.12) KILL DA D ^DIR KILL DIR
S DIR("?")="NOTE: You cannot delete a problem with this mnemonic, use RPO to delete a problem."
KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S DIE="^AUPNPROB(",DA=APCDADFN,DR=".12///"_Y
D ^DIE
K DA,DIE,DR
Q
CPSA ;EP - CALLED FROM INPUT TEMPLATE APCD CPS TO UPDATE PROBLEM STATUS
NEW APCDADFN
S APCDADFN=DA
D EN^XBNEW("CPSA1^APCDAPRB","APCDADFN")
K APCDADFN
Q
CPSA1 ;EP
;CALL READER TO GET VALUE
S DIR(0)="SBA^A:CHRONIC;I:INACTIVE;S:SUB-ACUTE;E:EPISODIC;O:SOCIAL;R:ROUTINE/ADMIN"
S DIR("?")="This is the current activity status of this problem. If more detail, is needed, a notation may be filed with this problem"
S DIR("A")=" STATUS: ",DIR("B")="CHRONIC" KILL DA D ^DIR KILL DIR
KILL DA D ^DIR KILL DIR
I $D(DIRUT) W "^ not allowed" G CPSA1
I Y="" W " Required" G CPSA1
S DIE="^AUPNPROB(",DA=APCDADFN,DR=".12///"_Y
D ^DIE
K DA,DIE,DR
Q
APCDAPRB ; IHS/CMI/LAB - PROMPT FOR PROBLEM ;
+1 ;;2.0;IHS PCC SUITE;**5,6,10,11,16,17**;MAY 14, 2009;Build 18
+2 ;
START ;EP
+1 IF $DATA(^DD(9000011,.01,12.1))
XECUTE ^DD(9000011,.01,12.1)
SET DIC="^ICD9("
SET DIC(0)="AEMQ"
SET DIC("A")="Enter Problem Diagnosis: "
DO ^DIC
KILL DIC
+2 IF Y=""
GOTO XIT
+3 IF Y=-1
IF X=""!(X="^")
SET APCDTSKI=1
SET APCDLOOK=""
GOTO XIT
+4 IF Y=-1
SET APCDTERR=1
SET APCDLOOK=""
GOTO XIT
+5 SET APCDLOOK="`"_+Y
SET APCDTNQP=X
XIT KILL Y,X,DO,D,DD,DIPGM
+1 QUIT
PL ;EP
+1 IF $GET(APCDDATE)=""
SET APCDDATE=DT
+2 IF $GET(APCDLOC)=""
SET APCDLOC=DUZ(2)
+3 SET DFN=APCDPAT
SET Y=APCDPAT
DO ^AUPNPAT
KILL Y
+4 SET APCDPLL=APCDLOC
SET APCDPLD=$PIECE(APCDDATE,".")
+5 SET APCDPLV=$GET(APCDVSIT)
+6 IF APCDPLV<0
SET APCDPLV=""
+7 DO EN^XBNEW("PL1^APCDAPRB","DFN;APCDPLL;APCDPLD;APCDPLV;VALM*")
+8 QUIT
PL1 ;EP
+1 DO TERM^VALM0
+2 DO ENDE^APCDPL
+3 QUIT
PO ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD PO (ADD)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
MPO ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD MPO (MPO)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
RPO ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD RPO (RPO)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
IPO ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD IPO (IPO)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
APO ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD APO (APO)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
MNN ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD MNN (MNN)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
RNO ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD RNO (RNO)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
PDSP ;EP
+1 SET DIE="^AUPNPAT("
SET DR="[APCD PDSP (PDSP)]"
SET DA=APCDPAT
DO ^DIE
KILL DA,DR,DIE
+2 QUIT
NON ;EP called from APCD NO (ADD) template
+1 DO ^XBNEW("NO^APCDAPRB:APCD*")
+2 QUIT
NOP ;EP called from APCD PO (ADD) template
+1 NEW APCDADDP
+2 SET APCDADDP=1
+3 DO ^XBNEW("NO1^APCDAPRB:APCD*")
+4 QUIT
NO ;EP add a note to a problem
+1 DO ^APCDPROB
+2 KILL DIR,DIRUT
SET DIR(0)="F^1:12"
SET DIR("A")="Enter Problem Number"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO NOX
+4 SET APCDPR=Y
+5 DO ^APCDPLK
+6 IF APCDPERR=1
WRITE $CHAR(7),$CHAR(7),"Not a valid problem number.",!
KILL APCDPERR
GOTO NO
+7 ;display existing notes, get next note number
NO1 ;EP
+1 SET APCDPROB=APCDPDFN
+2 IF APCDPROB["`"
SET APCDPROB=$PIECE(APCDPROB,"`",2)
+3 IF $GET(APCDPR)]""
WRITE !!,"Problem Number: ",APCDPR,?40,"Diagnosis: ",$PIECE($$ICDDX^ICDEX($PIECE(^AUPNPROB(APCDPROB,0),U)),U,2)
+4 IF $ORDER(^AUPNPROB(APCDPROB,11,0))
Begin DoDot:1
+5 WRITE !,"Problem Notes: "
SET L=0
FOR
SET L=$ORDER(^AUPNPROB(APCDPROB,11,L))
IF L'=+L
QUIT
IF $ORDER(^AUPNPROB(APCDPROB,11,L,11,0))
WRITE !?5,$PIECE(^DIC(4,$PIECE(^AUPNPROB(APCDPROB,11,L,0),U),0),U)
Begin DoDot:2
+6 SET X=0
FOR
SET X=$ORDER(^AUPNPROB(APCDPROB,11,L,11,X))
IF X'=+X
QUIT
WRITE !?10,"Note#",$PIECE(^AUPNPROB(APCDPROB,11,L,11,X,0),U)," ",$$FMTE^XLFDT($PIECE(^(0),U,5),5),?28,$PIECE(^AUPNPROB(APCDPROB,11,L,11,X,0),U,3)
End DoDot:2
End DoDot:1
+7 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Add a new Problem Note for this Problem"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
GOTO NOX
+9 IF Y=0
GOTO NOX
+10 ;get next note number
NUM ;
+1 ;add location multiple if necessary, otherwise get ien in multiple
+2 SET APCDNIEN=$ORDER(^AUPNPROB(APCDPROB,11,"B",APCDLOC,0))
+3 IF APCDNIEN=""
SET X="`"_APCDLOC
SET DIC="^AUPNPROB("_APCDPROB_",11,"
SET DA(1)=APCDPROB
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9000011,1101,0),U,2)
DO ^DIC
KILL DIC,DA,DR,Y,X
SET APCDNIEN=$ORDER(^AUPNPROB(APCDPROB,11,"B",APCDLOC,0))
+4 IF APCDNIEN=""
WRITE $CHAR(7),$CHAR(7),"ERROR UPDATING NOTE LOCATION MULTIPLE"
GOTO NOX
+5 SET (Y,X)=0
FOR
SET Y=$ORDER(^AUPNPROB(APCDPROB,11,APCDNIEN,11,"B",Y))
IF Y
SET X=Y
IF 'Y
SET X=X+1
KILL Y
QUIT
+6 SET APCDNUM=X
+7 WRITE !!,"Adding ",$PIECE(^DIC(4,APCDLOC,0),U)," Note #",X
+8 KILL DIC
SET X=APCDNUM
SET DA(1)=APCDNIEN
SET DA(2)=APCDPROB
SET DIC="^AUPNPROB("_APCDPROB_",11,"_APCDNIEN_",11,"
SET DIC("P")=$PIECE(^DD(9000011.11,1101,0),U,2)
SET DIC(0)="L"
DO ^DIC
KILL DA,DR
+9 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"ERROR when updating note number multiple",!
GOTO NOX
+10 SET DIE=DIC
KILL DIC
WRITE ?10
SET %=$SELECT($GET(APCDDATE):$PIECE(APCDDATE,"."),1:DT)
SET DA=+Y
SET DR=".03;.04////A;;.09////^S X=DUZ;.05///^S X=%"
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !!
+11 SET DIE="^AUPNPROB("
SET DA=APCDPROB
SET %=$SELECT($GET(APCDDATE):$PIECE(APCDDATE,"."),1:DT)
SET DR=".03////"_%_";.14////"_DUZ
DO ^DIE
KILL DIE,DA,DR,Y
+12 SET DA=APCDPROB
+13 IF '$GET(APCDADDP)
DO PLUDE
+14 GOTO NO1
+15 QUIT
NOX ;
+1 KILL Y,APCDPROB,X,L,APCDNUM,APCDNIEN,DIC,DA,DD
+2 QUIT
PLUDE ;EP - called from data entry input templates
+1 ;get provider who updated and date
+2 ;NEW APCDPRBI
+3 SET APCDTPRD=$GET(APCDTPRD)
+4 SET APCDPRBI=DA
+5 SET APCDP=$GET(APCDPAT)
+6 IF 'APCDP
SET APCDP=$GET(DFN)
+7 SET APCDV=$GET(APCDVSIT)
+8 IF APCDV<0
SET APCDV=""
+9 SET APCDD=$GET(APCDDATE)
+10 ;
+11 DO EN^XBNEW("PLUDE1^APCDAPRB","APCDP;APCDV;APCDD;APCDPRBI;APCDTPRD")
+12 QUIT
QUALP ;EP - called from input templates
+1 NEW APCDADDP
+2 SET APCDADDP=1
+3 DO ^XBNEW("QUAL1^APCDAPRB:APCD*")
+4 QUIT
QUAL ;EP add a note to a problem
+1 DO ^APCDPROB
+2 KILL DIR,DIRUT
SET DIR(0)="F^1:12"
SET DIR("A")="Enter Problem Number"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO NOX
+4 SET APCDPR=Y
+5 DO ^APCDPLK
+6 IF APCDPERR=1
WRITE $CHAR(7),$CHAR(7),"Not a valid problem number.",!
KILL APCDPERR
GOTO NO
+7 ;display existing notes, get next note number
QUAL1 ;EP
+1 SET APCDPROB=APCDPDFN
+2 IF APCDPROB["`"
SET APCDPROB=$PIECE(APCDPROB,"`",2)
QUAL2 WRITE !!?3,"Severity:"
+1 IF '$ORDER(^AUPNPROB(APCDPROB,13,0))
SET APCDC=0
WRITE " None recorded"
GOTO FM12
+2 DO EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?3")
+3 KILL APCDCM
SET X=0
SET APCDC=0
FOR
SET X=$ORDER(^AUPNPROB(APCDPROB,13,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET APCDC=APCDC+1
SET APCDCM(APCDC)=X
+5 WRITE !?2,APCDC,") ",$$GET1^DIQ(9000011.13,X_","_APCDPROB,.01)
End DoDot:1
FM12 ;
+1 DO EN^DDIOL("","","!!")
+2 KILL DIR
+3 SET DIR(0)="S^A:Add a Severity"_$SELECT(APCDC:";E:Edit an Existing Severity;D:Delete an Existing Severity",1:"")_";N:No Change"
+4 SET DIR("A")="Which action"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO FM13
+6 IF Y="N"
SET APCDDONE=1
GOTO FM13
+7 SET Y="FM"_Y
+8 DO @Y
+9 GOTO QUAL2
FM13 ;
+1 KILL Y
+2 QUIT
+3 ;
FME ;
+1 DO EN^DDIOL("","","!")
+2 KILL DIR
+3 SET DIR(0)="N^1:"_APCDC_":0"
SET DIR("A")="Edit Which One"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 KILL DIC,DA,DR
+6 IF $PIECE(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)]""
IF $PIECE(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)'=DUZ
Begin DoDot:1
+7 WRITE !!,"You did not enter that Severity, therefore you cannot edit it. It was entered by:",!,$PIECE(^VA(200,$PIECE(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2),0),U,1),!
QUIT
End DoDot:1
QUIT
+8 SET DA=APCDCM(Y)
SET DR=".01"
SET DA(1)=APCDPROB
+9 SET DIE="^AUPNPROB("_APCDPROB_",13,"
+10 DO ^DIE
+11 KILL DIE
+12 QUIT
FMD ;
+1 DO EN^DDIOL("","","!")
+2 KILL DIR
+3 SET DIR(0)="N^1:"_APCDC_":0"
SET DIR("A")="Delete Which One"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 IF $PIECE(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)]""
IF $PIECE(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2)'=DUZ
Begin DoDot:1
+6 WRITE !!,"You did not enter that qualifier, therefore you cannot delete it. It was entered by:",!,$PIECE(^VA(200,$PIECE(^AUPNPROB(APCDPROB,13,APCDCM(Y),0),U,2),0),U,1),!
QUIT
End DoDot:1
QUIT
+7 KILL DIC,DA,DR
+8 SET DA=APCDCM(Y)
SET DA(1)=APCDPROB
SET DIK="^AUPNPROB("_APCDPROB_",13,"
DO ^DIK
KILL DA,DIK
+9 QUIT
FMA ;
+1 SET DIR(0)="FO^1:30"
SET DIR("A")="Enter Qualifier"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 IF Y=""
QUIT
+4 SET DIC(0)="L"
SET DIC="^AUPNPROB("_APCDPROB_",13,"
SET DIC("DR")=".02////"_DUZ_";.03///^S X=$$NOW^XLFDT;.04////"_DUZ_";.05///^S X=$$NOW^XLFDT"
SET DA(1)=APCDPROB
+5 DO FILE^DICN
+6 QUIT
+7 ;
PLUDE1 ;EP - called from xbnew
+1 ;get date pl updated
+2 SET DIR(0)="D^::EPTSX"
SET DIR("A")="Enter the Date the Problem List was Updated by the Provider"
+3 SET DIR("B")=$SELECT($GET(APCDD):$$FMTE^XLFDT($PIECE(APCDD,".")),$GET(APCDV):$$FMTE^XLFDT($$VD^APCLV(APCDV)),1:$$FMTE^XLFDT(DT))
SET DIR("?")="This is the visit date or the date the provider updated the problem list."
+4 KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO PLUDE1
+6 IF $PIECE(Y,".")>DT
WRITE !!,"Future Dates now allowed.",!
GOTO PLUDE1
+7 SET APCDD=Y
PLUDE1P ;GET PROVIDER
+1 SET DIR(0)="9000010.54,1204"
SET DIR("A")="Enter the INDIVIDUAL who Updated the Problem List"
+2 SET DIR("A",1)="Enter the individual that updated the problem list. "
+3 SET DIR("A",2)="If you are transcribing an update from a PCC Provider, then enter"
+4 SET DIR("A",3)="the individual who requested the change. If you are data "
+5 SET DIR("A",4)="entry/coder correcting the problem entry such as correcting the "
+6 SET DIR("A",5)="ICD9 code, then enter yourself."
+7 SET DIR("B")=$SELECT($GET(APCDTPRD):$PIECE(^VA(200,APCDTPRD,0),U,1),$GET(APCDV):$$PRIMPROV^APCLV(APCDV,"N"),1:"")
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO PLUDE1P
+9 SET APCDPRV=+Y
+10 DO PLU($GET(APCDPRBI),APCDV,APCDP,APCDD,APCDPRV,.APCDRET)
+11 IF $PIECE(APCDRET,U,1)=0
WRITE !!,"error: ",$PIECE(APCDRET,U,2)
+12 QUIT
PLU(APCDPIEN,APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update Problem list update fields
+1 ;this API can be called to have a V UPDATED/REVIEWED entry and populate the
+2 ;.11, .12, and .13 fields
+3 ;input: APCDPIEN - ien of problem list entry
+4 ; APCDV - ien of visit, if in the context of a visit
+5 ; APCDP - DFN
+6 ; APCDD - Date and optionally time of problem list update (fileman format)
+7 ; APCDPRV = ien of provider updating the problem list
+8 ;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
+9 ;for Provider APCDP on date APCDD
+10 ;if not in the context of a visit (APCDV = null) then an event visit will be created
+11 ;with a V UPDATED/REVIEWED v file entry
+12 ;
+13 ;RETURN VALUE:
+14 ; ien of V UPDATED/REVIEWED entry that was created
+15 ; or 0^error message
+16 SET APCDPIEN=$GET(APCDPIEN)
+17 SET APCDV=$GET(APCDV)
+18 SET APCDP=$GET(APCDP)
+19 IF 'APCDP
SET RETVAL="0^not a valid patient DFN"
QUIT
+20 IF '$DATA(^AUPNPAT(APCDP,0))
SET RETVAL="0^not a valid patient DFN"
QUIT
+21 SET APCDD=$GET(APCDD)
+22 IF 'APCDD
SET RETVAL="0^no valid date passed"
QUIT
+23 SET APCDPRV=$GET(APCDPRV)
+24 IF 'APCDPRV
SET RETVAL="0^no valid provider ien passed"
QUIT
+25 SET RETVAL=""
+26 ;
+27 IF APCDV
DO PLUV
QUIT
+28 ;NO VISIT SO CREATE EVENT VISIT AND CALL PLUV
+29 DO EVSIT
+30 QUIT
PLUV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
+1 ;not exist on this visit already.
+2 NEW APCDX,APCDVD,APCDVRI,APCDVAL
+3 SET APCDVAL=$ORDER(^AUTTCRA("C","PLU",0))
+4 IF APCDVAL=""
SET RETVAL="0^action item missing"
QUIT
+5 SET APCDVRI=""
+6 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNVRUP("AD",APCDV,APCDX))
IF APCDX=""!(APCDVRI)
QUIT
Begin DoDot:1
+7 ;is this entry a problem list review entry?
+8 ;this one isn't a PLU entry
IF $PIECE(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL
QUIT
+9 IF $PIECE($GET(^AUPNVRUP(APCDX,2)),U,1)
QUIT
+10 ;not this provider
IF $PIECE($GET(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV
QUIT
+11 ;found one so don't create one
SET APCDVRI=APCDX
+12 QUIT
End DoDot:1
+13 IF APCDVRI
SET RETVAL=APCDVRI
QUIT
+14 ;create V UPDATED/REVIEWED entry
+15 NEW APCDALVR
+16 SET APCDALVR("APCDPAT")=APCDP
+17 SET APCDALVR("APCDVSIT")=APCDV
+18 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
+19 SET APCDALVR("APCDTCLA")="`"_APCDVAL
+20 SET APCDALVR("APCDTCDT")=APCDD
+21 SET APCDALVR("APCDTEPR")="`"_APCDPRV
+22 DO ^APCDALVR
+23 IF $DATA(APCDALVR("APCDAFLG"))
SET RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
+24 KILL APCDALVR
+25 QUIT
BSD ;
+1 NEW APCDBSDV
+2 KILL APCDIN
+3 SET APCDIN("PAT")=APCDP
+4 SET APCDIN("VISIT DATE")=APCDD_".12"
+5 SET APCDIN("SITE")=DUZ(2)
+6 SET APCDIN("VISIT TYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+7 SET APCDIN("SRV CAT")="E"
+8 SET APCDIN("TIME RANGE")=0
+9 SET APCDIN("USR")=DUZ
+10 KILL APCDALVR
+11 KILL APCDBSDV
+12 DO GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
+13 SET T=$PIECE(APCDBSDV(0),U,2)
+14 ;errored
IF T]""
SET RETVAL="0^could not create event visit"
QUIT
+15 SET V=$ORDER(APCDBSDV(0))
SET APCDV=V
+16 IF $GET(APCDBSDV(V))="ADD"
DO DEDT^APCDEA2(APCDV)
+17 QUIT
EVSIT ;EP - get/create event visit
+1 IF $LENGTH($TEXT(^BSDAPI4))
Begin DoDot:1
+2 DO BSD
+3 DO PLUV
End DoDot:1
QUIT
+4 KILL APCDVSIT
+5 KILL APCDALVR
+6 SET APCDALVR("APCDAUTO")=""
+7 SET APCDALVR("APCDPAT")=APCDP
+8 SET APCDALVR("APCDCAT")="E"
+9 SET APCDALVR("APCDLOC")=DUZ(2)
+10 SET APCDALVR("APCDTYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+11 SET APCDALVR("APCDDATE")=APCDD_".12"
+12 DO ^APCDALV
+13 SET APCDV=$GET(APCDALVR("APCDVSIT"))
+14 IF $GET(APCDALVR("APCDVSIT","NEW"))
DO DEDT^APCDEA2(APCDVSIT)
+15 KILL APCDALVR
+16 DO PLUV
+17 QUIT
ANYACTP(P,EDATE) ;EP - does this patient have any active problems?
+1 IF '$GET(P)
QUIT 0
+2 SET EDATE=$GET(EDATE)
+3 NEW X,Y,Z
+4 SET Z=0
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(Z)
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNPROB(X,0))
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+9 IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+10 SET Z=1
+11 QUIT
End DoDot:1
+12 QUIT Z
PLR(APCDTDA) ;EP - called from nap template to create PLR entry
+1 DO EN^XBNEW("PLR1^APCDAPRB","APCDTDA")
+2 QUIT
PLR1 ;
+1 ;create PLR entry on this visit
+2 ;create V UPDATED/REVIEWED entry
+3 NEW APCDALVR,APCDVAL
+4 SET APCDVAL=$ORDER(^AUTTCRA("C","PLR",0))
+5 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVRUP(APCDTDA,0),U,2)
+6 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVRUP(APCDTDA,0),U,3)
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
+8 SET APCDALVR("APCDTCLA")="`"_APCDVAL
+9 SET APCDALVR("APCDTCDT")=$PIECE($GET(^AUPNVRUP(APCDTDA,12)),U,1)
+10 IF $PIECE($GET(^AUPNVRUP(APCDTDA,12)),U,4)
SET APCDALVR("APCDTEPR")="`"_$PIECE(^AUPNVRUP(APCDTDA,12),U,4)
+11 DO ^APCDALVR
+12 IF $DATA(APCDALVR("APCDAFLG"))
SET RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
+13 KILL APCDALVR
+14 QUIT
CPS ;EP - CALLED FROM INPUT TEMPLATE APCD CPS TO UPDATE PROBLEM STATUS
+1 NEW APCDADFN
+2 SET APCDADFN=DA
+3 DO EN^XBNEW("CPS1^APCDAPRB","APCDADFN")
+4 KILL APCDADFN
+5 QUIT
CPS1 ;EP
+1 ;CALL READER TO GET VALUE
+2 SET DIR(0)="SBA^A:CHRONIC;I:INACTIVE;S:SUB-ACUTE;E:EPISODIC;O:SOCIAL;R:ROUTINE/ADMIN"
+3 SET DIR("A")=" STATUS: "
SET DIR("B")=$$VAL^XBDIQ1(9000011,APCDADFN,.12)
KILL DA
DO ^DIR
KILL DIR
+4 SET DIR("?")="NOTE: You cannot delete a problem with this mnemonic, use RPO to delete a problem."
+5 KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
QUIT
+7 SET DIE="^AUPNPROB("
SET DA=APCDADFN
SET DR=".12///"_Y
+8 DO ^DIE
+9 KILL DA,DIE,DR
+10 QUIT
CPSA ;EP - CALLED FROM INPUT TEMPLATE APCD CPS TO UPDATE PROBLEM STATUS
+1 NEW APCDADFN
+2 SET APCDADFN=DA
+3 DO EN^XBNEW("CPSA1^APCDAPRB","APCDADFN")
+4 KILL APCDADFN
+5 QUIT
CPSA1 ;EP
+1 ;CALL READER TO GET VALUE
+2 SET DIR(0)="SBA^A:CHRONIC;I:INACTIVE;S:SUB-ACUTE;E:EPISODIC;O:SOCIAL;R:ROUTINE/ADMIN"
+3 SET DIR("?")="This is the current activity status of this problem. If more detail, is needed, a notation may be filed with this problem"
+4 SET DIR("A")=" STATUS: "
SET DIR("B")="CHRONIC"
KILL DA
DO ^DIR
KILL DIR
+5 KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
WRITE "^ not allowed"
GOTO CPSA1
+7 IF Y=""
WRITE " Required"
GOTO CPSA1
+8 SET DIE="^AUPNPROB("
SET DA=APCDADFN
SET DR=".12///"_Y
+9 DO ^DIE
+10 KILL DA,DIE,DR
+11 QUIT
