| 1 | GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Removed Problems ;4/10/03
|
|---|
| 2 | ;;2.0;Problem List;**28**;Aug 25, 1994
|
|---|
| 3 | EN ; -- 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 | ;
|
|---|
| 11 | GETLIST ; -- 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 | ;
|
|---|
| 19 | DISPLAY ; -- 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 | ;
|
|---|
| 36 | HDR ; -- 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 | ;
|
|---|
| 41 | CONTINUE() ; -- 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 | ;
|
|---|
| 47 | REPLACE ; -- 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 | ;
|
|---|
| 63 | SEL() ; -- 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 | ;
|
|---|
| 71 | SURE() ; -- 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
|
|---|
