APCDPLIE ;IHS/CMI/LAB - UPDATE ICD CODE FROM BSTS
;;2.0;IHS PCC SUITE;**16**;MAY 14, 2009;Build 9
;; ;
;
;THIS ROUTINE IS CALLED FROM AN OPTION THAT IS SCHEDULED TO RUN
;AT A SITE DEFINED INTERVAL. IT LOOPS THE PROBLEM FILE AND CHECKS
;ANY SNOMED CODED PROBLEM THAT HAS A STATUS OF EPISODIC.
;IF THE USED AS POV DATE IS GREATER THAN THE PARAMETER THE
;PROBLEM IS MARKED AS INACTIVE.
;E.G. EPISODIC PROBLEM WAS LAST USED AS POV ON 1/1/16.
;PARAMETER IS SET TO 30. TODAY IS 3/1/16. SINCE 1/1/16 IS
;GREATER THAN 30 DAYS AGO IT WILL MARK THE PROBLEM AS INACTIVE.
EP ;EP - CALLED FROM SCHEDULED OPTION
D QUEUE
D XIT
Q
XIT ;
D EN^XBVK("APCD")
Q
QUEUE ;EP
S APCDDAYS=$$GET^XPAR("SYS","BGO IPL INACTIVATE TIMEFRAME")
I APCDDAYS="" Q
S APCDX=0,APCDCNT=0
F S APCDX=$O(^AUPNPROB(APCDX)) Q:APCDX'=+APCDX D
.Q:'$D(^AUPNPROB(APCDX,0))
.S APCDCI=$P($G(^AUPNPROB(APCDX,800)),U) ;only snomed coded problems
.Q:APCDCI=""
.S APCDCS=$P(^AUPNPROB(APCDX,0),U,12) ;current status
.Q:APCDCS'="E" ;EPISODIC PROBLEMS ONLY
.S APCDLU=$$LASTUAPV(APCDX)
.;
.I APCDLU="" Q ;NEVER USED AS POV??
.S X=$$FMDIFF^XLFDT(DT,APCDLU)
.;W !,APCDX," ",APCDLU," ",APCDCS W " ",X
.I X<APCDDAYS Q
.;W " INACTIVATE"
.D CS
Q
LASTUAPV(P) ;
I '$G(P) Q ""
NEW X,Y,Z,V,D
S X=0
F S X=$O(^AUPNPROB(P,14,X)) Q:X'=+X D
.S V=$P($G(^AUPNPROB(P,14,X,0)),U,1) ;VISIT IEN
.I 'V Q ;NO .01??
.I '$D(^AUPNVSIT(V,0)) Q ;VISIT MUST HAVE BEEN DELETED
.S D=$$VD^APCLV(V) ;VISIT DATE, FM FORMAT
.S Z(D)=""
S X=0
F S X=$O(^AUPNPROB(P,15,X)) Q:X'=+X D
.S V=$P($G(^AUPNPROB(P,15,X,0)),U,1) ;VISIT IEN
.I 'V Q ;NO .01??
.I '$D(^AUPNVSIT(V,0)) Q ;VISIT MUST HAVE BEEN DELETED
.S D=$$VD^APCLV(V) ;VISIT DATE, FM FORMAT
.S Z(D)=""
S Z=$O(Z(99999999),-1)
Q Z
CS ;update status .12 and update PROBLEM entry and the change log
;update my log
K DIE,DA,DR
S DIE="^AUPNPROB(",DA=APCDX,DR=".12///I" D ^DIE K DIE,DA,DR
K DIC,DD,D0,DO,DO
S DIADD=1,DLAYGO=9001040.1,DIC(0)="L",DIC="^APCDPLMD("
S X=DT,DIC("DR")=".02////"_APCDX_";.07////9000011;1301///E"_";1302///I;1303///"_APCDLU
D FILE^DICN
K DIC,DIADD,DLAYGO
S APCDLOGE=+Y
Q
SETE ;
S DA=APCDLOGE,DIE="^APCDPLMD(",DR="1///"_ERR("DIERR",1)
Q
APCDPLIE ;IHS/CMI/LAB - UPDATE ICD CODE FROM BSTS
+1 ;;2.0;IHS PCC SUITE;**16**;MAY 14, 2009;Build 9
+2 ;; ;
+3 ;
+4 ;THIS ROUTINE IS CALLED FROM AN OPTION THAT IS SCHEDULED TO RUN
+5 ;AT A SITE DEFINED INTERVAL. IT LOOPS THE PROBLEM FILE AND CHECKS
+6 ;ANY SNOMED CODED PROBLEM THAT HAS A STATUS OF EPISODIC.
+7 ;IF THE USED AS POV DATE IS GREATER THAN THE PARAMETER THE
+8 ;PROBLEM IS MARKED AS INACTIVE.
+9 ;E.G. EPISODIC PROBLEM WAS LAST USED AS POV ON 1/1/16.
+10 ;PARAMETER IS SET TO 30. TODAY IS 3/1/16. SINCE 1/1/16 IS
+11 ;GREATER THAN 30 DAYS AGO IT WILL MARK THE PROBLEM AS INACTIVE.
EP ;EP - CALLED FROM SCHEDULED OPTION
+1 DO QUEUE
+2 DO XIT
+3 QUIT
XIT ;
+1 DO EN^XBVK("APCD")
+2 QUIT
QUEUE ;EP
+1 SET APCDDAYS=$$GET^XPAR("SYS","BGO IPL INACTIVATE TIMEFRAME")
+2 IF APCDDAYS=""
QUIT
+3 SET APCDX=0
SET APCDCNT=0
+4 FOR
SET APCDX=$ORDER(^AUPNPROB(APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNPROB(APCDX,0))
QUIT
+6 ;only snomed coded problems
SET APCDCI=$PIECE($GET(^AUPNPROB(APCDX,800)),U)
+7 IF APCDCI=""
QUIT
+8 ;current status
SET APCDCS=$PIECE(^AUPNPROB(APCDX,0),U,12)
+9 ;EPISODIC PROBLEMS ONLY
IF APCDCS'="E"
QUIT
+10 SET APCDLU=$$LASTUAPV(APCDX)
+11 ;
+12 ;NEVER USED AS POV??
IF APCDLU=""
QUIT
+13 SET X=$$FMDIFF^XLFDT(DT,APCDLU)
+14 ;W !,APCDX," ",APCDLU," ",APCDCS W " ",X
+15 IF X<APCDDAYS
QUIT
+16 ;W " INACTIVATE"
+17 DO CS
End DoDot:1
+18 QUIT
LASTUAPV(P) ;
+1 IF '$GET(P)
QUIT ""
+2 NEW X,Y,Z,V,D
+3 SET X=0
+4 FOR
SET X=$ORDER(^AUPNPROB(P,14,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;VISIT IEN
SET V=$PIECE($GET(^AUPNPROB(P,14,X,0)),U,1)
+6 ;NO .01??
IF 'V
QUIT
+7 ;VISIT MUST HAVE BEEN DELETED
IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 ;VISIT DATE, FM FORMAT
SET D=$$VD^APCLV(V)
+9 SET Z(D)=""
End DoDot:1
+10 SET X=0
+11 FOR
SET X=$ORDER(^AUPNPROB(P,15,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 ;VISIT IEN
SET V=$PIECE($GET(^AUPNPROB(P,15,X,0)),U,1)
+13 ;NO .01??
IF 'V
QUIT
+14 ;VISIT MUST HAVE BEEN DELETED
IF '$DATA(^AUPNVSIT(V,0))
QUIT
+15 ;VISIT DATE, FM FORMAT
SET D=$$VD^APCLV(V)
+16 SET Z(D)=""
End DoDot:1
+17 SET Z=$ORDER(Z(99999999),-1)
+18 QUIT Z
CS ;update status .12 and update PROBLEM entry and the change log
+1 ;update my log
+2 KILL DIE,DA,DR
+3 SET DIE="^AUPNPROB("
SET DA=APCDX
SET DR=".12///I"
DO ^DIE
KILL DIE,DA,DR
+4 KILL DIC,DD,D0,DO,DO
+5 SET DIADD=1
SET DLAYGO=9001040.1
SET DIC(0)="L"
SET DIC="^APCDPLMD("
+6 SET X=DT
SET DIC("DR")=".02////"_APCDX_";.07////9000011;1301///E"_";1302///I;1303///"_APCDLU
+7 DO FILE^DICN
+8 KILL DIC,DIADD,DLAYGO
+9 SET APCDLOGE=+Y
+10 QUIT
SETE ;
+1 SET DA=APCDLOGE
SET DIE="^APCDPLMD("
SET DR="1///"_ERR("DIERR",1)
+2 QUIT
