Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDPLST

APCDPLST.m

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