APCHS4 ; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**5,10,11,16**;MAY 14, 2009;Build 9
;
PROBST ;EP - problems by status
NEW APCHPBST,APCHST
S APCHSTAT="AEOSR"
S APCHSNDF=0
S APCHSFAC="" F APCHSQ=0:0 S APCHSFAC=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC)) Q:'APCHSFAC D
.S APCHSPRB="" F APCHSQ=0:0 S APCHSPRB=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB)) Q:APCHSPRB="" D
..S APCHSDFN=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB,""))
..S APCHST=$P(^AUPNPROB(APCHSDFN,0),U,12)
..Q:APCHST=""
..Q:"AEOSR"'[APCHST
..S APCHSNDF=APCHSNDF+1,APCHSDFT(APCHST,APCHSFAC_APCHSPRB)=APCHSDFN
X APCHSCKP G:$D(APCHSQIT) PROBX I 'APCHSNPG W ! X APCHSCKP G:$D(APCHSQIT) PROBX X:'APCHSNPG APCHSBRK
I APCHSNDF=0 G COMMON1
F APCHST="A","S","E","O","R" D
.S APCHSFPP="" F APCHSQ=0:0 S APCHSFPP=$O(APCHSDFT(APCHST,APCHSFPP)) Q:APCHSFPP="" S APCHSDFN=APCHSDFT(APCHST,APCHSFPP) D PROBDSP
G COMMON1
PROB ; ******************** PROBLEM / NOTES * 9000011 *********
APROB S APCHSTAT="AS" S:$P(^APCHSCTL(APCHSTYP,0),U,4) APCHSTAT=APCHSTAT_"O" G COMMON
CPROB S APCHSTAT="A" G COMMON
SPROB S APCHSTAT="S" G COMMON
OPROB S APCHSTAT="O" G COMMON
EPROB S APCHSTAT="E" G COMMON
RPROB S APCHSTAT="R" G COMMON
IPROB S APCHSTAT="I"
; <SETUP>
COMMON ;
K APCHSDFT S APCHSNDF=0
S APCHSFAC="" F APCHSQ=0:0 S APCHSFAC=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC)) Q:'APCHSFAC D PROBSCH
X APCHSCKP G:$D(APCHSQIT) PROBX I 'APCHSNPG W ! X APCHSCKP G:$D(APCHSQIT) PROBX X:'APCHSNPG APCHSBRK
I APCHSNDF=0 G COMMON1
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT) W ?13,"ENT. MODIFIED",!
S APCHSFPP="" F APCHSQ=0:0 S APCHSFPP=$O(APCHSDFT(APCHSFPP)) Q:APCHSFPP=""!($D(APCHSQIT)) S APCHSDFN=APCHSDFT(APCHSFPP) D PROBDSP
COMMON1 ;additional stuff for CHHIT bjpc 2.0 patch 5
;get date last reviewed and display
S APCHSX=$$LASTPLR^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
W !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",?54,$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,25),!
S APCHSX=$$LASTPLU^APCLAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
W "Problem List Updated On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",?54,$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,25),!
I APCHSTAT]"" D
.S APCHSX=$$LASTNAP^APCLAPI6(APCHSPAT,,DT,"A")
.X APCHSCKP Q:$D(APCHSQIT)
.;I '$$ANYACTP^APCDAPRB(APCHSPAT) W !,"No Active Problems: ",?24,$$FMTE^XLFDT($P(APCHSX,U,1)) I $P(APCHSX,U,3) W ?39,"Documented By: ",?54,$E($P($G(^VA(200,$P(APCHSX,U,3),0)),U),1,25),!
.W "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($P(APCHSX,U,1)) W ?51,"By: ",$E($S($P(APCHSX,U,3):$P($G(^VA(200,$P(APCHSX,U,3),0)),U),1:""),1,25),!
PROBX K APCHSDFT,APCHSNDF,APCHSFPP,APCHSFAC,APCHSPLN,APCHSPBN,APCHSDTM,APCHSDTN,APCHSPRB,APCHSTAT,APCHSNFP,APCHSNRQ,APCHSPNM,APCHSDFN,APCHSFCN,APCHSICD,APCHSDOO
K APCHSICL,APCHSILN,APCHSN,APCHSNAR,APCHSNTE
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,Y,APCHCSVD,APCHSX
Q
PROBSCH ;
S APCHSPRB="" F APCHSQ=0:0 S APCHSPRB=$O(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB)) Q:APCHSPRB="" S APCHSDFN=$O(^(APCHSPRB,"")) S:APCHSTAT[$P(^AUPNPROB(APCHSDFN,0),U,12) APCHSNDF=APCHSNDF+1,APCHSDFT(APCHSFAC_APCHSPRB)=APCHSDFN
Q
PROBDSP ;
; <SETUP PROBLEM>
S APCHSNTE=""
S APCHSN=^AUPNPROB(APCHSDFN,0)
S APCHCSVD=$P(^AUPNPROB(APCHSDFN,0),U,3)
S APCHSICD=$P(APCHSN,U,1) D GETICDDX^APCHSUTL
S APCHSNRQ="" I $$WANTPN^APCHSUTL(APCHSTYP) D
.S APCHSNRQ=$$GET1^DIQ(9000011,APCHSDFN_",",.05)
.I $P(^APCHSCTL(APCHSTYP,0),U,3) S X=$$GET1^DIQ(9000011,APCHSDFN_",",80001) I X]"" S APCHSNRQ=APCHSNRQ_" ("_X_")"
S APCHSITE=$P(APCHSN,U,6) D GETSITE^APCHSUTL
S APCHSPNM=$P(APCHSN,U,7) ;***** EDE *****
S APCHSPNM=APCHSNAB_APCHSPNM ;***** EDE *****
S Y=$P(APCHSN,U,3) X APCHSCVD S APCHSDTM=Y
S Y=$P(APCHSN,U,8) X APCHSCVD S APCHSDTN=Y
S APCHSCL=$$VAL^XBDIQ1(9000011,APCHSDFN,.15)
I APCHSCL]"" S APCHSNTE=" "_$$CAT^AUPNVPLC($P(APCHSN,U,1))_": "_APCHSCL
S Y=$P(APCHSN,U,13) X:Y]"" APCHSCVD S APCHSDOO=Y
S:APCHSDOO]"" APCHSNTE=APCHSNTE_" (onset "_APCHSDOO_")"
S APCHSNTE=APCHSNTE_"(Status: "_$$VAL^XBDIQ1(9000011,APCHSDFN,.12)_")"
S APCHSPLN=APCHSPNM_$E(" ",1,12-$L(APCHSPNM))_APCHSDTN_" "_APCHSDTM
X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG ?12,"ENT. MODIFIED",!
W APCHSPLN S APCHSICL=31,APCHSILN=50 D PRTICD^APCHSUTL
I $P(APCHSN,U,16)!($P(APCHSN,U,17))!($P(APCHSN,U,18)) D ECODEDSP
;SEVERITY
I $O(^AUPNPROB(APCHSDFN,13,0)) D
.W ?30,"Severity: "
.S APCHSAX=0 F S APCHSAX=$O(^AUPNPROB(APCHSDFN,13,APCHSAX)) Q:APCHSAX'=+APCHSAX D
..S I=APCHSAX_","_APCHSDFN
..W ?42,$$GET1^DIQ(9000011.13,I,.01)_" - "_$$GET1^DIQ(9000011.13,I,.019),!
;FINDING SITE
I $O(^AUPNPROB(APCHSDFN,17,0)) D
.W ?30,"Finding Site: "
.S APCHSAX=0 F S APCHSAX=$O(^AUPNPROB(APCHSDFN,17,APCHSAX)) Q:APCHSAX'=+APCHSAX D
..S I=APCHSAX_","_APCHSDFN
..W ?42,$$GET1^DIQ(9000011.17,I,.01),!
;clinical course
I $O(^AUPNPROB(APCHSDFN,18,0)) D
.W ?30,"Clinical Course: "
.S APCHSAX=0 F S APCHSAX=$O(^AUPNPROB(APCHSDFN,18,APCHSAX)) Q:APCHSAX'=+APCHSAX D
..S I=APCHSAX_","_APCHSDFN
..W ?42,$$GET1^DIQ(9000011.18,I,.01)_" - "_$$GET1^DIQ(9000011.18,I,.019),!
D NOTEDSP
Q
ECODEDSP ;
X APCHSCKP Q:$D(APCHSQIT) W ?30,"CAUSE: ",!
F APCHSP=16,17,18 D Q:$D(APCHSQIT)
.X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG ?13,"ENT. MODIFIED",!
.S APCHSTXT=""
.S APCHSICD=$P(APCHSN,U,APCHSP)
.Q:APCHSICD=""
.S APCHSNRQ=$S(APCHSICF="N":$P($$ICDDX^ICDEX($P(APCHSN,U,APCHSP)),U,4),APCHSICF="L":$P($$ICDDX^ICDEX($P(APCHSN,U,APCHSP)),U,4),1:"")
.D GETICDDX^APCHSUTL
.I APCHSICF="C"!(APCHSICF="") S APCHSNRQ=APCHSICD_"-"_$P($$ICDDX^ICDEX($P(APCHSN,U,APCHSP)),U,4)
.I APCHSICF="L" S APCHSNRQ=APCHSICD
.S APCHSICL=31,APCHSILN=50
.D PRTICDE^APCHSUTL
.Q
Q
NOTEDSP ; DISPLAY NOTES UNDER APCHSPRBLEM
S APCHSNFP=0 F APCHSQ=0:0 S APCHSNFP=$O(^AUPNPROB(APCHSDFN,11,APCHSNFP)) Q:'APCHSNFP D DSPFACN
Q
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
Q:$D(^AUPNPROB(APCHSDFN,11,APCHSNFP,11,0))'=1 Q:$O(^(0))=""
S APCHSITE=^AUPNPROB(APCHSDFN,11,APCHSNFP,0) D GETSITE^APCHSUTL S APCHSFCN=APCHSNAB
S APCHSNDF=0 F APCHSQ=0:0 S APCHSNDF=$O(^AUPNPROB(APCHSDFN,11,APCHSNFP,11,APCHSNDF)) Q:'APCHSNDF S APCHSN=^(APCHSNDF,0) D DSPN
Q
DSPN ; DISPLAY SINGLE NOTE
Q:$P(APCHSN,U,4)'="A"
S APCHSNAR=$P(APCHSN,U,3) S Y=$P(APCHSN,U,5) ;S:Y="" Y=" "
I Y>0 X APCHSCVD S Y=Y_" - "
S APCHSNAR=Y_APCHSNAR
F APCHSQ=0:0 Q:$E(APCHSFCN)'=" " S APCHSFCN=$E(APCHSFCN,2,99)
X APCHSCKP Q:$D(APCHSQIT) W APCHSPNM,APCHSFCN,$P(APCHSN,U)
S APCHSTXT=APCHSNAR,APCHSICL=31 D PRTTXT^APCHSUTL
Q
APCHS4 ; IHS/CMI/LAB - PART 4 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**5,10,11,16**;MAY 14, 2009;Build 9
+2 ;
PROBST ;EP - problems by status
+1 NEW APCHPBST,APCHST
+2 SET APCHSTAT="AEOSR"
+3 SET APCHSNDF=0
+4 SET APCHSFAC=""
FOR APCHSQ=0:0
SET APCHSFAC=$ORDER(^AUPNPROB("AA",APCHSPAT,APCHSFAC))
IF 'APCHSFAC
QUIT
Begin DoDot:1
+5 SET APCHSPRB=""
FOR APCHSQ=0:0
SET APCHSPRB=$ORDER(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB))
IF APCHSPRB=""
QUIT
Begin DoDot:2
+6 SET APCHSDFN=$ORDER(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB,""))
+7 SET APCHST=$PIECE(^AUPNPROB(APCHSDFN,0),U,12)
+8 IF APCHST=""
QUIT
+9 IF "AEOSR"'[APCHST
QUIT
+10 SET APCHSNDF=APCHSNDF+1
SET APCHSDFT(APCHST,APCHSFAC_APCHSPRB)=APCHSDFN
End DoDot:2
End DoDot:1
+11 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO PROBX
IF 'APCHSNPG
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO PROBX
IF 'APCHSNPG
XECUTE APCHSBRK
+12 IF APCHSNDF=0
GOTO COMMON1
+13 FOR APCHST="A","S","E","O","R"
Begin DoDot:1
+14 SET APCHSFPP=""
FOR APCHSQ=0:0
SET APCHSFPP=$ORDER(APCHSDFT(APCHST,APCHSFPP))
IF APCHSFPP=""
QUIT
SET APCHSDFN=APCHSDFT(APCHST,APCHSFPP)
DO PROBDSP
End DoDot:1
+15 GOTO COMMON1
PROB ; ******************** PROBLEM / NOTES * 9000011 *********
APROB SET APCHSTAT="AS"
IF $PIECE(^APCHSCTL(APCHSTYP,0),U,4)
SET APCHSTAT=APCHSTAT_"O"
GOTO COMMON
CPROB SET APCHSTAT="A"
GOTO COMMON
SPROB SET APCHSTAT="S"
GOTO COMMON
OPROB SET APCHSTAT="O"
GOTO COMMON
EPROB SET APCHSTAT="E"
GOTO COMMON
RPROB SET APCHSTAT="R"
GOTO COMMON
IPROB SET APCHSTAT="I"
+1 ; <SETUP>
COMMON ;
+1 KILL APCHSDFT
SET APCHSNDF=0
+2 SET APCHSFAC=""
FOR APCHSQ=0:0
SET APCHSFAC=$ORDER(^AUPNPROB("AA",APCHSPAT,APCHSFAC))
IF 'APCHSFAC
QUIT
DO PROBSCH
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO PROBX
IF 'APCHSNPG
WRITE !
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
GOTO PROBX
IF 'APCHSNPG
XECUTE APCHSBRK
+4 IF APCHSNDF=0
GOTO COMMON1
+5 ; <DISPLAY>
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ?13,"ENT. MODIFIED",!
+7 SET APCHSFPP=""
FOR APCHSQ=0:0
SET APCHSFPP=$ORDER(APCHSDFT(APCHSFPP))
IF APCHSFPP=""!($DATA(APCHSQIT))
QUIT
SET APCHSDFN=APCHSDFT(APCHSFPP)
DO PROBDSP
COMMON1 ;additional stuff for CHHIT bjpc 2.0 patch 5
+1 ;get date last reviewed and display
+2 SET APCHSX=$$LASTPLR^APCLAPI6(APCHSPAT,,DT,"A")
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE !,"Problem List Reviewed On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,25),!
+5 SET APCHSX=$$LASTPLU^APCLAPI6(APCHSPAT,,DT,"A")
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 WRITE "Problem List Updated On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,25),!
+8 IF APCHSTAT]""
Begin DoDot:1
+9 SET APCHSX=$$LASTNAP^APCLAPI6(APCHSPAT,,DT,"A")
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 ;I '$$ANYACTP^APCDAPRB(APCHSPAT) W !,"No Active Problems: ",?24,$$FMTE^XLFDT($P(APCHSX,U,1)) I $P(APCHSX,U,3) W ?39,"Documented By: ",?54,$E($P($G(^VA(200,$P(APCHSX,U,3),0)),U),1,25),!
+12 WRITE "No Active Problems Documented On: ",?36,$$FMTE^XLFDT($PIECE(APCHSX,U,1))
WRITE ?51,"By: ",$EXTRACT($SELECT($PIECE(APCHSX,U,3):$PIECE($GET(^VA(200,$PIECE(APCHSX,U,3),0)),U),1:""),1,25),!
End DoDot:1
PROBX KILL APCHSDFT,APCHSNDF,APCHSFPP,APCHSFAC,APCHSPLN,APCHSPBN,APCHSDTM,APCHSDTN,APCHSPRB,APCHSTAT,APCHSNFP,APCHSNRQ,APCHSPNM,APCHSDFN,APCHSFCN,APCHSICD,APCHSDOO
+1 KILL APCHSICL,APCHSILN,APCHSN,APCHSNAR,APCHSNTE
+2 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,Y,APCHCSVD,APCHSX
+3 QUIT
PROBSCH ;
+1 SET APCHSPRB=""
FOR APCHSQ=0:0
SET APCHSPRB=$ORDER(^AUPNPROB("AA",APCHSPAT,APCHSFAC,APCHSPRB))
IF APCHSPRB=""
QUIT
SET APCHSDFN=$ORDER(^(APCHSPRB,""))
IF APCHSTAT[$PIECE(^AUPNPROB(APCHSDFN,0),U,12)
SET APCHSNDF=APCHSNDF+1
SET APCHSDFT(APCHSFAC_APCHSPRB)=APCHSDFN
+2 QUIT
PROBDSP ;
+1 ; <SETUP PROBLEM>
+2 SET APCHSNTE=""
+3 SET APCHSN=^AUPNPROB(APCHSDFN,0)
+4 SET APCHCSVD=$PIECE(^AUPNPROB(APCHSDFN,0),U,3)
+5 SET APCHSICD=$PIECE(APCHSN,U,1)
DO GETICDDX^APCHSUTL
+6 SET APCHSNRQ=""
IF $$WANTPN^APCHSUTL(APCHSTYP)
Begin DoDot:1
+7 SET APCHSNRQ=$$GET1^DIQ(9000011,APCHSDFN_",",.05)
+8 IF $PIECE(^APCHSCTL(APCHSTYP,0),U,3)
SET X=$$GET1^DIQ(9000011,APCHSDFN_",",80001)
IF X]""
SET APCHSNRQ=APCHSNRQ_" ("_X_")"
End DoDot:1
+9 SET APCHSITE=$PIECE(APCHSN,U,6)
DO GETSITE^APCHSUTL
+10 ;***** EDE *****
SET APCHSPNM=$PIECE(APCHSN,U,7)
+11 ;***** EDE *****
SET APCHSPNM=APCHSNAB_APCHSPNM
+12 SET Y=$PIECE(APCHSN,U,3)
XECUTE APCHSCVD
SET APCHSDTM=Y
+13 SET Y=$PIECE(APCHSN,U,8)
XECUTE APCHSCVD
SET APCHSDTN=Y
+14 SET APCHSCL=$$VAL^XBDIQ1(9000011,APCHSDFN,.15)
+15 IF APCHSCL]""
SET APCHSNTE=" "_$$CAT^AUPNVPLC($PIECE(APCHSN,U,1))_": "_APCHSCL
+16 SET Y=$PIECE(APCHSN,U,13)
IF Y]""
XECUTE APCHSCVD
SET APCHSDOO=Y
+17 IF APCHSDOO]""
SET APCHSNTE=APCHSNTE_" (onset "_APCHSDOO_")"
+18 SET APCHSNTE=APCHSNTE_"(Status: "_$$VAL^XBDIQ1(9000011,APCHSDFN,.12)_")"
+19 SET APCHSPLN=APCHSPNM_$EXTRACT(" ",1,12-$LENGTH(APCHSPNM))_APCHSDTN_" "_APCHSDTM
+20 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?12,"ENT. MODIFIED",!
+21 WRITE APCHSPLN
SET APCHSICL=31
SET APCHSILN=50
DO PRTICD^APCHSUTL
+22 IF $PIECE(APCHSN,U,16)!($PIECE(APCHSN,U,17))!($PIECE(APCHSN,U,18))
DO ECODEDSP
+23 ;SEVERITY
+24 IF $ORDER(^AUPNPROB(APCHSDFN,13,0))
Begin DoDot:1
+25 WRITE ?30,"Severity: "
+26 SET APCHSAX=0
FOR
SET APCHSAX=$ORDER(^AUPNPROB(APCHSDFN,13,APCHSAX))
IF APCHSAX'=+APCHSAX
QUIT
Begin DoDot:2
+27 SET I=APCHSAX_","_APCHSDFN
+28 WRITE ?42,$$GET1^DIQ(9000011.13,I,.01)_" - "_$$GET1^DIQ(9000011.13,I,.019),!
End DoDot:2
End DoDot:1
+29 ;FINDING SITE
+30 IF $ORDER(^AUPNPROB(APCHSDFN,17,0))
Begin DoDot:1
+31 WRITE ?30,"Finding Site: "
+32 SET APCHSAX=0
FOR
SET APCHSAX=$ORDER(^AUPNPROB(APCHSDFN,17,APCHSAX))
IF APCHSAX'=+APCHSAX
QUIT
Begin DoDot:2
+33 SET I=APCHSAX_","_APCHSDFN
+34 WRITE ?42,$$GET1^DIQ(9000011.17,I,.01),!
End DoDot:2
End DoDot:1
+35 ;clinical course
+36 IF $ORDER(^AUPNPROB(APCHSDFN,18,0))
Begin DoDot:1
+37 WRITE ?30,"Clinical Course: "
+38 SET APCHSAX=0
FOR
SET APCHSAX=$ORDER(^AUPNPROB(APCHSDFN,18,APCHSAX))
IF APCHSAX'=+APCHSAX
QUIT
Begin DoDot:2
+39 SET I=APCHSAX_","_APCHSDFN
+40 WRITE ?42,$$GET1^DIQ(9000011.18,I,.01)_" - "_$$GET1^DIQ(9000011.18,I,.019),!
End DoDot:2
End DoDot:1
+41 DO NOTEDSP
+42 QUIT
ECODEDSP ;
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ?30,"CAUSE: ",!
+2 FOR APCHSP=16,17,18
Begin DoDot:1
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?13,"ENT. MODIFIED",!
+4 SET APCHSTXT=""
+5 SET APCHSICD=$PIECE(APCHSN,U,APCHSP)
+6 IF APCHSICD=""
QUIT
+7 SET APCHSNRQ=$SELECT(APCHSICF="N":$PIECE($$ICDDX^ICDEX($PIECE(APCHSN,U,APCHSP)),U,4),APCHSICF="L":$PIECE($$ICDDX^ICDEX($PIECE(APCHSN,U,APCHSP)),U,4),1:"")
+8 DO GETICDDX^APCHSUTL
+9 IF APCHSICF="C"!(APCHSICF="")
SET APCHSNRQ=APCHSICD_"-"_$PIECE($$ICDDX^ICDEX($PIECE(APCHSN,U,APCHSP)),U,4)
+10 IF APCHSICF="L"
SET APCHSNRQ=APCHSICD
+11 SET APCHSICL=31
SET APCHSILN=50
+12 DO PRTICDE^APCHSUTL
+13 QUIT
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
+14 QUIT
NOTEDSP ; DISPLAY NOTES UNDER APCHSPRBLEM
+1 SET APCHSNFP=0
FOR APCHSQ=0:0
SET APCHSNFP=$ORDER(^AUPNPROB(APCHSDFN,11,APCHSNFP))
IF 'APCHSNFP
QUIT
DO DSPFACN
+2 QUIT
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
+1 IF $DATA(^AUPNPROB(APCHSDFN,11,APCHSNFP,11,0))'=1
QUIT
IF $ORDER(^(0))=""
QUIT
+2 SET APCHSITE=^AUPNPROB(APCHSDFN,11,APCHSNFP,0)
DO GETSITE^APCHSUTL
SET APCHSFCN=APCHSNAB
+3 SET APCHSNDF=0
FOR APCHSQ=0:0
SET APCHSNDF=$ORDER(^AUPNPROB(APCHSDFN,11,APCHSNFP,11,APCHSNDF))
IF 'APCHSNDF
QUIT
SET APCHSN=^(APCHSNDF,0)
DO DSPN
+4 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 IF $PIECE(APCHSN,U,4)'="A"
QUIT
+2 ;S:Y="" Y=" "
SET APCHSNAR=$PIECE(APCHSN,U,3)
SET Y=$PIECE(APCHSN,U,5)
+3 IF Y>0
XECUTE APCHSCVD
SET Y=Y_" - "
+4 SET APCHSNAR=Y_APCHSNAR
+5 FOR APCHSQ=0:0
IF $EXTRACT(APCHSFCN)'=" "
QUIT
SET APCHSFCN=$EXTRACT(APCHSFCN,2,99)
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSPNM,APCHSFCN,$PIECE(APCHSN,U)
+7 SET APCHSTXT=APCHSNAR
SET APCHSICL=31
DO PRTTXT^APCHSUTL
+8 QUIT
