source: FOIAVistA/trunk/r/PROBLEM_LIST-GMPL/GMPLX1.m@ 800

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

initial load of FOIAVistA 6/30/08 version
File size: 6.5 KB
Line 
1GMPLX1 ; SLC/MKB/KER -- Problem List Person Utilities ; 04/15/2002
2 ;;2.0;Problem List;**3,26**;Aug 25, 1994
3 ;
4 ; External References
5 ; DBIA 348 ^DPT(
6 ; DBIA 3106 ^DIC(49
7 ; DBIA 872 ^ORD(101
8 ; DBIA 10060 ^VA(200
9 ; DBIA 10062 7^VADPT
10 ; DBIA 10062 DEM^VADPT
11 ; DBIA 2716 $$GETSTAT^DGMSTAPI
12 ; DBIA 3457 $$GETCUR^DGNTAPI
13 ; DBIA 10104 $$REPEAT^XLFSTR
14 ; DBIA 10006 ^DIC
15 ; DBIA 10018 ^DIE
16 ; DBIA 10026 ^DIR
17 ;
18PAT() ; Select patient -- returns DFN^NAME^BID
19 N DIC,X,Y,DFN,VADM,VA,PAT
20P1 S DIC="^AUPNPAT(",DIC(0)="AEQM" D ^DIC I +Y<1 Q -1
21 I $P(Y,U,2)'=$P(^DPT(+Y,0),U) W $C(7),!!,"ERROR -- Please check your Patient Files #2 and #9000001 for inconsistencies.",! G P1
22 S DFN=+Y,PAT=Y D DEM^VADPT
23 S PAT=PAT_U_$E($P(PAT,U,2))_VA("BID"),AUPNSEX=$P(VADM(5),U)
24 I VADM(6) S PAT=PAT_U_+VADM(6) ; date of death
25 Q PAT
26 ;
27VADPT(DFN) ; Get Service/Elig Flags
28 ;
29 ; Returns = 1/0/"" if Y/N/unknown
30 ; GMPSC Service Connected
31 ; GMPAGTOR Agent Orange Exposure
32 ; GMPION Ionizing Radiation Exposure
33 ; GMPGULF Persian Gulf Exposure
34 ; GMPMST Military Sexual Trauma
35 ; GMPHNC Head and/or Neck Cancer
36 ;
37 N VAEL,VASV,VAERR,HNC,X D 7^VADPT S GMPSC=VAEL(3),GMPAGTOR=VASV(2)
38 S GMPION=VASV(3),X=$P($G(^DPT(DFN,.322)),U,10),GMPGULF=$S(X="Y":1,X="N":0,1:"")
39 S X=$P($$GETSTAT^DGMSTAPI(DFN),"^",2),GMPMST=$S(X="Y":1,X="N":0,1:"")
40 S X=$$GETCUR^DGNTAPI(DFN,"HNC"),X=+($G(HNC("STAT"))),GMPHNC=$S(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
41 Q
42SCS(PROB,SC) ; Get Exposure/Conditions Strings
43 ;
44 ; Input PROB Pointer to Problem #9000011
45 ;
46 ; Returns SC Array passed by reference
47 ; SC(1)="AO/IR/EC/HNC/MST"
48 ; SC(2)="A/I/E/H/M"
49 ; SC(3)="AIEHM"
50 ;
51 ; NOTE: Military Sexual Trauma (MST) is suppressed
52 ; if the current device is a printer.
53 ;
54 N ND,DA,FL,AO,IR,EC,HNC,MST,PTR S DA=+($G(PROB)) Q:+DA=0
55 S ND=$G(^AUPNPROB(+DA,1)),AO=+($P(ND,"^",11)),IR=+($P(ND,"^",12))
56 S EC=+($P(ND,"^",13)),HNC=+($P(ND,"^",15)),MST=+($P(ND,"^",16))
57 S PTR=$$PTR^GMPLUTL4
58 I +AO>0 D
59 . S:$G(SC(1))'["AO" SC(1)=$G(SC(1))_"/AO" S:$G(SC(2))'["A" SC(2)=$G(SC(2))_"/A" S:$G(SC(3))'["A" SC(3)=$G(SC(3))_"A"
60 I +IR>0 D
61 . S:$G(SC(1))'["IR" SC(1)=$G(SC(1))_"/IR" S:$G(SC(2))'["I" SC(2)=$G(SC(2))_"/I" S:$G(SC(3))'["I" SC(3)=$G(SC(3))_"I"
62 I +EC>0 D
63 . S:$G(SC(1))'["EC" SC(1)=$G(SC(1))_"/EC" S:$G(SC(2))'["E" SC(2)=$G(SC(2))_"/E" S:$G(SC(3))'["E" SC(3)=$G(SC(3))_"E"
64 I +HNC>0 D
65 . S:$G(SC(1))'["HNC" SC(1)=$G(SC(1))_"/HNC" S:$G(SC(2))'["H" SC(2)=$G(SC(2))_"/H" S:$G(SC(3))'["H" SC(3)=$G(SC(3))_"H"
66 I +PTR'>0 D
67 . I +MST>0 S:$G(SC(1))'["MST" SC(1)=$G(SC(1))_"/MST" S:$G(SC(2))'["M" SC(2)=$G(SC(2))_"/M" S:$G(SC(3))'["M" SC(3)=$G(SC(3))_"M"
68 S:$D(SC(1)) SC(1)=$$RS(SC(1)) S:$D(SC(2)) SC(2)=$$RS(SC(2))
69 Q
70SCCOND(DFN,SC) ; Get Service/Elig Flags (array)
71 ; Returns local array .SC passed by value
72 N HNC,VAEL,VASV,VAERR,X D 7^VADPT
73 S SC("DFN")=$G(DFN),SC("SC")=$P(VAEL(3),"^",1)
74 S SC("AO")=$P(VASV(2),"^",1)
75 S SC("IR")=$P(VASV(3),"^",1)
76 S X=$P($G(^DPT(DFN,.322)),U,10),SC("PG")=$S(X="Y":1,X="N":0,1:"")
77 S X=$P($$GETSTAT^DGMSTAPI(DFN),"^",2),SC("MST")=$S(X="Y":1,X="N":0,1:"")
78 S X=$$GETCUR^DGNTAPI(DFN,"HNC"),X=+($G(HNC("STAT"))),SC("HNC")=$S(X=4:1,X=5:1,X=1:0,X=6:0,1:"")
79 Q
80 ;
81CKDEAD(DATE) ; Dead patient ... continue? Returns 1 if YES, 0 otherwise
82 N DIR,X,Y S DIR(0)="YA",DIR("B")="NO"
83 S DIR("A")="Are you sure you want to continue? "
84 S DIR("?",1)=" Enter YES to continue and add new problem(s) for this patient:",DIR("?")=" press <return> to select another action."
85 W $C(7),!!,"DATE OF DEATH: "_$$EXTDT^GMPLX(DATE)
86 D ^DIR
87 Q +Y
88 ;
89REQPROV() ; Returns requesting provider
90 N DIR,X,Y
91 I $D(GMPLUSER) S Y=DUZ_U_$P(^VA(200,DUZ,0),U) Q Y
92 S DIR("?")="Enter the name of the provider responsible for this data."
93 S DIR(0)="PA^200:AEQM",DIR("A")="Provider: "
94 S:$G(GMPROV) DIR("B")=$P(GMPROV,U,2) W ! D ^DIR
95 I $D(DUOUT)!($D(DTOUT))!(+Y'>0) Q -1
96 Q Y
97 ;
98NAME(USER) ; Formats user name into "Lastname,F"
99 N NAME,LAST,FIRST
100 S NAME=$P($G(^VA(200,+USER,0)),U) I '$L(NAME) Q ""
101 S LAST=$P(NAME,","),FIRST=$P(NAME,",",2)
102 S:$E(FIRST)=" " FIRST=$E(FIRST,2,99)
103 Q $E(LAST,1,15)_","_$E(FIRST)
104 ;
105SERVICE(USER) ; Returns User's service/section from file #49
106 N X S X=+$P($G(^VA(200,USER,5)),U)
107 I $P($G(^DIC(49,X,0)),U,9)'="C" S X=0
108 S:X>0 X=X_U_$P($G(^DIC(49,X,0)),U) S:X'>0 X=""
109 Q X
110 ;
111SERV(X) ; Return service name abbreviation
112 N NODE,ABBREV
113 S NODE=$G(^DIC(49,+X,0)) I NODE="" Q ""
114 S ABBREV=$P(NODE,U,2) I ABBREV="" S ABBREV=$E($P(NODE,U),1,4)
115 Q ABBREV_"/"
116 ;
117CLINIC(LAST) ; Returns clinic from file #44
118 N X,Y,DIC,DIR S Y="" G:$E(GMPLVIEW("VIEW"))="S" CLINQ
119 S DIR(0)="FAO^1:30",DIR("A")="Clinic: " S:$L(LAST) DIR("B")=$P(LAST,U,2)
120 S DIR("?")="Enter the clinic to be associated with these problems, if available"
121 S DIR("??")="^D LISTCLIN^GMPLMGR1 W !,DIR(""?"")_""."""
122CLIN1 ; Ask Clinic
123 D ^DIR S:$D(DUOUT)!($D(DTOUT)) Y="^" S:Y="@" Y="" G:("^"[Y) CLINQ
124 S DIC="^SC(",DIC(0)="EMQ",DIC("S")="I $P(^(0),U,3)=""C"""
125 D ^DIC I Y'>0 W !?5,"Only clinics are allowed!",! G CLIN1
126CLINQ ; Quit Asking
127 Q Y
128 ;
129VIEW(USER) ; Returns user's preferred view
130 N X S X=$P($G(^VA(200,USER,125)),U)
131 Q X
132 ;
133VOCAB() ; Select search vocabulary
134 N DIR,X,Y S DIR(0)="SAOM^N:NURSING;I:IMMUNOLOGIC;D:DENTAL;S:SOCIAL WORK;P:GENERAL PROBLEM"
135 S DIR("A")="Select Specialty Subset: ",DIR("B")="GENERAL PROBLEM"
136 S DIR("?",1)="Because many discipline-specific terms are synonyms to other terms,"
137 S DIR("?",2)="they are not accessible unless you specify the appropriate subset of the"
138 S DIR("?",3)="Clinical Lexicon to select from. Choose from: Nursing"
139 S DIR("?",4)=$$REPEAT^XLFSTR(" ",48)_"Immunologic"
140 S DIR("?",5)=$$REPEAT^XLFSTR(" ",48)_"Dental"
141 S DIR("?",6)=$$REPEAT^XLFSTR(" ",48)_"Social Work"
142 S DIR("?")=$$REPEAT^XLFSTR(" ",48)_"General Problem"
143 D ^DIR S X=$S(Y="N":"NUR",Y="I":"IMM",Y="D":"DEN",Y="S":"SOC",Y="P":"PL1",1:"^")
144 Q X
145 ;
146PARAMS ; Edit pkg parameters in file #125.99
147 N DIE,DA,DR,OLDVERFY,VERFY,BLANK S BLANK=" "
148 S OLDVERFY=+$P($G(^GMPL(125.99,1,0)),U,2)
149 S DIE="^GMPL(125.99,",DA=1,DR="1:6" D ^DIE
150 Q:+$P($G(^GMPL(125.99,1,0)),U,2)=OLDVERFY
151 S DA(1)=$O(^ORD(101,"B","GMPL PROBLEM LIST",0)) Q:'DA(1)
152 S VERFY=$O(^ORD(101,"B","GMPL VERIFY",0)) W "."
153 S DA=$O(^ORD(101,DA(1),10,"B",VERFY,0)) Q:'DA
154 S DR=$S(OLDVERFY:"2///@;6///^S X=BLANK",1:"2////$;6///@") W "."
155 S DIE="^ORD(101,"_DA(1)_",10,"
156 D ^DIE W "."
157 Q
158RS(X) ; Remove Slashes
159 S X=$G(X) F Q:$E(X,1)'="/" S X=$E(X,2,$L(X))
160 F Q:$E(X,$L(X))'="/" S X=$E(X,1,($L(X)-1))
161 Q X
Note: See TracBrowser for help on using the repository browser.