APCDPLST ;IHS/CMI/LAB - UPDATE ICD CODE FROM BSTS
;;2.0;IHS PCC SUITE;**16**;MAY 14, 2009;Build 9
;; ;
;
W !!,"This option is used to update the Status field on Problem List"
W !,"based on the default status associated with the SNOMED term.",!!
W !,"You will be given the opportunity to select which status group",!
W "will be updated."
W !,"Notes:"
W !,?2,"- Update all Chronic: this will loop through the problems on"
W !?2," the IPL and for any problem whose Concept ID is defaulted to Chronic "
W !?2," in DTS, change to Chronic on IPL. Problems on the IPL with a status "
W !?2," of inactive will be skipped and the status will not be changed."
;W !,?2,"- Update all Sub-Acute: this will loop through the problems on"
;W !?2," the IPL and for any problem whose Concept ID is defaulted to Sub-Acute "
;W !?2," in DTS, change to Sub-Acute on IPL. Problems on the IPL with a status "
;W !?2," of Inactive or Chronic will be skipped and the status will not be changed."
W !,?2,"- Update all Social/Environmental: this will loop through the problems on"
W !?2," the IPL and for any problem whose Concept ID is defaulted to "
W !?2," Social/Environmental in DTS, change to Social/Environmental on IPL. "
W !?2," Problems on the IPL with a status of Inactive or Chronic will be skipped"
W !?2," and the status will not be changed."
W !,?2,"- Update all Routine/Admin: this will loop through the problems on"
W !?2," the IPL and for any problem whose Concept ID is defaulted to Routine/Admin "
W !?2," in DTS, change to Routine/Admin on IPL. Problems on the IPL with a status "
W !?2," of Inactive will be skipped and the status will not be changed."
S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I 'Y Q
;WHICH ONES SHOULD BE UPDATED
K DIR
S DIR(0)="S^C:Chronic Status Concept IDs;O:Social/Environmental Concept IDs;R:Routine/Admin Concept IDs;A:All of these Types",DIR("A")="Update which Problem's Status" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D XIT Q
I Y="" D XIT Q
S APCDPLT=Y
W !!,"Hold on..this may take a few minutes.."
D QUEUE
D XIT
Q
XIT ;
D EN^XBVK("APCD")
K ^TMP($J)
Q
SETSUB ;
S X=$$SUBLST^BSTSAPI(OUT,IN)
;SET UP INDEX
S Y=0 F S Y=$O(^TMP($J,APCDS,Y)) Q:Y'=+Y D
.S X=$P(^TMP($J,APCDS,Y),U,1)
.S ^TMP($J,"I",X,APCDS)=""
.Q
Q
QUEUE ;EP
W !!,"Gathering up subsets..."
;GATHER UP THE SUBSET LISTS
NEW OUT,IN,C,J,Y,X,I
K ^TMP($J)
I APCDPLT="C"!(APCDPLT="A") S OUT=$NA(^TMP($J,"A")),IN="EHR IPL DEFAULT STATUS CHRONIC",APCDS="A" D SETSUB
;I APCDPLT="S"!(APCDPLT="A") S OUT=$NA(^TMP($J,"S")),IN="EHR IPL DEFAULT STATUS SUB",APCDS="S" D SETSUB
I APCDPLT="O"!(APCDPLT="A") S OUT=$NA(^TMP($J,"O")),IN="EHR IPL DEFAULT STATUS SOCIAL",APCDS="O" D SETSUB
I APCDPLT="R"!(APCDPLT="A") S OUT=$NA(^TMP($J,"R")),IN="EHR IPL DEFAULT STATUS ADMIN",APCDS="R" D SETSUB
I '$D(ZTQUEUED) W !!,"Looping through Problem entries....."
;
S APCDX=0,APCDCNT=0
F S APCDX=$O(^AUPNPROB(APCDX)) Q:APCDX'=+APCDX D
.S APCDCNT=APCDCNT+1
.W:'(APCDCNT#1000) "."
.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="D" ;SKIP DELETED PROBLEMS
.Q:APCDCS="I" ;SKIP INACTIVE PROBLEMS PER SUSAN
.;CHECK EACH ONE
.;get this snomed's default status
.S APCDDEF=$O(^TMP($J,"I",APCDCI,""))
.Q:APCDDEF="" ;NO DEFAULT SO SKIP THIS PROBLEM
.I APCDCS=APCDDEF Q ;STATUS IS ALREADY THE DEFAULTED STATUS SO DON'T BOTHER
.I APCDPLT="C"!(APCDPLT="A"),APCDDEF="A" D CS Q ;IF WANT TO CHANGE CHRONICS AND THIS IS CHRONIC CHANGE IT
.;I APCDPLT="S"!(APCDPLT="A"),APCDDEF="S",APCDCS'="A" D CS Q ;IF WANT TO CHANGE SUBACUTES AND THIS IS SUBACUTE CHANGE IT EXCEPT IF IT IS CHRONIC
.I APCDPLT="O"!(APCDPLT="A"),APCDDEF="O",APCDCS'="A" D CS Q ;IF WANT TO CHANGE SOCIAL AND THIS IS SOCIAL CHANGE IT EXCEPT IF IT IS CHRONIC
.I APCDPLT="R"!(APCDPLT="A"),APCDDEF="R" D CS Q ;IF WANT TO CHANGE ROUTINE/ADMIN AND THIS IS ROUTINE/ADMIN CHANGE IT EXCEPT IF IT IS CHRONIC
Q
CS ;update status .12 and update PROBLEM entry and the change log
S APCDOLDS=APCDCS
K DIE,DA,DR
S DIE="^AUPNPROB(",DA=APCDX,DR=".12///"_APCDDEF D ^DIE K DIE,DA,DR
;update my log to save my ....
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;.08////"_APCDCI_";1301///"_APCDCS_";1302///"_APCDDEF
D FILE^DICN
K DIC,DIADD,DLAYGO
S APCDLOGE=+Y
Q
SETE ;
S DA=APCDLOGE,DIE="^APCDPLMD(",DR="1///"_ERR("DIERR",1)
Q
APCDPLST ;IHS/CMI/LAB - UPDATE ICD CODE FROM BSTS
+1 ;;2.0;IHS PCC SUITE;**16**;MAY 14, 2009;Build 9
+2 ;; ;
+3 ;
+4 WRITE !!,"This option is used to update the Status field on Problem List"
+5 WRITE !,"based on the default status associated with the SNOMED term.",!!
+6 WRITE !,"You will be given the opportunity to select which status group",!
+7 WRITE "will be updated."
+8 WRITE !,"Notes:"
+9 WRITE !,?2,"- Update all Chronic: this will loop through the problems on"
+10 WRITE !?2," the IPL and for any problem whose Concept ID is defaulted to Chronic "
+11 WRITE !?2," in DTS, change to Chronic on IPL. Problems on the IPL with a status "
+12 WRITE !?2," of inactive will be skipped and the status will not be changed."
+13 ;W !,?2,"- Update all Sub-Acute: this will loop through the problems on"
+14 ;W !?2," the IPL and for any problem whose Concept ID is defaulted to Sub-Acute "
+15 ;W !?2," in DTS, change to Sub-Acute on IPL. Problems on the IPL with a status "
+16 ;W !?2," of Inactive or Chronic will be skipped and the status will not be changed."
+17 WRITE !,?2,"- Update all Social/Environmental: this will loop through the problems on"
+18 WRITE !?2," the IPL and for any problem whose Concept ID is defaulted to "
+19 WRITE !?2," Social/Environmental in DTS, change to Social/Environmental on IPL. "
+20 WRITE !?2," Problems on the IPL with a status of Inactive or Chronic will be skipped"
+21 WRITE !?2," and the status will not be changed."
+22 WRITE !,?2,"- Update all Routine/Admin: this will loop through the problems on"
+23 WRITE !?2," the IPL and for any problem whose Concept ID is defaulted to Routine/Admin "
+24 WRITE !?2," in DTS, change to Routine/Admin on IPL. Problems on the IPL with a status "
+25 WRITE !?2," of Inactive will be skipped and the status will not be changed."
+26 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+27 IF $DATA(DIRUT)
QUIT
+28 IF 'Y
QUIT
+29 ;WHICH ONES SHOULD BE UPDATED
+30 KILL DIR
+31 SET DIR(0)="S^C:Chronic Status Concept IDs;O:Social/Environmental Concept IDs;R:Routine/Admin Concept IDs;A:All of these Types"
SET DIR("A")="Update which Problem's Status"
KILL DA
DO ^DIR
KILL DIR
+32 IF $DATA(DIRUT)
DO XIT
QUIT
+33 IF Y=""
DO XIT
QUIT
+34 SET APCDPLT=Y
+35 WRITE !!,"Hold on..this may take a few minutes.."
+36 DO QUEUE
+37 DO XIT
+38 QUIT
XIT ;
+1 DO EN^XBVK("APCD")
+2 KILL ^TMP($JOB)
+3 QUIT
SETSUB ;
+1 SET X=$$SUBLST^BSTSAPI(OUT,IN)
+2 ;SET UP INDEX
+3 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,APCDS,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+4 SET X=$PIECE(^TMP($JOB,APCDS,Y),U,1)
+5 SET ^TMP($JOB,"I",X,APCDS)=""
+6 QUIT
End DoDot:1
+7 QUIT
QUEUE ;EP
+1 WRITE !!,"Gathering up subsets..."
+2 ;GATHER UP THE SUBSET LISTS
+3 NEW OUT,IN,C,J,Y,X,I
+4 KILL ^TMP($JOB)
+5 IF APCDPLT="C"!(APCDPLT="A")
SET OUT=$NAME(^TMP($JOB,"A"))
SET IN="EHR IPL DEFAULT STATUS CHRONIC"
SET APCDS="A"
DO SETSUB
+6 ;I APCDPLT="S"!(APCDPLT="A") S OUT=$NA(^TMP($J,"S")),IN="EHR IPL DEFAULT STATUS SUB",APCDS="S" D SETSUB
+7 IF APCDPLT="O"!(APCDPLT="A")
SET OUT=$NAME(^TMP($JOB,"O"))
SET IN="EHR IPL DEFAULT STATUS SOCIAL"
SET APCDS="O"
DO SETSUB
+8 IF APCDPLT="R"!(APCDPLT="A")
SET OUT=$NAME(^TMP($JOB,"R"))
SET IN="EHR IPL DEFAULT STATUS ADMIN"
SET APCDS="R"
DO SETSUB
+9 IF '$DATA(ZTQUEUED)
WRITE !!,"Looping through Problem entries....."
+10 ;
+11 SET APCDX=0
SET APCDCNT=0
+12 FOR
SET APCDX=$ORDER(^AUPNPROB(APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+13 SET APCDCNT=APCDCNT+1
+14 IF '(APCDCNT#1000)
WRITE "."
+15 IF '$DATA(^AUPNPROB(APCDX,0))
QUIT
+16 ;only snomed coded problems
SET APCDCI=$PIECE($GET(^AUPNPROB(APCDX,800)),U)
+17 IF APCDCI=""
QUIT
+18 ;current status
SET APCDCS=$PIECE(^AUPNPROB(APCDX,0),U,12)
+19 ;SKIP DELETED PROBLEMS
IF APCDCS="D"
QUIT
+20 ;SKIP INACTIVE PROBLEMS PER SUSAN
IF APCDCS="I"
QUIT
+21 ;CHECK EACH ONE
+22 ;get this snomed's default status
+23 SET APCDDEF=$ORDER(^TMP($JOB,"I",APCDCI,""))
+24 ;NO DEFAULT SO SKIP THIS PROBLEM
IF APCDDEF=""
QUIT
+25 ;STATUS IS ALREADY THE DEFAULTED STATUS SO DON'T BOTHER
IF APCDCS=APCDDEF
QUIT
+26 ;IF WANT TO CHANGE CHRONICS AND THIS IS CHRONIC CHANGE IT
IF APCDPLT="C"!(APCDPLT="A")
IF APCDDEF="A"
DO CS
QUIT
+27 ;I APCDPLT="S"!(APCDPLT="A"),APCDDEF="S",APCDCS'="A" D CS Q ;IF WANT TO CHANGE SUBACUTES AND THIS IS SUBACUTE CHANGE IT EXCEPT IF IT IS CHRONIC
+28 ;IF WANT TO CHANGE SOCIAL AND THIS IS SOCIAL CHANGE IT EXCEPT IF IT IS CHRONIC
IF APCDPLT="O"!(APCDPLT="A")
IF APCDDEF="O"
IF APCDCS'="A"
DO CS
QUIT
+29 ;IF WANT TO CHANGE ROUTINE/ADMIN AND THIS IS ROUTINE/ADMIN CHANGE IT EXCEPT IF IT IS CHRONIC
IF APCDPLT="R"!(APCDPLT="A")
IF APCDDEF="R"
DO CS
QUIT
End DoDot:1
+30 QUIT
CS ;update status .12 and update PROBLEM entry and the change log
+1 SET APCDOLDS=APCDCS
+2 KILL DIE,DA,DR
+3 SET DIE="^AUPNPROB("
SET DA=APCDX
SET DR=".12///"_APCDDEF
DO ^DIE
KILL DIE,DA,DR
+4 ;update my log to save my ....
+5 KILL DIC,DD,D0,DO,DO
+6 SET DIADD=1
SET DLAYGO=9001040.1
SET DIC(0)="L"
SET DIC="^APCDPLMD("
+7 SET X=DT
SET DIC("DR")=".02////"_APCDX_";.07////9000011;.08////"_APCDCI_";1301///"_APCDCS_";1302///"_APCDDEF
+8 DO FILE^DICN
+9 KILL DIC,DIADD,DLAYGO
+10 SET APCDLOGE=+Y
+11 QUIT
SETE ;
+1 SET DA=APCDLOGE
SET DIE="^APCDPLMD("
SET DR="1///"_ERR("DIERR",1)
+2 QUIT
