- 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