source: FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGDMEDL.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1MAGDMEDL ;WOIFO/LB - Routine to look up entries in the Medicine files ; 05/16/2005 09:18
2 ;;3.0;IMAGING;**51**;26-August-2005
3 ;; +---------------------------------------------------------------+
4 ;; | Property of the US Government. |
5 ;; | No permission to copy or redistribute this software is given. |
6 ;; | Use of unreleased versions of this software requires the user |
7 ;; | to execute a written test agreement with the VistA Imaging |
8 ;; | Development Office of the Department of Veterans Affairs, |
9 ;; | telephone (301) 734-0100. |
10 ;; | |
11 ;; | The Food and Drug Administration classifies this software as |
12 ;; | a medical device. As such, it may not be changed in any way. |
13 ;; | Modifications to this software may result in an adulterated |
14 ;; | medical device under 21CFR820, the use of which is considered |
15 ;; | to be a violation of US Federal Statutes. |
16 ;; +---------------------------------------------------------------+
17 ;;
18 Q
19SELECT(ITEM,ARRAY) ;
20 ;
21 N CNT,DIR,DIROUT,DIRUT,ENTRY
22 S CNT=+ARRAY
23 I 'CNT Q 0
24 S DIR(0)="NO^1:"_CNT,DIR("A")="Select a Medicine Procedure"
25 S DIR("T")=600 D ^DIR
26 I $D(DIRUT)!($D(DIROUT)) Q 0
27 S ENTRY=+Y
28 I '$D(ARRAY(ENTRY)) D G SELECT
29 . W !,"Please select an entry or use '^' to exit"
30 W !,"You have selected ",$P(ARRAY(ENTRY),"^"),"."
31 Q $P(ARRAY(ENTRY),"^",2)
32 ;
33LOOP(ARRAY,MAGPAT,SUB,CASEDT) ;
34 ; MAGPAT = patient's dfn
35 ; SUB = Medicine specialty
36 ; CASEDT = case date
37 ; array(0)= 1 or 0 ^ # entries found ^ message text
38 ; array(#)= formatted out display without delimiters
39 ; array(#,1) = internal stored values
40 ; Variable MAGDIMG
41 S ARRAY(0)="0^^No entries found"
42 Q:'MAGPAT
43 Q:'$D(MAGMC)#10 ;Array should be available.
44 N BEG,CDT,CNT,DATA,DICOM,EN,END,IMG,IMAGEPTR,MAGDIMG,PATIENT,PATNME,PRC,PRCNM,SSN,THEDT,X1,X2,X
45 N IEN,II,IOUT,MAGMC,MEDFILE
46 Q:'$$FIND1^DIC(2,,"A",MAGPAT,"","")
47 S PATNME=$P(^DPT(MAGPAT,0),"^"),SSN=$P(^(0),"^",9)
48 S PATIENT=PATNME_" "_SSN
49 I 'CASEDT S CASEDT=DT
50 S X1=CASEDT,X2=-3 D C^%DTC S BEG=X
51 S END=CASEDT+.9999
52 S CNT=0,CDT=BEG-.001
53 F S CDT=$O(MAGMC(MAGPAT,SUB,CDT)) Q:'CDT!(CDT>END) D
54 . S EN=0 F S EN=$O(MAGMC(MAGPAT,SUB,CDT,EN)) Q:'EN D
55 . . S DATA=MAGMC(MAGPAT,SUB,CDT,EN)
56 . . S PRCNM=$P(DATA,"^",2),PRC=SUB
57 . . S THEDT=$P(DATA,"^"),IEN=$P(DATA,"^",5)
58 . . I $D(MAGMC(MAGPAT,SUB,CDT,EN,2005)) S (IOUT,II)=0 D
59 . . . F S II=$O(MAGMC(MAGPAT,SUB,CDT,EN,2005,II)) Q:'II!IOUT D
60 . . . . S IMAGEPTR=MAGMC(MAGPAT,SUB,CDT,EN,2005,II)
61 . . . . I '$D(^MAG(2005,IMAGEPTR)) S IMAGEPTR="" Q
62 . . . . I '$D(^MAG(2005,IMAGEPTR,"PACS")) S IMAGEPTR="",IOUT=1
63 . . S MEDFILE=$P(DATA,"^",4),MEDFILE=$P(MEDFILE,"MCAR(",2)
64 . . S DICOM="" D DICOMID^MAGDMEDI(.DICOM,MEDFILE,IEN,PRC,MAGPAT)
65 . . I DICOM'="" D
66 . . . S DICOM=$P(DICOM,":",2)
67 . . . S CNT=CNT+1
68 . . . S ARRAY(CNT)=DICOM_" "_PRCNM_", "_THEDT_" "_PATIENT
69 . . . S ARRAY(CNT,1)=DICOM_"^"_PATNME_"^"_SSN_"^"_EN_"^"_PRCNM_"^"_PRC_"^"_$G(IMAGEPTR)_"^"_MEDFILE
70 I CNT S ARRAY(0)="1^"_CNT_"^Medicine file entries for "_PATIENT
71 Q
72DISPLAY(ARRAY) ;
73 ; Call routine needs to pass array in the following sequence
74 ; ARRAY(0)= 1 or 0 ^ #entries ^ message
75 ; ARRAY(#)= Formatted output to be displayed.
76 ; Will set the RES variable for selected entry.
77 I '$D(ARRAY(0)) Q 0
78 ; If only one entry return the subscript variable.
79 I $P(ARRAY(0),"^",2)=1 Q 1
80 I $P(ARRAY(0),"^")'=1 Q 0
81 N ENTRY,ITEM,ITEMS,MSG,OUT,OUTPUT,RES
82 S RES=0,MSG=$P(ARRAY(0),"^",3)
83 S IOF="#,$C(27,91,72,27,91,74,8,8,8,8)",IO=0,IOSL=24,POP=0
84 D HEAD
85 S (ENTRY,OUT)=0,ITEMS=$P(ARRAY(0),"^",2)
86 F S ENTRY=$O(ARRAY(ENTRY)) Q:'ENTRY!OUT D
87 . S OUTPUT=$G(ARRAY(ENTRY))
88 . D:$Y+3>IOSL HEAD D LINE
89 . D:$Y+3>IOSL ASKQ
90 I 'OUT D ASKQ S RES=ITEM
91 Q RES
92HEAD ;
93 W:$Y+3>IOSL @IOF W !,MSG
94 Q
95LINE ;
96 W !,ENTRY,".) "_OUTPUT
97 Q
98ASKQ ;
99 N X,Y,DIR
100 S DIR(0)="L^1:"_$S('ENTRY:ITEMS,1:ENTRY)
101 S DIR("T")=600,DIR("A")="Select an entry: " D ^DIR
102 S ITEM=+Y
103 Q:$D(DIRUT)!($D(DIROUT))
104 Q:'ITEM
105 I '$D(ARRAY(ITEM)) W !,"Please select an entry or '^' to exit" G ASKQ
106 W !,"You have selected ",$P($G(ARRAY(ITEM)),"^")
107 S OUT=1
108 Q
109ASKMORE() ;
110 N DIR,DATE,X,XX,Y
111 Q:'$D(MAGPAT)
112 Q:'$D(SUB)
113 S DIR(0)="Y",DIR("B")="NO"
114 S DIR("A")="Search further"
115 D ^DIR K DIR
116 I 'Y Q 0
117 W !,"Search will include 3 days prior to the day specified."
118 S DIR(0)="D^::EXP" D ^DIR
119 ; Y2K compliance all calls to %DT must have either past or future date
120 I 'Y Q 0
121 S DATE=Y
122 D LOOP(.XX,MAGPAT,SUB,DATE)
123 I $D(XX(0)),$P(XX(0),"^")=0 D Q 0
124 . W "No entries found."
125 Q 1
Note: See TracBrowser for help on using the repository browser.