source: FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFX1.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.9 KB
Line 
1GMRAFX1 ;SLC/DAN Fix existing allergy entries-continued ;10/6/05 11:42
2 ;;4.0;Adverse Reaction Tracking;**17,19,20**;Mar 29, 1996;Build 1
3 ;DBIA SECTION
4 ;10116 - VALM1
5 ;10102 - XQORM1
6 ;10104 - XLFSTR
7 ;10061 - VADPT
8 ;10017 - VALM10
9 ;10118 - VALM
10 ;10026 - DIR
11 ;
12DET ;Detailed listing of selected group
13 N DIR,Y,DTOUT,DUOUT,DIRUT,J,GMRAT,GMRAUT,DFN,GMRA,GMRAL,VADM,CNT,VAERR,K,LEN,NAME,ENTRY,NMBR2,ENMBR,GMRAR
14 S VALMBCK="R",CNT=0
15 K ^TMP($J,LTYPE,"GMRADET"),^TMP($J,LTYPE,"IDX2")
16 S ENMBR=+NMBR ;get number portion of entry
17 S ENTRY=0
18 S GMRAUT=$P(^XTMP("GMRAFX",LTYPE,"IDX",ENMBR),"^"),GMRAT=$P(^XTMP("GMRAFX",LTYPE,"IDX",ENMBR),"^",2)
19 S J=0 F S J=$O(^XTMP("GMRAFX",LTYPE,"GMRAR",GMRAUT,GMRAT,J)) Q:'+J D
20 .S DFN=$P($G(^GMR(120.8,J,0)),"^"),GMRA="0^0^111" D ^GMRADPT ;Get patient allergies
21 .D DEM^VADPT ;Get patient information
22 .Q:$G(VAERR) ;Quit if patient lookup produces an error
23 .S CNT=CNT+1,ENTRY=ENTRY+1
24 .S GMRAR(CNT)=VADM(1)_$$REPEAT^XLFSTR(" ",(32-$L(VADM(1))))_$E(VADM(2),6,9)_" "
25 .D SET^VALM10(CNT,ENTRY_$$REPEAT^XLFSTR(" ",(4-$L(ENTRY)))_GMRAR(CNT)) K GMRAR(CNT) ;19
26 .S ^TMP($J,LTYPE,"IDX2",ENTRY)=CNT_"^"_J
27 .S CNT=CNT+1,LEN=0,GMRAR(CNT)="Allergies: "
28 .S K=0 F S K=$O(GMRAL(K)) Q:'+K D
29 ..S NAME=$P(GMRAL(K),"^",2) ;Allergy name
30 ..S LEN=LEN+$L(NAME)+1
31 ..I LEN>70 D SET^VALM10(CNT,GMRAR(CNT)) K GMRAR(CNT) S CNT=CNT+1,LEN=$L(NAME)+1,GMRAR(CNT)=" " ;19
32 ..S GMRAR(CNT)=$G(GMRAR(CNT))_NAME_$S($O(GMRAL(K)):"~",1:"") D:'$O(GMRAL(K)) SET^VALM10(CNT,GMRAR(CNT)) ;19
33 S VALMCNT=CNT,^TMP($J,LTYPE,"IDX2",0)=ENTRY
34 Q
35 ;
36HDR ; -- header code
37 S VALMHDR(1)="Patient listing for reactant "_$S(+$G(NMBR):$P(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR),"^"),1:"")
38 Q
39 ;
40PHDR ;
41 S VALMSG="Select a patient"
42 S XQORM("#")=$$FIND1^DIC(101,,"BX","GMRA FIX DETAIL MENU") ;19
43 D SHOW^VALM
44 Q
45 ;
46INIT ; -- init variables and list array
47 N DIR
48 I '$G(NMBR) S NMBR=$$GETNUM^GMRAFX3("DET") S:'+NMBR VALMQUIT="" Q:'+NMBR I '$$LOCK^GMRAFX3(+NMBR) S VALMQUIT="" Q
49 I $L($G(NMBR),",")>2 D FULL^VALM1 W !,"Please select",$S('$G(NMBR):"",1:" only")," one entry from the list." S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR S VALMQUIT=1 Q
50 K ^TMP($J,LTYPE,"GMRADET"),^TMP($J,LTYPE,"IDX2")
51 S VALMBCK="",VALMBG=$G(VALMBG,1),VALMCNT=0,VALMWD=80
52 Q
53 ;
54CHKSEL ;Evaluate selection if done by number
55 N J,TMP,DIR,NUM,X,Y
56 S NUM=$P($G(XQORNOD(0)),"=",2) ;get currently selected entries
57 I NUM'="" D
58 .I NUM=$G(NMBR2) D DESELECT Q ;If user selects same entry without taking an entry, unhighlight and stop processing
59 .D DESELECT:$G(NMBR2) ;If user previously selected entries but took no action, unhighlight before highlighting new choices
60 .S NMBR2=$P(XQORNOD(0),"=",2),DIR(0)="L^"_"1:"_$G(^TMP($J,LTYPE,"IDX2",0)),X=NMBR2,DIR("V")="" D ^DIR K DIR
61 .I Y="" D FULL^VALM1 W !,"Invalid selection." D WAIT^GMRAFX3 K NMBR2 Q ;Selection out of range, stop processing
62 .F J=1:1:$L(NMBR2,",")-1 S TMP=$P(NMBR2,",",J) D CNTRL^VALM10(+^TMP($J,LTYPE,"IDX2",TMP),1,+$G(VALMWD),IORVON,IORVOFF)
63 Q
64 ;
65DESELECT ;Un-highlight selected choices
66 N J,TMP
67 F J=1:1:$L($G(NMBR2),",")-1 S TMP=$P(NMBR2,",",J) D CNTRL^VALM10(+^TMP($J,LTYPE,"IDX2",TMP),1,+$G(VALMWD),IORVOFF,IORVOFF)
68 K NMBR2
69 Q
70HELP ; -- help code
71 D FULL^VALM1
72 W !!,"Use AE to add local allergies to the GMR ALLERGY file. This",!,"should only be done if you're sure no existing reactant matches your needs."
73 W !!,"Use EE to mark all selected entries as entered",!,"in error. You may select multiple patients if you like."
74 W !!,"Use UR to update the reactant. Extreme caution should be used when updating",!,"reactants. You may select multiple patients if you like,"
75 W !!,"Use PR to add new allergies for the selected patient in",!,"addition to the ones listed here."
76 W !!,"Use DD to get details about the allergy entry that you're",!,"currently working on for this patient.",!
77 D WAIT^GMRAFX3 S VALMBCK="R"
78 Q
79 ;
80EXIT ; -- exit code
81 K ^TMP($J,LTYPE,"IDX2"),^TMP($J,LTYPE,"GMRADET")
82 Q
83 ;
84EXPND ; -- expand code
85 Q
86 ;
87PROCESS(TYPE) ;API to mark selected entries from the detailed listing as entered in error or update to new reactant
88 N GMRAPA,GMRAJ,DIR,Y,NUM,GMRADONE,ENTRY,GMRAI,STOP,NUM2,GMRAAR
89 S VALMBCK="R" D FULL^VALM1
90 I '$G(NMBR2) S NMBR2=$$GETNUM^GMRAFX3("") Q:'+NMBR2
91 W !!,"You are about to ",$S(TYPE="E":"mark",1:"update")," the selected patient",$S($L(NMBR2,",")>2:"s'",1:"'s"),!
92 S ENTRY=$G(^XTMP("GMRAFX",LTYPE,"IDX",+NMBR))
93 W $P(ENTRY,"^",2)," allergy ",$S(TYPE="E":"as entered in error.",1:"to a new reactant."),!
94 S DIR(0)="Y",DIR("B")="NO",DIR("A")="ARE YOU SURE"
95 S DIR("?")="Once allergies are updated or marked as entered in error it cannot be undone!"
96 S DIR("?",1)="Be sure this is what you want to do."
97 D ^DIR Q:Y'=1 ;Stop if user doesn't answer yes
98 S NUM=+NMBR
99 F GMRAI=1:1:($L(NMBR2,",")-1) D Q:$G(STOP)
100 .S GMRADONE=1
101 .S NUM2=$P(NMBR2,",",GMRAI)
102 .S (GMRAPA,GMRAJ)=$P(^TMP($J,LTYPE,"IDX2",NUM2),U,2) Q:'GMRAPA
103 .D @$S(TYPE="E":"EIE^GMRAFX",1:"UIE^GMRAFX3")
104 .D:$G(GMRADONE) UPDATE^GMRAFX3
105 Q
Note: See TracBrowser for help on using the repository browser.