source: WorldVistAEHR/trunk/r/PROBLEM_LIST-GMPL/GMPLRPTR.m@ 862

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

initial load of WorldVistAEHR
File size: 3.0 KB
Line 
1GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Removed Problems ;4/10/03
2 ;;2.0;Problem List;**28**;Aug 25, 1994
3EN ; -- main entry point
4 S GMPDFN=$$PAT^GMPLX1 Q:+GMPDFN'>0
5 D WAIT^DICD,GETLIST
6 I GMPLIST(0)'>0 W $C(7),!!?10,"No 'removed' problems found for this patient.",! Q
7 D DISPLAY,REPLACE
8 K GMPDFN,GMPLIST
9 Q
10 ;
11GETLIST ; -- build GMPLIST() of removed problems
12 N IFN,CNT,NODE S CNT=0
13 F IFN=0:0 S IFN=$O(^AUPNPROB("AC",+GMPDFN,IFN)) Q:IFN'>0 D
14 . S NODE=$G(^AUPNPROB(IFN,1)) Q:$P(NODE,U,2)'="H"
15 . S CNT=CNT+1,GMPLIST(CNT)=IFN W "."
16 S GMPLIST(0)=CNT
17 Q
18 ;
19DISPLAY ; -- show list on screen
20 N PROBLEM,DATE,USER,NUM,PROV,IDT,AIFN,NODE,DONE,GMPQUIT D HDR
21 F NUM=0:0 S NUM=$O(GMPLIST(NUM)) Q:NUM'>0 D Q:$D(GMPQUIT)
22 . S IFN=GMPLIST(NUM) Q:'IFN
23 . S PROBLEM=$$PROBTEXT^GMPLX(IFN),(DATE,PROV)="" K DONE
24 . ; added for Code Set Versioning (CSV)
25 . I '$$CODESTS^GMPLX(IFN,DT) S PROBLEM="#"_PROBLEM
26 . F IDT=0:0 S IDT=$O(^GMPL(125.8,"AD",IFN,IDT)) Q:IDT'>0 D Q:$D(DONE)
27 . . F AIFN=0:0 S AIFN=$O(^GMPL(125.8,"AD",IFN,IDT,AIFN)) Q:AIFN'>0 D Q:$D(DONE)
28 . . . S NODE=$G(^GMPL(125.8,AIFN,0)) Q:$P(NODE,U,2)'=1.02
29 . . . I $P(NODE,U,6)="H" S DATE=9999999-IDT,PROV=$P(NODE,U,8),DONE=1
30 . I $Y>(IOSL-4) S:'$$CONTINUE GMPQUIT=1 Q:$D(GMPQUIT) D HDR
31 . ; added for Code Set Versioning
32 . N GMPLBUF S GMPLBUF=$S(PROBLEM["#":3,1:4)
33 . W !,NUM,?GMPLBUF,PROBLEM,?51,$$EXTDT^GMPLX(DATE),?60,$$NAME^GMPLX1(PROV)
34 Q
35 ;
36HDR ; -- header code
37 W @IOF,"REMOVED PROBLEMS FOR "_$P(GMPDFN,U,2)_" ("_$P(GMPDFN,U,3)_"):"
38 W !!," Problem",?51,"Removed By Whom",!,$$REPEAT^XLFSTR("-",79)
39 Q
40 ;
41CONTINUE() ; -- end of page prompt
42 N DIR,X,Y
43 S DIR(0)="E",DIR("A")="Press <return> to continue or ^ to exit ..."
44 D ^DIR
45 Q +Y
46 ;
47REPLACE ; -- replace problem on patient's list
48 N GMPLSEL,GMPLNO,NUM,CHNGE,NOW,DA,DR,DIE W !!
49 S GMPLSEL=$$SEL Q:GMPLSEL="^" Q:'$$SURE
50 W !!,"Replacing problem(s) on patient's list ..."
51 S GMPLNO=$L(GMPLSEL,","),NOW=$$HTFM^XLFDT($H)
52 F I=1:1:GMPLNO S NUM=$P(GMPLSEL,",",I) I NUM D
53 . ; added for Code Set Versioning (CSV)
54 . I '$$CODESTS^GMPLX(GMPLIST(NUM),DT) W !!,$$PROBTEXT^GMPLX(GMPLIST(NUM)),!,"has an inactive ICD9 code and will not be replaced." Q
55 . S DA=GMPLIST(NUM),DR="1.02////P",DIE="^AUPNPROB(" D ^DIE
56 . S CHNGE=DA_"^1.02^"_NOW_U_DUZ_"^H^P^Replaced^"_DUZ
57 . D AUDIT^GMPLX(CHNGE,""),DTMOD^GMPLX(DA)
58 . W !," "_$$PROBTEXT^GMPLX(DA)
59 D
60 . N DIR S DIR(0)="E" W ! D ^DIR
61 Q
62 ;
63SEL() ; -- select problem(s)
64 N DIR,X,Y,MAX
65 S MAX=+GMPLIST(0) I MAX'>0 Q "^"
66 S DIR(0)="LAO^1:"_MAX,DIR("A")="Select the problem(s) you wish to replace on this patient's list: "
67 S DIR("?",1)="Enter the problems you wish to add back on this patient's problem list,",DIR("?")="as a range or list of numbers."
68 D ^DIR I $D(DTOUT)!(X="") S Y="^"
69 Q Y
70 ;
71SURE() ; -- are you sure you want to do this?
72 N DIR,X,Y
73 S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="NO"
74 S DIR("?",1)="Enter YES if you are ready to have the selected problems put back on this",DIR("?")="patient's problem list; press <return> to exit without further action."
75 W $C(7) D ^DIR
76 Q +Y
Note: See TracBrowser for help on using the repository browser.