Changeset 623 for WorldVistAEHR/trunk/r/PROBLEM_LIST-GMPL/GMPLHS.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/PROBLEM_LIST-GMPL/GMPLHS.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PROBLEM_LIST-GMPL/GMPLHS.m
r613 r623 1 GMPLHS ; SLC/MKB/KER - Extract Prob List Health Summary ; 04/15/2002 2 ;;2.0;Problem List;**22,26,35**;Aug 25, 1994;Build 26 3 ; 4 ; External References 5 ; DBIA 3106 ^DIC(49 6 ; DBIA 10060 ^VA(200 7 ; DBIA 10015 EN^DIQ1 8 ; 9 GETLIST(GMPDFN,STATUS) ; Define List 10 N GMPLIST,GMPLVIEW,GMPARAM,GMPTOTAL K ^TMP("GMPLHS",$J) Q:+GMPDFN'>0 11 S GMPARAM("QUIET")=1,GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R" 12 S GMPLVIEW("ACT")=STATUS,GMPLVIEW("PROV")=0,GMPLVIEW("VIEW")="" 13 D GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW) 14 BUILD ; Build list for selected patient 15 ; Sets Global Array: 16 ; ^TMP("GMPLHS",$J,STATUS,0) 17 ; 18 ; Piece 1: GMPCNT # of entries extracted 19 ; 2: GMPTOTAL # of entries that exist 20 N IFN,GMPCNT,NUM S (NUM,GMPCNT)=0 F S NUM=$O(GMPLIST(NUM)) Q:NUM'>0 D 21 . S IFN=+GMPLIST(NUM) Q:IFN'>0 D GETPROB(IFN) 22 I $G(GMPCNT)'>0 K ^TMP("GMPLHS",$J) Q 23 S ^TMP("GMPLHS",$J,STATUS,0)=GMPCNT_U_GMPTOTAL 24 Q 25 GETPROB(IFN) ; Get problem data and set it to ^TMP array 26 ; Sets Global Arrays: 27 ; ^TMP("GMPLHS",$J,CNT,0) 28 ; Piece 1: Pointer to ICD9 file #80 29 ; 2: Internal Date Last Modified 30 ; 3: Facility Name 31 ; 4: Internal Date Entered 32 ; 5: Internal Status (A/I/"") 33 ; 6: Internal Date of Onset 34 ; 7: Responsible Provider Name 35 ; 8: Service Name 36 ; 9: Service Abbreviation 37 ; 10: Internal Date Resolved 38 ; 11: Clinic Name 39 ; 12: Internal Date Recorded 40 ; 13: Problem Term (from Lexicon) 41 ; 14: Exposure String (AO/IR/EC/HNC/MST/CV/SHD) 42 ; 43 ; ^TMP("GMPLHS",$J,CNT,"N") 44 ; Piece 1: Provider Narrative 45 ; 46 ; ^TMP("GMPLHS",$J,CNT,"IEN") 47 ; Piece 1: Pointer to Problem file 9000011 48 ; 49 N DIC,DIQ,DR,DA,REC,DIAG,LASTMDT,NARR,SITE,ENTDT,STAT,ONSETDT,RPROV 50 N SERV,SERVABB,RESDT,CLIN,RECDT,LEXI,LEX,PG,AO,EXP,HNC,MST,CV,SHD,IR,SCS 51 S DIC=9000011,DA=IFN,DIQ="REC(",DIQ(0)="IE" 52 S DR=".01;.03;.05;.06;.08;.12;.13;1.01;1.05;1.06;1.07;1.08;1.09;1.11;1.12;1.13;1.15;1.16;1.17;1.18" 53 D EN^DIQ1 54 S DIAG=REC(9000011,DA,.01,"I"),LASTMDT=REC(9000011,DA,.03,"I") 55 S NARR=REC(9000011,DA,.05,"E"),SITE=REC(9000011,DA,.06,"E") 56 S ENTDT=REC(9000011,DA,.08,"I"),STAT=REC(9000011,DA,.12,"I") 57 S ONSETDT=REC(9000011,DA,.13,"I") 58 S LEXI=REC(9000011,DA,1.01,"I") 59 S LEX=REC(9000011,DA,1.01,"E") 60 S RPROV=REC(9000011,DA,1.05,"E") 61 S SERV=REC(9000011,DA,1.06,"E") 62 S SERVABB=$$SERV(REC(9000011,DA,1.06,"I"),SERV) 63 S RESDT=REC(9000011,DA,1.07,"I") 64 S CLIN=REC(9000011,DA,1.08,"E") 65 S RECDT=REC(9000011,DA,1.09,"I") 66 S AO=+REC(9000011,DA,1.11,"I") 67 S IR=+REC(9000011,DA,1.12,"I") 68 S PG=+REC(9000011,DA,1.13,"I") 69 S HNC=+REC(9000011,DA,1.15,"I") 70 S MST=+REC(9000011,DA,1.16,"I") 71 S CV=+REC(9000011,DA,1.17,"I") 72 S SHD=+REC(9000011,DA,1.18,"I") 73 K SCS D SCS^GMPLX1(DA,.SCS) S EXP=$G(SCS(1)) 74 S GMPCNT=GMPCNT+1,^TMP("GMPLHS",$J,GMPCNT,0)=DIAG_U_LASTMDT_U_SITE_U_ENTDT_U_STAT_U_ONSETDT_U_RPROV_U_SERV_U_SERVABB_U_RESDT_U_CLIN_U_RECDT_U_LEX_U_EXP 75 S ^TMP("GMPLHS",$J,GMPCNT,"N")=NARR,^TMP("GMPLHS",$J,GMPCNT,"IEN")=IFN 76 S:+LEXI>0 ^TMP("GMPLHS",$J,GMPCNT,"L")=LEXI_"^"_LEX 77 D GETCOMM(IFN,GMPCNT) 78 Q 79 GETCOMM(IFN,CNT) ; Get Active Comments for a Note 80 ; Sets Global Array: 81 ; ^TMP("GMPLHS",$J,CNT,"C",LOCATION,NOTE NMBR,0) 82 ; 83 ; Piece 1: Note Narrative 84 ; 2: Internal Date Note Added 85 ; 3; Name of Note's Author 86 ; 87 N IFN2,IFN3,LOC,NODE S LOC=0 Q:$D(^AUPNPROB(IFN,11))'>0 S IFN2=0 88 F S IFN2=$O(^AUPNPROB(IFN,11,IFN2)) Q:IFN2'>0 D 89 . Q:$D(^AUPNPROB(IFN,11,IFN2,11))'>0 90 . S LOC=+$G(^AUPNPROB(IFN,11,IFN2,0)),IFN3=0 91 . F S IFN3=$O(^AUPNPROB(IFN,11,IFN2,11,IFN3)) Q:IFN3'>0 D 92 . . S NODE=$G(^AUPNPROB(IFN,11,IFN2,11,IFN3,0)) Q:$P(NODE,U,4)']"" 93 . . S ^TMP("GMPLHS",$J,CNT,"C",LOC,$P(NODE,U),0)=$P(NODE,U,3)_U_$P(NODE,U,5)_U_$P($G(^VA(200,+$P(NODE,U,6),0)),U) 94 Q 95 SERV(X,SERV) ; Returns Service Name Abbreviation 96 N ABBREV S ABBREV=$P($G(^DIC(49,+X,0)),U,2) S:ABBREV="" ABBREV=$E($G(SERV),1,5) 97 Q ABBREV 1 GMPLHS ; SLC/MKB/KER - Extract Prob List Health Summary ; 04/15/2002 2 ;;2.0;Problem List;**22,26**;Aug 25, 1994 3 ; 4 ; External References 5 ; DBIA 3106 ^DIC(49 6 ; DBIA 10060 ^VA(200 7 ; DBIA 10015 EN^DIQ1 8 ; 9 GETLIST(GMPDFN,STATUS) ; Define List 10 N GMPLIST,GMPLVIEW,GMPARAM,GMPTOTAL K ^TMP("GMPLHS",$J) Q:+GMPDFN'>0 11 S GMPARAM("QUIET")=1,GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R" 12 S GMPLVIEW("ACT")=STATUS,GMPLVIEW("PROV")=0,GMPLVIEW("VIEW")="" 13 D GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW) 14 BUILD ; Build list for selected patient 15 ; Sets Global Array: 16 ; ^TMP("GMPLHS",$J,STATUS,0) 17 ; 18 ; Piece 1: GMPCNT # of entries extracted 19 ; 2: GMPTOTAL # of entries that exist 20 N IFN,GMPCNT,NUM S (NUM,GMPCNT)=0 F S NUM=$O(GMPLIST(NUM)) Q:NUM'>0 D 21 . S IFN=+GMPLIST(NUM) Q:IFN'>0 D GETPROB(IFN) 22 I $G(GMPCNT)'>0 K ^TMP("GMPLHS",$J) Q 23 S ^TMP("GMPLHS",$J,STATUS,0)=GMPCNT_U_GMPTOTAL 24 Q 25 GETPROB(IFN) ; Get problem data and set it to ^TMP array 26 ; Sets Global Arrays: 27 ; ^TMP("GMPLHS",$J,CNT,0) 28 ; Piece 1: Pointer to ICD9 file #80 29 ; 2: Internal Date Last Modified 30 ; 3: Facility Name 31 ; 4: Internal Date Entered 32 ; 5: Internal Status (A/I/"") 33 ; 6: Internal Date of Onset 34 ; 7: Responsible Provider Name 35 ; 8: Service Name 36 ; 9: Service Abbreviation 37 ; 10: Internal Date Resolved 38 ; 11: Clinic Name 39 ; 12: Internal Date Recorded 40 ; 13: Problem Term (from Lexicon) 41 ; 14: Exposure String (AO/IR/EC/HNC/MST) 42 ; 43 ; ^TMP("GMPLHS",$J,CNT,"N") 44 ; Piece 1: Provider Narrative 45 ; 46 ; ^TMP("GMPLHS",$J,CNT,"IEN") 47 ; Piece 1: Pointer to Problem file 9000011 48 ; 49 N DIC,DIQ,DR,DA,REC,DIAG,LASTMDT,NARR,SITE,ENTDT,STAT,ONSETDT,RPROV 50 N SERV,SERVABB,RESDT,CLIN,RECDT,LEXI,LEX,PG,AO,EXP,HNC,MST,IR,SCS 51 S DIC=9000011,DA=IFN,DIQ="REC(",DIQ(0)="IE" 52 S DR=".01;.03;.05;.06;.08;.12;.13;1.01;1.05;1.06;1.07;1.08;1.09;1.11;1.12;1.13;1.15;1.16" 53 D EN^DIQ1 54 S DIAG=REC(9000011,DA,.01,"I"),LASTMDT=REC(9000011,DA,.03,"I") 55 S NARR=REC(9000011,DA,.05,"E"),SITE=REC(9000011,DA,.06,"E") 56 S ENTDT=REC(9000011,DA,.08,"I"),STAT=REC(9000011,DA,.12,"I") 57 S ONSETDT=REC(9000011,DA,.13,"I") 58 S LEXI=REC(9000011,DA,1.01,"I") 59 S LEX=REC(9000011,DA,1.01,"E") 60 S RPROV=REC(9000011,DA,1.05,"E") 61 S SERV=REC(9000011,DA,1.06,"E") 62 S SERVABB=$$SERV(REC(9000011,DA,1.06,"I"),SERV) 63 S RESDT=REC(9000011,DA,1.07,"I") 64 S CLIN=REC(9000011,DA,1.08,"E") 65 S RECDT=REC(9000011,DA,1.09,"I") 66 S AO=+REC(9000011,DA,1.11,"I") 67 S IR=+REC(9000011,DA,1.12,"I") 68 S PG=+REC(9000011,DA,1.13,"I") 69 S HNC=+REC(9000011,DA,1.15,"I") 70 S MST=+REC(9000011,DA,1.16,"I") 71 K SCS D SCS^GMPLX1(DA,.SCS) S EXP=$G(SCS(1)) 72 S GMPCNT=GMPCNT+1,^TMP("GMPLHS",$J,GMPCNT,0)=DIAG_U_LASTMDT_U_SITE_U_ENTDT_U_STAT_U_ONSETDT_U_RPROV_U_SERV_U_SERVABB_U_RESDT_U_CLIN_U_RECDT_U_LEX_U_EXP 73 S ^TMP("GMPLHS",$J,GMPCNT,"N")=NARR,^TMP("GMPLHS",$J,GMPCNT,"IEN")=IFN 74 S:+LEXI>0 ^TMP("GMPLHS",$J,GMPCNT,"L")=LEXI_"^"_LEX 75 D GETCOMM(IFN,GMPCNT) 76 Q 77 GETCOMM(IFN,CNT) ; Get Active Comments for a Note 78 ; Sets Global Array: 79 ; ^TMP("GMPLHS",$J,CNT,"C",LOCATION,NOTE NMBR,0) 80 ; 81 ; Piece 1: Note Narrative 82 ; 2: Internal Date Note Added 83 ; 3; Name of Note's Author 84 ; 85 N IFN2,IFN3,LOC,NODE S LOC=0 Q:$D(^AUPNPROB(IFN,11))'>0 S IFN2=0 86 F S IFN2=$O(^AUPNPROB(IFN,11,IFN2)) Q:IFN2'>0 D 87 . Q:$D(^AUPNPROB(IFN,11,IFN2,11))'>0 88 . S LOC=+$G(^AUPNPROB(IFN,11,IFN2,0)),IFN3=0 89 . F S IFN3=$O(^AUPNPROB(IFN,11,IFN2,11,IFN3)) Q:IFN3'>0 D 90 . . S NODE=$G(^AUPNPROB(IFN,11,IFN2,11,IFN3,0)) Q:$P(NODE,U,4)']"" 91 . . S ^TMP("GMPLHS",$J,CNT,"C",LOC,$P(NODE,U),0)=$P(NODE,U,3)_U_$P(NODE,U,5)_U_$P($G(^VA(200,+$P(NODE,U,6),0)),U) 92 Q 93 SERV(X,SERV) ; Returns Service Name Abbreviation 94 N ABBREV S ABBREV=$P($G(^DIC(49,+X,0)),U,2) S:ABBREV="" ABBREV=$E($G(SERV),1,5) 95 Q ABBREV
Note:
See TracChangeset
for help on using the changeset viewer.
