GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Removed Problems ;11/14/14 12:18
;;2.0;Problem List;**28,47**;Aug 25, 1994;Build 58
EN ; -- main entry point
N GMPDFN
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 GMPLI,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 GMPLI=1:1:GMPLNO S NUM=$P(GMPLSEL,",",GMPLI) I NUM D
S GMPLNO=$L(GMPLSEL,",")-1,NOW=$$HTFM^XLFDT($H)
F GMPLI=1:1:GMPLNO S NUM=$P(GMPLSEL,",",GMPLI) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLRPTR 3303 printed Nov 22, 2024@17:40:23 Page 2
GMPLRPTR ; SLC/MKB/AJB -- Problem List Report of Removed Problems ;11/14/14 12:18
+1 ;;2.0;Problem List;**28,47**;Aug 25, 1994;Build 58
EN ; -- main entry point
+1 NEW GMPDFN
+2 SET GMPDFN=$$PAT^GMPLX1
if +GMPDFN'>0
QUIT
+3 DO WAIT^DICD
DO GETLIST
+4 IF GMPLIST(0)'>0
WRITE $CHAR(7),!!?10,"No 'removed' problems found for this patient.",!
QUIT
+5 DO DISPLAY
DO REPLACE
+6 KILL GMPDFN,GMPLIST
+7 QUIT
+8 ;
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 GMPLI,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 ;S GMPLNO=$L(GMPLSEL,","),NOW=$$HTFM^XLFDT($H)
+5 ;F GMPLI=1:1:GMPLNO S NUM=$P(GMPLSEL,",",GMPLI) I NUM D
+6 SET GMPLNO=$LENGTH(GMPLSEL,",")-1
SET NOW=$$HTFM^XLFDT($HOROLOG)
+7 FOR GMPLI=1:1:GMPLNO
SET NUM=$PIECE(GMPLSEL,",",GMPLI)
Begin DoDot:1
+8 ; added for Code Set Versioning (CSV)
+9 IF '$$CODESTS^GMPLX(GMPLIST(NUM),DT)
WRITE !!,$$PROBTEXT^GMPLX(GMPLIST(NUM)),!,"has an inactive ICD9 code and will not be replaced."
QUIT
+10 SET DA=GMPLIST(NUM)
SET DR="1.02////P"
SET DIE="^AUPNPROB("
DO ^DIE
+11 SET CHNGE=DA_"^1.02^"_NOW_U_DUZ_"^H^P^Replaced^"_DUZ
+12 DO AUDIT^GMPLX(CHNGE,"")
DO DTMOD^GMPLX(DA)
+13 WRITE !," "_$$PROBTEXT^GMPLX(DA)
End DoDot:1
+14 Begin DoDot:1
+15 NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
+16 QUIT
+17 ;
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
