APCDPROB ; IHS/CMI/LAB - Display Problems and Notes ;
;;2.0;IHS PCC SUITE;**5,11,16**;MAY 14, 2009;Build 9
;Called from data entry templates to display problems, APCDPAT must equal the patient DFN
NEW APCDQUIT,APCDSX
S APCDQUIT=0
W:$D(IOF) @IOF
S APCDTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))"
;get date last reviewed and display
S APCDSX=$$LASTPLR^APCLAPI6(APCDPAT,,DT,"A")
W !,"Problem List Reviewed On: ",?24,$$FMTE^XLFDT($P(APCDSX,U,1)) W ?51,"By: ",?54,$E($S($P(APCDSX,U,3):$P($G(^VA(200,$P(APCDSX,U,3),0)),U),1:""),1,25),!
S APCDSX=$$LASTPLU^APCLAPI6(APCDPAT,,DT,"A")
W "Problem List Updated On: ",?36,$$FMTE^XLFDT($P(APCDSX,U,1)) W ?51,"By: ",?54,$E($S($P(APCDSX,U,3):$P($G(^VA(200,$P(APCDSX,U,3),0)),U),1:""),1,25),!
S APCDSX=$$LASTNAP^APCLAPI6(APCDPAT,,DT,"A")
W "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($P(APCDSX,U,1)) W ?51,"By: ",$E($S($P(APCDSX,U,3):$P($G(^VA(200,$P(APCDSX,U,3),0)),U),1:""),1,25),!
S APCDTTAT="ASEOR" D COMMON I 'APCDQUIT S APCDTTAT="I" D COMMON
K APCDTCVD,APCDTQ,Y
D PROBX
I $Y>(IOSL-5)&('APCDQUIT) W !!,"Press return to continue " R X:DTIME K X
K X
Q
COMMON ;
;I '$D(^AUPNPROB("AC",APCDPAT)) W !!,"********** No ",$S(APCDTTAT="A":"ACTIVE",1:"INACTIVE/RESOLVED")," Problems on file for this Patient",! Q
I '$D(^AUPNPROB("AC",APCDPAT)) W !!,"********** No Problems on file for this Patient",! Q
K APCDTDFT S APCDTNDF=0
S APCDTFAC="" F APCDTQ=0:0 S APCDTFAC=$O(^AUPNPROB("AA",APCDPAT,APCDTFAC)) Q:'APCDTFAC!(APCDQUIT) D PROBSCH
;I APCDTNDF=0 W !,"********** No ",$S(APCDTTAT="A":"ACTIVE",1:"INACTIVE/RESOLVED")," Problems on file for this Patient",! Q
;W !!,"******************",$S(APCDTTAT="A":" ACTIVE ",1:" INACTIVE/RESOLVED "),"PROBLEMS AND NOTES ********************",!!
I APCDTNDF=0 W !,"********** No ",$S(APCDTTAT["A":"ACTIVE (ALL)",1:"INACTIVE")," Problems on file for this Patient",! Q
W !!,"******************",$S(APCDTTAT["A":" ACTIVE (ALL) ",1:" INACTIVE "),"PROBLEMS AND NOTES ********************",!!
S APCDTFPP="" F APCDTQ=0:0 S APCDTFPP=$O(APCDTDFT(APCDTFPP)) Q:APCDTFPP=""!(APCDQUIT) S APCDTDFN=APCDTDFT(APCDTFPP) D PROBDSP
PROBX K APCDTDFT,APCDTNDF,APCDTFPP,APCDTFAC,APCDTPLN,APCDTPBN,APCDTDTM,APCDTDTN,APCDTPRB,APCDTTAT,APCDTNFP,APCDTNRQ,APCDTPNM,APCDTDFN,APCDTFCN,APCDTICD,APCDTICL,APCDTILN,APCDTN
K APCDTNFL,APCDTNSH,APCDTNAB,APCDTVSC,APCDTITE,APCDTDOO,APCDTDOI
Q
PROBSCH ;
S APCDTPRB="" F APCDTQ=0:0 S APCDTPRB=$O(^AUPNPROB("AA",APCDPAT,APCDTFAC,APCDTPRB)) Q:APCDTPRB=""!(APCDQUIT) S APCDTDFN=$O(^(APCDTPRB,"")) S:APCDTTAT[$P(^AUPNPROB(APCDTDFN,0),U,12) APCDTNDF=APCDTNDF+1,APCDTDFT(APCDTFAC_APCDTPRB)=APCDTDFN
Q
PROBDSP ;
S APCDTN=^AUPNPROB(APCDTDFN,0)
S APCDTNRQ=$P(APCDTN,U,5)
D GETNARR I 1
E S APCDTNRQ=""
S APCDTDOO=$P(APCDTN,U,13) I APCDTDOO]"" S Y=APCDTDOO X APCDTCVD S APCDTDOO=Y
S APCDTITE=$P(APCDTN,U,6)
D GETSITE
S APCDTPNM=$P(APCDTN,U,7)
S APCDTPNM=APCDTNAB_APCDTPNM
S Y=$P(APCDTN,U,3) X APCDTCVD S APCDTDTM=Y
S Y=$P(APCDTN,U,8) X APCDTCVD S APCDTDTN=Y
I $Y>(IOSL-2) D EOP Q:APCDQUIT
S APCDTPLN=APCDTPNM_$E(" ",1,12-$L(APCDTPNM))_APCDTDTM
W APCDTPLN S APCDTICL=24,APCDTILN=56 D PRTICD
W ?24,"Status: ",$$VAL^XBDIQ1(9000011,APCDTDFN,.12),!
D NOTEDSP
Q
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
S APCDTNFP=0 F APCDTQ=0:0 S APCDTNFP=$O(^AUPNPROB(APCDTDFN,11,APCDTNFP)) Q:'APCDTNFP!(APCDQUIT) D DSPFACN
Q
DSPFACN ; DISPLAY NOTES FOR SELECTED FACILITY
Q:$D(^AUPNPROB(APCDTDFN,11,APCDTNFP,11,0))'=1
Q:$O(^AUPNPROB(APCDTDFN,11,APCDTNFP,11,0))=""
S APCDTITE=^AUPNPROB(APCDTDFN,11,APCDTNFP,0) D GETSITE S APCDTFCN=APCDTNAB
S APCDTNDF=0 F APCDTQ=0:0 S APCDTNDF=$O(^AUPNPROB(APCDTDFN,11,APCDTNFP,11,APCDTNDF)) Q:'APCDTNDF!(APCDQUIT) D DSPN ; ACC
Q
DSPN ; DISPLAY SINGLE NOTE
S APCDTN=^AUPNPROB(APCDTDFN,11,APCDTNFP,11,APCDTNDF,0)
Q:$P(APCDTN,U,4)="I"
F APCDTQ=0:0 Q:$E(APCDTFCN)'=" " S APCDTFCN=$E(APCDTFCN,2,99)
S APCDTDOI=$P(APCDTN,U,5) I APCDTDOI]"" S Y=APCDTDOI X APCDTCVD S APCDTDOI=Y
I $Y>(IOSL-2) D EOP Q:APCDQUIT
W APCDTPNM,APCDTFCN,$P(APCDTN,U),?12,APCDTDOI,?24,$P(APCDTN,U,3),!
K APCDTDOI
Q
;
PRTICD ;
S:APCDTNRQ="" APCDTNRQ="<no narrative provided>" S APCDTICD=""
S APCDTTXT=APCDTICD D PRTTXT
Q
;
PRTTXT ; GENERALIZED TEXT PRINTER
S APCDTDLT=1,APCDTILN=80-APCDTICL-1
I APCDTDOO]"" S APCDTNRQ=APCDTNRQ_" (ONSET: "_APCDTDOO_")"
F APCDTQ=0:0 S:APCDTNRQ]""&(($L(APCDTNRQ)+$L(APCDTTXT)+2)<255) APCDTTXT=$S(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ,APCDTNRQ="" Q:APCDTTXT="" D PRTTXT2
K APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT,APCDTDOO
Q
PRTTXT2 D GETFRAG
I $Y>(IOSL-2) D EOP
Q:APCDQUIT
W ?APCDTICL W APCDTF,! S APCDTICL=APCDTICL+APCDTDLT,APCDTILN=APCDTILN-APCDTDLT,APCDTDLT=0
Q
GETFRAG I $L(APCDTTXT)<APCDTILN S APCDTF=APCDTTXT,APCDTTXT="" Q
F APCDTC=APCDTILN:-1:1 Q:$E(APCDTTXT,APCDTC)=" "
S APCDTF=$E(APCDTTXT,1,APCDTC-1),APCDTTXT=$E(APCDTTXT,APCDTC+1,255)
Q
;
GETNARR ;
;I APCDTNRQ]"" S APCDTNRQ=$S($D(^AUTNPOV(APCDTNRQ)):$P(^AUTNPOV(APCDTNRQ,0),U),1:"***** "_APCDTNRQ_" *****")
I APCDTNRQ]"" S APCDTNRQ=$$PNPROB^AUPNVUTL(APCDTNRQ)
E S APCDTNRQ=""
Q
;
GETSITE ;
S:APCDTITE="" APCDTITE="null"
S %=$G(^AUTTLOC(APCDTITE,0))
S APCDTNFL=$P(%,U),APCDTNFL=$S($D(^DIC(4,APCDTITE,0)):$P(^(0),U),1:"<"_APCDTITE_">")
S APCDTNSH=$P(%,U,2) I APCDTNSH="" S APCDTNSH="<"_APCDTITE_">"
S APCDTNAB=$J($P(%,U,7),4) I APCDTNAB="" S APCDTNAB="<"_APCDTITE_">"
Q
EOP ;end of page
W !,"Enter return to continue, '^' to exit" R X:DTIME
I X="^" S APCDQUIT=1 Q
I X'="" W "??" G EOP
W:$D(IOF) @IOF
Q
APCDPROB ; IHS/CMI/LAB - Display Problems and Notes ;
+1 ;;2.0;IHS PCC SUITE;**5,11,16**;MAY 14, 2009;Build 9
+2 ;Called from data entry templates to display problems, APCDPAT must equal the patient DFN
+3 NEW APCDQUIT,APCDSX
+4 SET APCDQUIT=0
+5 IF $DATA(IOF)
WRITE @IOF
+6 SET APCDTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))"
+7 ;get date last reviewed and display
+8 SET APCDSX=$$LASTPLR^APCLAPI6(APCDPAT,,DT,"A")
+9 WRITE !,"Problem List Reviewed On: ",?24,$$FMTE^XLFDT($PIECE(APCDSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(APCDSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCDSX,U,3),0)),U),1:""),1,25),!
+10 SET APCDSX=$$LASTPLU^APCLAPI6(APCDPAT,,DT,"A")
+11 WRITE "Problem List Updated On: ",?36,$$FMTE^XLFDT($PIECE(APCDSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(APCDSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCDSX,U,3),0)),U),1:""),1,25),!
+12 SET APCDSX=$$LASTNAP^APCLAPI6(APCDPAT,,DT,"A")
+13 WRITE "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($PIECE(APCDSX,U,1))
WRITE ?51,"By: ",$EXTRACT($SELECT($PIECE(APCDSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCDSX,U,3),0)),U),1:""),1,25),!
+14 SET APCDTTAT="ASEOR"
DO COMMON
IF 'APCDQUIT
SET APCDTTAT="I"
DO COMMON
+15 KILL APCDTCVD,APCDTQ,Y
+16 DO PROBX
+17 IF $Y>(IOSL-5)&('APCDQUIT)
WRITE !!,"Press return to continue "
READ X:DTIME
KILL X
+18 KILL X
+19 QUIT
COMMON ;
+1 ;I '$D(^AUPNPROB("AC",APCDPAT)) W !!,"********** No ",$S(APCDTTAT="A":"ACTIVE",1:"INACTIVE/RESOLVED")," Problems on file for this Patient",! Q
+2 IF '$DATA(^AUPNPROB("AC",APCDPAT))
WRITE !!,"********** No Problems on file for this Patient",!
QUIT
+3 KILL APCDTDFT
SET APCDTNDF=0
+4 SET APCDTFAC=""
FOR APCDTQ=0:0
SET APCDTFAC=$ORDER(^AUPNPROB("AA",APCDPAT,APCDTFAC))
IF 'APCDTFAC!(APCDQUIT)
QUIT
DO PROBSCH
+5 ;I APCDTNDF=0 W !,"********** No ",$S(APCDTTAT="A":"ACTIVE",1:"INACTIVE/RESOLVED")," Problems on file for this Patient",! Q
+6 ;W !!,"******************",$S(APCDTTAT="A":" ACTIVE ",1:" INACTIVE/RESOLVED "),"PROBLEMS AND NOTES ********************",!!
+7 IF APCDTNDF=0
WRITE !,"********** No ",$SELECT(APCDTTAT["A":"ACTIVE (ALL)",1:"INACTIVE")," Problems on file for this Patient",!
QUIT
+8 WRITE !!,"******************",$SELECT(APCDTTAT["A":" ACTIVE (ALL) ",1:" INACTIVE "),"PROBLEMS AND NOTES ********************",!!
+9 SET APCDTFPP=""
FOR APCDTQ=0:0
SET APCDTFPP=$ORDER(APCDTDFT(APCDTFPP))
IF APCDTFPP=""!(APCDQUIT)
QUIT
SET APCDTDFN=APCDTDFT(APCDTFPP)
DO PROBDSP
PROBX KILL APCDTDFT,APCDTNDF,APCDTFPP,APCDTFAC,APCDTPLN,APCDTPBN,APCDTDTM,APCDTDTN,APCDTPRB,APCDTTAT,APCDTNFP,APCDTNRQ,APCDTPNM,APCDTDFN,APCDTFCN,APCDTICD,APCDTICL,APCDTILN,APCDTN
+1 KILL APCDTNFL,APCDTNSH,APCDTNAB,APCDTVSC,APCDTITE,APCDTDOO,APCDTDOI
+2 QUIT
PROBSCH ;
+1 SET APCDTPRB=""
FOR APCDTQ=0:0
SET APCDTPRB=$ORDER(^AUPNPROB("AA",APCDPAT,APCDTFAC,APCDTPRB))
IF APCDTPRB=""!(APCDQUIT)
QUIT
SET APCDTDFN=$ORDER(^(APCDTPRB,""))
IF APCDTTAT[$PIECE(^AUPNPROB(APCDTDFN,0),U,12)
SET APCDTNDF=APCDTNDF+1
SET APCDTDFT(APCDTFAC_APCDTPRB)=APCDTDFN
+2 QUIT
PROBDSP ;
+1 SET APCDTN=^AUPNPROB(APCDTDFN,0)
+2 SET APCDTNRQ=$PIECE(APCDTN,U,5)
+3 DO GETNARR
IF 1
+4 IF '$TEST
SET APCDTNRQ=""
+5 SET APCDTDOO=$PIECE(APCDTN,U,13)
IF APCDTDOO]""
SET Y=APCDTDOO
XECUTE APCDTCVD
SET APCDTDOO=Y
+6 SET APCDTITE=$PIECE(APCDTN,U,6)
+7 DO GETSITE
+8 SET APCDTPNM=$PIECE(APCDTN,U,7)
+9 SET APCDTPNM=APCDTNAB_APCDTPNM
+10 SET Y=$PIECE(APCDTN,U,3)
XECUTE APCDTCVD
SET APCDTDTM=Y
+11 SET Y=$PIECE(APCDTN,U,8)
XECUTE APCDTCVD
SET APCDTDTN=Y
+12 IF $Y>(IOSL-2)
DO EOP
IF APCDQUIT
QUIT
+13 SET APCDTPLN=APCDTPNM_$EXTRACT(" ",1,12-$LENGTH(APCDTPNM))_APCDTDTM
+14 WRITE APCDTPLN
SET APCDTICL=24
SET APCDTILN=56
DO PRTICD
+15 WRITE ?24,"Status: ",$$VAL^XBDIQ1(9000011,APCDTDFN,.12),!
+16 DO NOTEDSP
+17 QUIT
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
+1 SET APCDTNFP=0
FOR APCDTQ=0:0
SET APCDTNFP=$ORDER(^AUPNPROB(APCDTDFN,11,APCDTNFP))
IF 'APCDTNFP!(APCDQUIT)
QUIT
DO DSPFACN
+2 QUIT
DSPFACN ; DISPLAY NOTES FOR SELECTED FACILITY
+1 IF $DATA(^AUPNPROB(APCDTDFN,11,APCDTNFP,11,0))'=1
QUIT
+2 IF $ORDER(^AUPNPROB(APCDTDFN,11,APCDTNFP,11,0))=""
QUIT
+3 SET APCDTITE=^AUPNPROB(APCDTDFN,11,APCDTNFP,0)
DO GETSITE
SET APCDTFCN=APCDTNAB
+4 ; ACC
SET APCDTNDF=0
FOR APCDTQ=0:0
SET APCDTNDF=$ORDER(^AUPNPROB(APCDTDFN,11,APCDTNFP,11,APCDTNDF))
IF 'APCDTNDF!(APCDQUIT)
QUIT
DO DSPN
+5 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 SET APCDTN=^AUPNPROB(APCDTDFN,11,APCDTNFP,11,APCDTNDF,0)
+2 IF $PIECE(APCDTN,U,4)="I"
QUIT
+3 FOR APCDTQ=0:0
IF $EXTRACT(APCDTFCN)'=" "
QUIT
SET APCDTFCN=$EXTRACT(APCDTFCN,2,99)
+4 SET APCDTDOI=$PIECE(APCDTN,U,5)
IF APCDTDOI]""
SET Y=APCDTDOI
XECUTE APCDTCVD
SET APCDTDOI=Y
+5 IF $Y>(IOSL-2)
DO EOP
IF APCDQUIT
QUIT
+6 WRITE APCDTPNM,APCDTFCN,$PIECE(APCDTN,U),?12,APCDTDOI,?24,$PIECE(APCDTN,U,3),!
+7 KILL APCDTDOI
+8 QUIT
+9 ;
PRTICD ;
+1 IF APCDTNRQ=""
SET APCDTNRQ="<no narrative provided>"
SET APCDTICD=""
+2 SET APCDTTXT=APCDTICD
DO PRTTXT
+3 QUIT
+4 ;
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET APCDTDLT=1
SET APCDTILN=80-APCDTICL-1
+2 IF APCDTDOO]""
SET APCDTNRQ=APCDTNRQ_" (ONSET: "_APCDTDOO_")"
+3 FOR APCDTQ=0:0
IF APCDTNRQ]""&(($LENGTH(APCDTNRQ)+$LENGTH(APCDTTXT)+2)<255)
SET APCDTTXT=$SELECT(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ
SET APCDTNRQ=""
IF APCDTTXT=""
QUIT
DO PRTTXT2
+4 KILL APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT,APCDTDOO
+5 QUIT
PRTTXT2 DO GETFRAG
+1 IF $Y>(IOSL-2)
DO EOP
+2 IF APCDQUIT
QUIT
+3 WRITE ?APCDTICL
WRITE APCDTF,!
SET APCDTICL=APCDTICL+APCDTDLT
SET APCDTILN=APCDTILN-APCDTDLT
SET APCDTDLT=0
+4 QUIT
GETFRAG IF $LENGTH(APCDTTXT)<APCDTILN
SET APCDTF=APCDTTXT
SET APCDTTXT=""
QUIT
+1 FOR APCDTC=APCDTILN:-1:1
IF $EXTRACT(APCDTTXT,APCDTC)=" "
QUIT
+2 SET APCDTF=$EXTRACT(APCDTTXT,1,APCDTC-1)
SET APCDTTXT=$EXTRACT(APCDTTXT,APCDTC+1,255)
+3 QUIT
+4 ;
GETNARR ;
+1 ;I APCDTNRQ]"" S APCDTNRQ=$S($D(^AUTNPOV(APCDTNRQ)):$P(^AUTNPOV(APCDTNRQ,0),U),1:"***** "_APCDTNRQ_" *****")
+2 IF APCDTNRQ]""
SET APCDTNRQ=$$PNPROB^AUPNVUTL(APCDTNRQ)
+3 IF '$TEST
SET APCDTNRQ=""
+4 QUIT
+5 ;
GETSITE ;
+1 IF APCDTITE=""
SET APCDTITE="null"
+2 SET %=$GET(^AUTTLOC(APCDTITE,0))
+3 SET APCDTNFL=$PIECE(%,U)
SET APCDTNFL=$SELECT($DATA(^DIC(4,APCDTITE,0)):$PIECE(^(0),U),1:"<"_APCDTITE_">")
+4 SET APCDTNSH=$PIECE(%,U,2)
IF APCDTNSH=""
SET APCDTNSH="<"_APCDTITE_">"
+5 SET APCDTNAB=$JUSTIFY($PIECE(%,U,7),4)
IF APCDTNAB=""
SET APCDTNAB="<"_APCDTITE_">"
+6 QUIT
EOP ;end of page
+1 WRITE !,"Enter return to continue, '^' to exit"
READ X:DTIME
+2 IF X="^"
SET APCDQUIT=1
QUIT
+3 IF X'=""
WRITE "??"
GOTO EOP
+4 IF $DATA(IOF)
WRITE @IOF
+5 QUIT
