APCDPROB.m

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