GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Removed Problems ;4/10/03
;;2.0;Problem List;**28**;Aug 25, 1994
EN ; -- main entry point
S GMPDFN=$$PAT^GMPLX1 Q:+GMPDFN'>0
D WAIT^DICD,GETLIST
I GMPLIST(0)'>0 W $C(7),!!?10,"No 'removed' problems found for this patient.",! Q
D DISPLAY,REPLACE
K GMPDFN,GMPLIST
Q
;
GETLIST ; -- build GMPLIST() of removed problems
N IFN,CNT,NODE S CNT=0
F IFN=0:0 S IFN=$O(^AUPNPROB("AC",+GMPDFN,IFN)) Q:IFN'>0 D
. S NODE=$G(^AUPNPROB(IFN,1)) Q:$P(NODE,U,2)'="H"
. S CNT=CNT+1,GMPLIST(CNT)=IFN W "."
S GMPLIST(0)=CNT
Q
;
DISPLAY ; -- show list on screen
N PROBLEM,DATE,USER,NUM,PROV,IDT,AIFN,NODE,DONE,GMPQUIT D HDR
F NUM=0:0 S NUM=$O(GMPLIST(NUM)) Q:NUM'>0 D Q:$D(GMPQUIT)
. S IFN=GMPLIST(NUM) Q:'IFN
. S PROBLEM=$$PROBTEXT^GMPLX(IFN),(DATE,PROV)="" K DONE
. ; added for Code Set Versioning (CSV)
. I '$$CODESTS^GMPLX(IFN,DT) S PROBLEM="#"_PROBLEM
. F IDT=0:0 S IDT=$O(^GMPL(125.8,"AD",IFN,IDT)) Q:IDT'>0 D Q:$D(DONE)
. . F AIFN=0:0 S AIFN=$O(^GMPL(125.8,"AD",IFN,IDT,AIFN)) Q:AIFN'>0 D Q:$D(DONE)
. . . S NODE=$G(^GMPL(125.8,AIFN,0)) Q:$P(NODE,U,2)'=1.02
. . . I $P(NODE,U,6)="H" S DATE=9999999-IDT,PROV=$P(NODE,U,8),DONE=1
. I $Y>(IOSL-4) S:'$$CONTINUE GMPQUIT=1 Q:$D(GMPQUIT) D HDR
. ; added for Code Set Versioning
. N GMPLBUF S GMPLBUF=$S(PROBLEM["#":3,1:4)
. W !,NUM,?GMPLBUF,PROBLEM,?51,$$EXTDT^GMPLX(DATE),?60,$$NAME^GMPLX1(PROV)
Q
;
HDR ; -- header code
W @IOF,"REMOVED PROBLEMS FOR "_$P(GMPDFN,U,2)_" ("_$P(GMPDFN,U,3)_"):"
W !!," Problem",?51,"Removed By Whom",!,$$REPEAT^XLFSTR("-",79)
Q
;
CONTINUE() ; -- end of page prompt
N DIR,X,Y
S DIR(0)="E",DIR("A")="Press <return> to continue or ^ to exit ..."
D ^DIR
Q +Y
;
REPLACE ; -- replace problem on patient's list
N GMPLSEL,GMPLNO,NUM,CHNGE,NOW,DA,DR,DIE W !!
S GMPLSEL=$$SEL Q:GMPLSEL="^" Q:'$$SURE
W !!,"Replacing problem(s) on patient's list ..."
S GMPLNO=$L(GMPLSEL,","),NOW=$$HTFM^XLFDT($H)
F I=1:1:GMPLNO S NUM=$P(GMPLSEL,",",I) I NUM D
. ; added for Code Set Versioning (CSV)
. I '$$CODESTS^GMPLX(GMPLIST(NUM),DT) W !!,$$PROBTEXT^GMPLX(GMPLIST(NUM)),!,"has an inactive ICD9 code and will not be replaced." Q
. S DA=GMPLIST(NUM),DR="1.02////P",DIE="^AUPNPROB(" D ^DIE
. S CHNGE=DA_"^1.02^"_NOW_U_DUZ_"^H^P^Replaced^"_DUZ
. D AUDIT^GMPLX(CHNGE,""),DTMOD^GMPLX(DA)
. W !," "_$$PROBTEXT^GMPLX(DA)
D
. N DIR S DIR(0)="E" W ! D ^DIR
Q
;
SEL() ; -- select problem(s)
N DIR,X,Y,MAX
S MAX=+GMPLIST(0) I MAX'>0 Q "^"
S DIR(0)="LAO^1:"_MAX,DIR("A")="Select the problem(s) you wish to replace on this patient's list: "
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."
D ^DIR I $D(DTOUT)!(X="") S Y="^"
Q Y
;
SURE() ; -- are you sure you want to do this?
N DIR,X,Y
S DIR(0)="Y",DIR("A")="Are you sure you want to do this",DIR("B")="NO"
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."
W $C(7) D ^DIR
Q +Y
GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Removed Problems ;4/10/03
+1 ;;2.0;Problem List;**28**;Aug 25, 1994
EN ; -- main entry point
+1 SET GMPDFN=$$PAT^GMPLX1
IF +GMPDFN'>0
QUIT
+2 DO WAIT^DICD
DO GETLIST
+3 IF GMPLIST(0)'>0
WRITE $CHAR(7),!!?10,"No 'removed' problems found for this patient.",!
QUIT
+4 DO DISPLAY
DO REPLACE
+5 KILL GMPDFN,GMPLIST
+6 QUIT
+7 ;
GETLIST ; -- build GMPLIST() of removed problems
+1 NEW IFN,CNT,NODE
SET CNT=0
+2 FOR IFN=0:0
SET IFN=$ORDER(^AUPNPROB("AC",+GMPDFN,IFN))
IF IFN'>0
QUIT
Begin DoDot:1
+3 SET NODE=$GET(^AUPNPROB(IFN,1))
IF $PIECE(NODE,U,2)'="H"
QUIT
+4 SET CNT=CNT+1
SET GMPLIST(CNT)=IFN
WRITE "."
End DoDot:1
+5 SET GMPLIST(0)=CNT
+6 QUIT
+7 ;
DISPLAY ; -- show list on screen
+1 NEW PROBLEM,DATE,USER,NUM,PROV,IDT,AIFN,NODE,DONE,GMPQUIT
DO HDR
+2 FOR NUM=0:0
SET NUM=$ORDER(GMPLIST(NUM))
IF NUM'>0
QUIT
Begin DoDot:1
+3 SET IFN=GMPLIST(NUM)
IF 'IFN
QUIT
+4 SET PROBLEM=$$PROBTEXT^GMPLX(IFN)
SET (DATE,PROV)=""
KILL DONE
+5 ; added for Code Set Versioning (CSV)
+6 IF '$$CODESTS^GMPLX(IFN,DT)
SET PROBLEM="#"_PROBLEM
+7 FOR IDT=0:0
SET IDT=$ORDER(^GMPL(125.8,"AD",IFN,IDT))
IF IDT'>0
QUIT
Begin DoDot:2
+8 FOR AIFN=0:0
SET AIFN=$ORDER(^GMPL(125.8,"AD",IFN,IDT,AIFN))
IF AIFN'>0
QUIT
Begin DoDot:3
+9 SET NODE=$GET(^GMPL(125.8,AIFN,0))
IF $PIECE(NODE,U,2)'=1.02
QUIT
+10 IF $PIECE(NODE,U,6)="H"
SET DATE=9999999-IDT
SET PROV=$PIECE(NODE,U,8)
SET DONE=1
End DoDot:3
IF $DATA(DONE)
QUIT
End DoDot:2
IF $DATA(DONE)
QUIT
+11 IF $Y>(IOSL-4)
IF '$$CONTINUE
SET GMPQUIT=1
IF $DATA(GMPQUIT)
QUIT
DO HDR
+12 ; added for Code Set Versioning
+13 NEW GMPLBUF
SET GMPLBUF=$SELECT(PROBLEM["#":3,1:4)
+14 WRITE !,NUM,?GMPLBUF,PROBLEM,?51,$$EXTDT^GMPLX(DATE),?60,$$NAME^GMPLX1(PROV)
End DoDot:1
IF $DATA(GMPQUIT)
QUIT
+15 QUIT
+16 ;
HDR ; -- header code
+1 WRITE @IOF,"REMOVED PROBLEMS FOR "_$PIECE(GMPDFN,U,2)_" ("_$PIECE(GMPDFN,U,3)_"):"
+2 WRITE !!," Problem",?51,"Removed By Whom",!,$$REPEAT^XLFSTR("-",79)
+3 QUIT
+4 ;
CONTINUE() ; -- end of page prompt
+1 NEW DIR,X,Y
+2 SET DIR(0)="E"
SET DIR("A")="Press <return> to continue or ^ to exit ..."
+3 DO ^DIR
+4 QUIT +Y
+5 ;
REPLACE ; -- replace problem on patient's list
+1 NEW GMPLSEL,GMPLNO,NUM,CHNGE,NOW,DA,DR,DIE
WRITE !!
+2 SET GMPLSEL=$$SEL
IF GMPLSEL="^"
QUIT
IF '$$SURE
QUIT
+3 WRITE !!,"Replacing problem(s) on patient's list ..."
+4 SET GMPLNO=$LENGTH(GMPLSEL,",")
SET NOW=$$HTFM^XLFDT($HOROLOG)
+5 FOR I=1:1:GMPLNO
SET NUM=$PIECE(GMPLSEL,",",I)
IF NUM
Begin DoDot:1
+6 ; added for Code Set Versioning (CSV)
+7 IF '$$CODESTS^GMPLX(GMPLIST(NUM),DT)
WRITE !!,$$PROBTEXT^GMPLX(GMPLIST(NUM)),!,"has an inactive ICD9 code and will not be replaced."
QUIT
+8 SET DA=GMPLIST(NUM)
SET DR="1.02////P"
SET DIE="^AUPNPROB("
DO ^DIE
+9 SET CHNGE=DA_"^1.02^"_NOW_U_DUZ_"^H^P^Replaced^"_DUZ
+10 DO AUDIT^GMPLX(CHNGE,"")
DO DTMOD^GMPLX(DA)
+11 WRITE !," "_$$PROBTEXT^GMPLX(DA)
End DoDot:1
+12 Begin DoDot:1
+13 NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
+14 QUIT
+15 ;
SEL() ; -- select problem(s)
+1 NEW DIR,X,Y,MAX
+2 SET MAX=+GMPLIST(0)
IF MAX'>0
QUIT "^"
+3 SET DIR(0)="LAO^1:"_MAX
SET DIR("A")="Select the problem(s) you wish to replace on this patient's list: "
+4 SET DIR("?",1)="Enter the problems you wish to add back on this patient's problem list,"
SET DIR("?")="as a range or list of numbers."
+5 DO ^DIR
IF $DATA(DTOUT)!(X="")
SET Y="^"
+6 QUIT Y
+7 ;
SURE() ; -- are you sure you want to do this?
+1 NEW DIR,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to do this"
SET DIR("B")="NO"
+3 SET DIR("?",1)="Enter YES if you are ready to have the selected problems put back on this"
SET DIR("?")="patient's problem list; press <return> to exit without further action."
+4 WRITE $CHAR(7)
DO ^DIR
+5 QUIT +Y
