GMPLPRNT ; SLC/MKB,KER,TC -- Problem List prints/displays; 04/15/2002 ;06/08/12 16:13
;;2.0;Problem List;**1,13,26,41,36**;Aug 25, 1994;Build 65
;
; External References
; DBIA 3990 $$ICDDX^ICDCODE
; DBIA 10090 ^DIC(4
; DBIA 10086 ^%ZIS
; DBIA 10086 HOME^%ZIS
; DBIA 10089 ^%ZISC
; DBIA 10063 ^%ZTLOAD
; DBIA 10026 ^DIR
; DBIA 10061 OERR^VADPT
; DBIA 10116 CLEAR^VALM1
; DBIA 10103 $$FMTE^XLFDT
; DBIA 10103 $$NOW^XLFDT
; DBIA 10104 $$REPEAT^XLFSTR
; DBIA 10112 $$SITE^VASITE
;
EN ; Print/Display (Main)
N DIR,X,Y S VALMBCK=$S(VALMCC:"",1:"R") W !
I '(($L(GMPLVIEW("ACT")))!(GMPLVIEW("PROV"))!($L(GMPLVIEW("VIEW"),"/")>2)) S Y="A" G EN1
S DIR(0)="SAOM^C:CURRENT VIEW;A:ALL PROBLEMS;"
S DIR("A")="Print (C)urrently displayed problems only, or include (A)ll problems? "
S DIR("?",1)="Enter C to print a copy of your currently displayed view"
S DIR("?",2)="of this patient's list; to print a complete list of all"
S DIR("?",3)="active and inactive problems, which may be included in"
S DIR("?")="the patient's chart, select A."
D ^DIR G:$D(DTOUT)!($D(DUOUT))!(Y="") ENQ
EN1 ; Print View
W ! D @$S(Y="C":"LIST",1:"VAF")
I GMPRT'>0 W !!,"No problems found.",!,$C(7) H 1 G ENQ
D DEVICE G:$D(GMPQUIT) ENQ
D CLEAR^VALM1,PRT S VALMBCK="R"
ENQ ; Quit Print/Display
D KILL^GMPLX S VALMSG=$$MSG^GMPLX Q
;
VAF ; Build Chart Copy
N TOTAL,VIEW K GMPLCURR S (TOTAL,GMPRT)=0
Q:'$D(^AUPNPROB("AC",+GMPDFN))
S (VIEW("ACT"),VIEW("VIEW"))="",VIEW("PROV")=0
D GETPLIST^GMPLMGR1(.GMPRT,.TOTAL,.VIEW)
S GMPRT=TOTAL
Q
;
LIST ; Build Current View
S GMPLCURR=1,GMPRT=0 Q:+$G(GMPCOUNT)'>0 N I,IFN
W !,"One moment, please ..."
F I=0:0 S I=$O(^TMP("GMPLIDX",$J,I)) Q:I'>0 D
. S IFN=$P($G(^TMP("GMPLIDX",$J,I)),U,2) Q:IFN'>0
. S GMPRT=GMPRT+1,GMPRT(I)=IFN W "."
Q
;
DEVICE ; Get Device
S %ZIS="Q",%ZIS("B")="" D ^%ZIS I POP S GMPQUIT=1 G DQ
I '$D(GMPLCURR) K GMPRINT
I $D(IO("Q")) D
. S ZTRTN="PRT^GMPLPRNT",ZTDESC="PROBLEM LIST OF "_$P(GMPDFN,U,2)
. S (ZTSAVE("GMPRT"),ZTSAVE("GMPRT("),ZTSAVE("GMPDFN"),ZTSAVE("GMPVAMC"))=""
. S:$D(GMPLCURR) ZTSAVE("GMPLCURR")="" S ZTDTH=$H
. D ^%ZTLOAD,HOME^%ZIS S:$D(ZTSK) GMPQUIT=1
DQ ; Quit Device
K IO("Q"),POP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,ZTSK
Q
;
HDR ; Header Code
N PAGE S PAGE="Page: "_GMPLPAGE,GMPLPAGE=GMPLPAGE+1
W $C(13),$$REPEAT^XLFSTR("-",79),!
I IOST?1"P".E W:$D(GMPLCURR) "** NOT for " W "Medical Record" W:$D(GMPLCURR) " **"
I IOST'?1"P".E W $P(GMPDFN,U,2)_" ("_$P(GMPDFN,U,3)_")"
W ?41,"| " W:$D(GMPLCURR) "PARTIAL "
W "PROBLEM LIST",?(79-$L(PAGE)),PAGE,!
W $$REPEAT^XLFSTR("-",79),!
W !," Date",?63,"Date of Date"
W !," Recorded Problems",?64,"Onset Resolved"
W !,$$REPEAT^XLFSTR("-",79)
Q
;
FTR ; Footer Code
N I,SITE,DFN,VA,VADM,LOC,DATE,FORM
F I=1:1:(IOSL-$Y-6) W !
S SITE=$$SITE^VASITE,SITE=$P(SITE,U,2)
S:SITE'["VAMC" SITE=SITE_" VAMC"
S DFN=+GMPDFN D OERR^VADPT
S LOC="Pt Loc: "_$S(VAIN(4)]"":$P(VAIN(4),U,2)_" "_VAIN(5),1:"OUTPATIENT") K VAIN
I $L(LOC)>51 S LOC=$E(LOC,1,51),FORM="VAF10-141"
E S FORM="VA FORM 10-1415"
W !,$S($D(GMPLFLAG):"$ = Requires verification by provider",1:"")
W !,$$REPEAT^XLFSTR("-",79)
W !,$P(GMPDFN,U,2),?(79-$L(SITE)\2),SITE
S DATE=$$FMTE^XLFDT($E(($$NOW^XLFDT),1,12),2)
S DATE="Printed:"_$P(DATE,"@")_" "_$P(DATE,"@",2)
W ?(79-$L(DATE)),DATE
W !,VA("PID"),?(79-$L(LOC)\2),LOC,?(79-$L(FORM)),FORM
W !,$$REPEAT^XLFSTR("-",79),@IOF
Q
;
RETURN() ; End of page
N X,Y,DIR,I F I=1:1:(IOSL-$Y-3) W !
S DIR(0)="E" D ^DIR
Q +Y
;
PRT ; Body of Problem List
U IO N I,IFN,GMPLPAGE,GMPLFLAG S GMPLPAGE=1 D HDR
F I=0:0 S I=$O(GMPRT(I)) Q:I'>0 D Q:$D(GMPQUIT)
. S IFN=GMPRT(I) Q:IFN'>0
. D PROB(IFN,I)
D FTR:IOST?1"P".E I '$D(GMPQUIT),IOST?1"C".E S I=$$RETURN
I $D(ZTQUEUED) S ZTREQ="@" K GMPDFN,GMPLCURR,GMPQUIT,GMPRT
D ^%ZISC
Q
;
PROB(DA,NUM) ; Get Problem Text Line
N GMPL0,GMPL1,GMPL803,ONSET,DATE,TEXT,NOTES,J,RESOLVED,X,LINES,PROB,SCS,SP
S GMPL0=$G(^AUPNPROB(DA,0)),GMPL1=$G(^(1)),GMPL803=$G(^(803,0)) Q:GMPL0="" Q:GMPL1=""
S ONSET=$P(GMPL0,U,13),DATE=$P(GMPL1,U,9),RESOLVED=$P(GMPL1,U,7)
D SCS^GMPLX1(+DA,.SCS) S SP=$G(SCS(3))
I 'DATE S DATE=$P(GMPL0,U,8)
S PROB=$$PROBTEXT^GMPLX(DA)
I PROB[" (SCT"&($L($G(GMPL803))>0) D
. S PROB=PROB_" (ICD-9-CM "_$P($$ICDDX^ICDCODE(+GMPL0),U,2)
. N IEN S IEN=0 F S IEN=$O(^AUPNPROB(DA,803,IEN)) Q:'+IEN D
. . S PROB=PROB_"/"_$P($G(^AUPNPROB(DA,803,IEN,0)),U)
. S PROB=PROB_")"
E I PROB[" (SCT"&($G(GMPL803)="") S PROB=PROB_" (ICD-9-CM "_$P($$ICDDX^ICDCODE(+GMPL0),U,2)_")"
I $P($G(^AUPNPROB(DA,1)),"^",14)="A" S PROB="*"_PROB
E S PROB=" "_PROB
D WRAP^GMPLX(PROB,50,.TEXT)
D NOTES(DA) S LINES=TEXT+NOTES+1
I ($Y+LINES)>(IOSL-7) D Q:$D(GMPQUIT)
. I IOST?1"P".E D FTR,HDR Q
. I $$RETURN W @IOF D HDR Q
. S GMPQUIT=1
PR1 ; Write Problem Text Line
W !!,$E(" ",1,3-$L(NUM))_NUM_". "_$J($$EXTDT^GMPLX(DATE),8)
I $P(GMPL1,U,2)="T",$P($G(^GMPL(125.99,1,0)),U,2) W ?14,"$" S GMPLFLAG=1
W ?15,TEXT(1),?62,$J($$EXTDT^GMPLX(ONSET),8)
I $P(GMPL0,U,12)="I" W ?71,$S(RESOLVED:$J($$EXTDT^GMPLX(RESOLVED),8),1:"unknown")
I TEXT>1 F J=2:1:TEXT W !?15,TEXT(J)
Q:'NOTES S DATE=$P(DATE,".")
F J=1:1:NOTES S X=$S(DATE'=$P(NOTES(J),U):$$EXTDT^GMPLX($P(NOTES(J),U)),1:"") W !?5,$J(X,8),?17,$P(NOTES(J),U,2) S DATE=$P(NOTES(J),U)
Q
NOTES(IFN) ; Place Comments in NOTES array
N I,NOTE,DATE,TEXT,FAC,NIFN S (NOTES,I)=0
Q:'$D(^AUPNPROB(IFN,11))
S FAC=$O(^AUPNPROB(IFN,11,"B",+GMPVAMC,0)) Q:FAC'>0
F NIFN=0:0 S NIFN=$O(^AUPNPROB(IFN,11,FAC,11,"B",NIFN)) Q:NIFN'>0 D
. S NOTE=$G(^AUPNPROB(IFN,11,FAC,11,NIFN,0)) Q:NOTE=""
. S DATE=$P(NOTE,U,5),TEXT=$P(NOTE,U,3),I=I+1
. S NOTES(I)=$P(DATE,".")_U_TEXT
S NOTES=I
Q
GMPLPRNT ; SLC/MKB,KER,TC -- Problem List prints/displays; 04/15/2002 ;06/08/12 16:13
+1 ;;2.0;Problem List;**1,13,26,41,36**;Aug 25, 1994;Build 65
+2 ;
+3 ; External References
+4 ; DBIA 3990 $$ICDDX^ICDCODE
+5 ; DBIA 10090 ^DIC(4
+6 ; DBIA 10086 ^%ZIS
+7 ; DBIA 10086 HOME^%ZIS
+8 ; DBIA 10089 ^%ZISC
+9 ; DBIA 10063 ^%ZTLOAD
+10 ; DBIA 10026 ^DIR
+11 ; DBIA 10061 OERR^VADPT
+12 ; DBIA 10116 CLEAR^VALM1
+13 ; DBIA 10103 $$FMTE^XLFDT
+14 ; DBIA 10103 $$NOW^XLFDT
+15 ; DBIA 10104 $$REPEAT^XLFSTR
+16 ; DBIA 10112 $$SITE^VASITE
+17 ;
EN ; Print/Display (Main)
+1 NEW DIR,X,Y
SET VALMBCK=$SELECT(VALMCC:"",1:"R")
WRITE !
+2 IF '(($LENGTH(GMPLVIEW("ACT")))!(GMPLVIEW("PROV"))!($LENGTH(GMPLVIEW("VIEW"),"/")>2))
SET Y="A"
GOTO EN1
+3 SET DIR(0)="SAOM^C:CURRENT VIEW;A:ALL PROBLEMS;"
+4 SET DIR("A")="Print (C)urrently displayed problems only, or include (A)ll problems? "
+5 SET DIR("?",1)="Enter C to print a copy of your currently displayed view"
+6 SET DIR("?",2)="of this patient's list; to print a complete list of all"
+7 SET DIR("?",3)="active and inactive problems, which may be included in"
+8 SET DIR("?")="the patient's chart, select A."
+9 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="")
GOTO ENQ
EN1 ; Print View
+1 WRITE !
DO @$SELECT(Y="C":"LIST",1:"VAF")
+2 IF GMPRT'>0
WRITE !!,"No problems found.",!,$CHAR(7)
HANG 1
GOTO ENQ
+3 DO DEVICE
IF $DATA(GMPQUIT)
GOTO ENQ
+4 DO CLEAR^VALM1
DO PRT
SET VALMBCK="R"
ENQ ; Quit Print/Display
+1 DO KILL^GMPLX
SET VALMSG=$$MSG^GMPLX
QUIT
+2 ;
VAF ; Build Chart Copy
+1 NEW TOTAL,VIEW
KILL GMPLCURR
SET (TOTAL,GMPRT)=0
+2 IF '$DATA(^AUPNPROB("AC",+GMPDFN))
QUIT
+3 SET (VIEW("ACT"),VIEW("VIEW"))=""
SET VIEW("PROV")=0
+4 DO GETPLIST^GMPLMGR1(.GMPRT,.TOTAL,.VIEW)
+5 SET GMPRT=TOTAL
+6 QUIT
+7 ;
LIST ; Build Current View
+1 SET GMPLCURR=1
SET GMPRT=0
IF +$GET(GMPCOUNT)'>0
QUIT
NEW I,IFN
+2 WRITE !,"One moment, please ..."
+3 FOR I=0:0
SET I=$ORDER(^TMP("GMPLIDX",$JOB,I))
IF I'>0
QUIT
Begin DoDot:1
+4 SET IFN=$PIECE($GET(^TMP("GMPLIDX",$JOB,I)),U,2)
IF IFN'>0
QUIT
+5 SET GMPRT=GMPRT+1
SET GMPRT(I)=IFN
WRITE "."
End DoDot:1
+6 QUIT
+7 ;
DEVICE ; Get Device
+1 SET %ZIS="Q"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
SET GMPQUIT=1
GOTO DQ
+2 IF '$DATA(GMPLCURR)
KILL GMPRINT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTRTN="PRT^GMPLPRNT"
SET ZTDESC="PROBLEM LIST OF "_$PIECE(GMPDFN,U,2)
+5 SET (ZTSAVE("GMPRT"),ZTSAVE("GMPRT("),ZTSAVE("GMPDFN"),ZTSAVE("GMPVAMC"))=""
+6 IF $DATA(GMPLCURR)
SET ZTSAVE("GMPLCURR")=""
SET ZTDTH=$HOROLOG
+7 DO ^%ZTLOAD
DO HOME^%ZIS
IF $DATA(ZTSK)
SET GMPQUIT=1
End DoDot:1
DQ ; Quit Device
+1 KILL IO("Q"),POP,%ZIS,ZTRTN,ZTDESC,ZTSAVE,ZTSK
+2 QUIT
+3 ;
HDR ; Header Code
+1 NEW PAGE
SET PAGE="Page: "_GMPLPAGE
SET GMPLPAGE=GMPLPAGE+1
+2 WRITE $CHAR(13),$$REPEAT^XLFSTR("-",79),!
+3 IF IOST?1"P".E
IF $DATA(GMPLCURR)
WRITE "** NOT for "
WRITE "Medical Record"
IF $DATA(GMPLCURR)
WRITE " **"
+4 IF IOST'?1"P".E
WRITE $PIECE(GMPDFN,U,2)_" ("_$PIECE(GMPDFN,U,3)_")"
+5 WRITE ?41,"| "
IF $DATA(GMPLCURR)
WRITE "PARTIAL "
+6 WRITE "PROBLEM LIST",?(79-$LENGTH(PAGE)),PAGE,!
+7 WRITE $$REPEAT^XLFSTR("-",79),!
+8 WRITE !," Date",?63,"Date of Date"
+9 WRITE !," Recorded Problems",?64,"Onset Resolved"
+10 WRITE !,$$REPEAT^XLFSTR("-",79)
+11 QUIT
+12 ;
FTR ; Footer Code
+1 NEW I,SITE,DFN,VA,VADM,LOC,DATE,FORM
+2 FOR I=1:1:(IOSL-$Y-6)
WRITE !
+3 SET SITE=$$SITE^VASITE
SET SITE=$PIECE(SITE,U,2)
+4 IF SITE'["VAMC"
SET SITE=SITE_" VAMC"
+5 SET DFN=+GMPDFN
DO OERR^VADPT
+6 SET LOC="Pt Loc: "_$SELECT(VAIN(4)]"":$PIECE(VAIN(4),U,2)_" "_VAIN(5),1:"OUTPATIENT")
KILL VAIN
+7 IF $LENGTH(LOC)>51
SET LOC=$EXTRACT(LOC,1,51)
SET FORM="VAF10-141"
+8 IF '$TEST
SET FORM="VA FORM 10-1415"
+9 WRITE !,$SELECT($DATA(GMPLFLAG):"$ = Requires verification by provider",1:"")
+10 WRITE !,$$REPEAT^XLFSTR("-",79)
+11 WRITE !,$PIECE(GMPDFN,U,2),?(79-$LENGTH(SITE)\2),SITE
+12 SET DATE=$$FMTE^XLFDT($EXTRACT(($$NOW^XLFDT),1,12),2)
+13 SET DATE="Printed:"_$PIECE(DATE,"@")_" "_$PIECE(DATE,"@",2)
+14 WRITE ?(79-$LENGTH(DATE)),DATE
+15 WRITE !,VA("PID"),?(79-$LENGTH(LOC)\2),LOC,?(79-$LENGTH(FORM)),FORM
+16 WRITE !,$$REPEAT^XLFSTR("-",79),@IOF
+17 QUIT
+18 ;
RETURN() ; End of page
+1 NEW X,Y,DIR,I
FOR I=1:1:(IOSL-$Y-3)
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
+3 QUIT +Y
+4 ;
PRT ; Body of Problem List
+1 USE IO
NEW I,IFN,GMPLPAGE,GMPLFLAG
SET GMPLPAGE=1
DO HDR
+2 FOR I=0:0
SET I=$ORDER(GMPRT(I))
IF I'>0
QUIT
Begin DoDot:1
+3 SET IFN=GMPRT(I)
IF IFN'>0
QUIT
+4 DO PROB(IFN,I)
End DoDot:1
IF $DATA(GMPQUIT)
QUIT
+5 IF IOST?1"P".E
DO FTR
IF '$DATA(GMPQUIT)
IF IOST?1"C".E
SET I=$$RETURN
+6 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL GMPDFN,GMPLCURR,GMPQUIT,GMPRT
+7 DO ^%ZISC
+8 QUIT
+9 ;
PROB(DA,NUM) ; Get Problem Text Line
+1 NEW GMPL0,GMPL1,GMPL803,ONSET,DATE,TEXT,NOTES,J,RESOLVED,X,LINES,PROB,SCS,SP
+2 SET GMPL0=$GET(^AUPNPROB(DA,0))
SET GMPL1=$GET(^(1))
SET GMPL803=$GET(^(803,0))
IF GMPL0=""
QUIT
IF GMPL1=""
QUIT
+3 SET ONSET=$PIECE(GMPL0,U,13)
SET DATE=$PIECE(GMPL1,U,9)
SET RESOLVED=$PIECE(GMPL1,U,7)
+4 DO SCS^GMPLX1(+DA,.SCS)
SET SP=$GET(SCS(3))
+5 IF 'DATE
SET DATE=$PIECE(GMPL0,U,8)
+6 SET PROB=$$PROBTEXT^GMPLX(DA)
+7 IF PROB[" (SCT"&($LENGTH($GET(GMPL803))>0)
Begin DoDot:1
+8 SET PROB=PROB_" (ICD-9-CM "_$PIECE($$ICDDX^ICDCODE(+GMPL0),U,2)
+9 NEW IEN
SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPROB(DA,803,IEN))
IF '+IEN
QUIT
Begin DoDot:2
+10 SET PROB=PROB_"/"_$PIECE($GET(^AUPNPROB(DA,803,IEN,0)),U)
End DoDot:2
+11 SET PROB=PROB_")"
End DoDot:1
+12 IF '$TEST
IF PROB[" (SCT"&($GET(GMPL803)="")
SET PROB=PROB_" (ICD-9-CM "_$PIECE($$ICDDX^ICDCODE(+GMPL0),U,2)_")"
+13 IF $PIECE($GET(^AUPNPROB(DA,1)),"^",14)="A"
SET PROB="*"_PROB
+14 IF '$TEST
SET PROB=" "_PROB
+15 DO WRAP^GMPLX(PROB,50,.TEXT)
+16 DO NOTES(DA)
SET LINES=TEXT+NOTES+1
+17 IF ($Y+LINES)>(IOSL-7)
Begin DoDot:1
+18 IF IOST?1"P".E
DO FTR
DO HDR
QUIT
+19 IF $$RETURN
WRITE @IOF
DO HDR
QUIT
+20 SET GMPQUIT=1
End DoDot:1
IF $DATA(GMPQUIT)
QUIT
PR1 ; Write Problem Text Line
+1 WRITE !!,$EXTRACT(" ",1,3-$LENGTH(NUM))_NUM_". "_$JUSTIFY($$EXTDT^GMPLX(DATE),8)
+2 IF $PIECE(GMPL1,U,2)="T"
IF $PIECE($GET(^GMPL(125.99,1,0)),U,2)
WRITE ?14,"$"
SET GMPLFLAG=1
+3 WRITE ?15,TEXT(1),?62,$JUSTIFY($$EXTDT^GMPLX(ONSET),8)
+4 IF $PIECE(GMPL0,U,12)="I"
WRITE ?71,$SELECT(RESOLVED:$JUSTIFY($$EXTDT^GMPLX(RESOLVED),8),1:"unknown")
+5 IF TEXT>1
FOR J=2:1:TEXT
WRITE !?15,TEXT(J)
+6 IF 'NOTES
QUIT
SET DATE=$PIECE(DATE,".")
+7 FOR J=1:1:NOTES
SET X=$SELECT(DATE'=$PIECE(NOTES(J),U):$$EXTDT^GMPLX($PIECE(NOTES(J),U)),1:"")
WRITE !?5,$JUSTIFY(X,8),?17,$PIECE(NOTES(J),U,2)
SET DATE=$PIECE(NOTES(J),U)
+8 QUIT
NOTES(IFN) ; Place Comments in NOTES array
+1 NEW I,NOTE,DATE,TEXT,FAC,NIFN
SET (NOTES,I)=0
+2 IF '$DATA(^AUPNPROB(IFN,11))
QUIT
+3 SET FAC=$ORDER(^AUPNPROB(IFN,11,"B",+GMPVAMC,0))
IF FAC'>0
QUIT
+4 FOR NIFN=0:0
SET NIFN=$ORDER(^AUPNPROB(IFN,11,FAC,11,"B",NIFN))
IF NIFN'>0
QUIT
Begin DoDot:1
+5 SET NOTE=$GET(^AUPNPROB(IFN,11,FAC,11,NIFN,0))
IF NOTE=""
QUIT
+6 SET DATE=$PIECE(NOTE,U,5)
SET TEXT=$PIECE(NOTE,U,3)
SET I=I+1
+7 SET NOTES(I)=$PIECE(DATE,".")_U_TEXT
End DoDot:1
+8 SET NOTES=I
+9 QUIT
