source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCARUTL2.m@ 1438

Last change on this file since 1438 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1MCARUTL2 ;HOIFO/WAA-Utility Routine #2;11/29/00 09:55
2 ;;2.3;Medicine;**30**;09/13/1996
3 ;;
4 ;;These APIs are referenced in DBIA 3279
5 ;Input:
6 ; Required:
7 ; ARRAY = Array that data is to be stored in
8 ; DFN = Patient DFN
9 ; SUB = Sub Speciality on file 697.2
10 ; Optional:
11 ; FROM = From date
12 ; TO = To date
13 ;
14SUB(ARRAY,DFN,SUB,FROM,TO) ; Set a Screen for certain Speciality
15 N PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,SUBTXT,FILE,FNAME,FN,IEN,%,I,X
16 N %I,%H,DISYS
17 K ARRAY ; Purge Array
18 S PATNAM="",CNT=0 ; init
19 I DFN'="" S PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I") ; Get patient name
20 I PATNAM="" S ARRAY(CNT)="0^No patient has been defined." Q ; no patient name
21 I '$D(^MCAR(690,DFN,0)) S ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file." Q ; Patient is not in Medicine patient
22 I $G(FROM)="" S FROM=0 ; get from the beginning of time
23 I $G(TO)="" D NOW^%DTC S TO=% ; get to now
24 I SUB="" S ARRAY(CNT)="0^No Procedure defined." Q
25 S SUBTXT=SUB ; if passing Text name saving it
26 I SUB'?1N.N S SUB=$O(^MCAR(697.2,"B",SUB,0))
27 I SUB<1 S ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality." Q
28 ; ^----Will quit id Sub is not found in the 697.2,"B"
29 S SPEC=$G(^MCAR(697.2,SUB,0)) ; Getting Sub Spec
30 I SPEC="" S ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality." Q
31 ; ^--- No Sub Spec.
32 S FILE=$P(SPEC,U,2) ; Extended Reference
33 S FN=$P(FILE,"(",2) ; file Number in MCAR name Range
34 S FNAME=$P(SPEC,U) ; Procedure Name
35 S IEN=0 ; v--- Looping in file FN for Patient DFN
36 F S IEN=$O(^MCAR(FN,"C",DFN,IEN)) Q:IEN<1 D
37 . N LIN
38 . S LIN=$G(^MCAR(FN,IEN,0))
39 . Q:LIN="" ; Invalid entry
40 . ;Filter 699 and 699.5 for valid procedures
41 . I FN=699,$P(LIN,U,12)'=SUB Q
42 . I FN=699.5,$P(LIN,U,6)'=SUB Q
43 . ;Filter dates
44 . S PDATE=$P(LIN,U) ; Procedure date
45 . I PDATE<FROM Q ; quit out of range
46 . I PDATE>TO Q ; quit out of range
47 . S PEDATE=$$FMTE^XLFDT(PDATE,8) ; convert date to external format
48 . S CNT=CNT+1
49 . S ARRAY(CNT)=PEDATE_U_FNAME_U_PATNAM_U_FILE_U_IEN
50 . ; getting Imaging PT
51 . I (+$P($G(^MCAR(FN,IEN,2005,0)),U,3)) N CNT2,IMAGE S (IMAGE,CNT2)=0 F S IMAGE=$O(^MCAR(FN,IEN,2005,IMAGE)) Q:IMAGE<1 D
52 . . N IEN2005
53 . . S IEN2005=$P($G(^MCAR(FN,IEN,2005,IMAGE,0)),U) Q:IEN2005<1
54 . . S CNT2=CNT2+1
55 . . S ARRAY(CNT,2005,CNT2)=IEN2005
56 . . Q
57 . ; ^------ Building Array for entry
58 . I $D(ARRAY(CNT,2005,1)) S ARRAY(CNT)=ARRAY(CNT)_U_"1"_U
59 . E S ARRAY(CNT)=ARRAY(CNT)_U_"0"_U
60 . Q
61 I CNT<1 S ARRAY(CNT)="0^No "_FNAME_" procedure found for Patient "_PATNAM
62 ; ^------- No entries found for patient
63 E S ARRAY(0)="1^"_CNT_" "_FNAME_" Procedure"_$S(CNT=1:"",1:"s")_" found for Patient "_PATNAM
64 ; ^------- Processing 0 node on array if data was found
65 S ARRAY=CNT ; passing total number of entries found for patient
66 Q
67PATLK() ; Lookup patient in medicine file.
68 N DIC,X,Y,DILN,%,I,%I,DGMT,DGMTE,DGWRT,DISYS,DST,DGNOCOPF
69 S DIC="^MCAR(690,",DIC(0)="AEMQ"
70 D ^DIC
71 Q +Y
72PATSUB(ARRAY,DFN) ; Find all Subs for a patient
73 N PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,IMAGE,SUBTXT,FILE,FNAME,FN,IEN,SUB,DISYS
74 K ARRAY ; Purge Array
75 S PATNAM="",CNT=0 ; init
76 I DFN'="" S PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I") ; Get patient name
77 I PATNAM="" S ARRAY(CNT)="0^No patient has been defined." Q ; no patient name
78 I '$D(^MCAR(690,DFN,0)) S ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file." Q ; Patient is not in Medicine patient
79 S SUB=0
80 F S SUB=$O(^MCAR(697.2,SUB)) Q:SUB<1 D
81 . ; Go thur all the entries in 697.2
82 . N LN,IEN,PCNT
83 . S LN=$G(^MCAR(697.2,SUB,0)) ; insure that the entry is valid
84 . Q:LN=""
85 . S FILE=$P(LN,U,2) ; get the MCAR file name
86 . S FN=$P(FILE,"(",2) ; get the file number
87 . S FNAME=$P(LN,U) ; get the procedure name
88 . Q:'$D(^MCAR(FN,"C",DFN)) ; quit if there is no entry for that patient
89 . S PCNT=$$VALDT(DFN,FN,SUB) I PCNT=0 Q ; Validate that there are SUBs
90 . S CNT=CNT+1
91 . S ARRAY(CNT)=FNAME_U_SUB_U_PCNT ; Build array string
92 . Q
93 S ARRAY=CNT
94 I CNT=0 S ARRAY(CNT)="0^There are no Procedures on file for "_PATNAM
95 E S ARRAY=CNT S ARRAY(0)="1^There were "_CNT_" procedures found for patient "_PATNAM
96 Q
97VALDT(DFN,FN,SUB) ; Validate that there is a report for that patient
98 N ANS,IEN
99 S (ANS,IEN)=0 ; Init
100 F S IEN=$O(^MCAR(FN,"C",DFN,IEN)) Q:IEN<1 D
101 . ; Loop thru and validate each entry for a subspeciality
102 . N LIN ; init
103 . S LIN=$G(^MCAR(FN,IEN,0)) ; check the 0 node valid
104 . Q:LIN="" ; Invalid entry
105 . ;Filter 699 and 699.5 for valid procedures
106 . I FN=699,$P(LIN,U,12)'=SUB Q
107 . I FN=699.5,$P(LIN,U,6)'=SUB Q
108 . S ANS=ANS+1 ; If it is valid then add 1 to the count
109 . Q
110 Q ANS ; pass back the total number of valid entries found
Note: See TracBrowser for help on using the repository browser.