- 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