- 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
