APCHS81 ; IHS/CMI/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
NT ; ******************** NARRATIVE TEXT 9000010.34 ******
K APCHSTXA
; <SETUP>
Q:'$D(^AUPNVNT("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT) W !
S APCHSTT="" F APCHSQ=0:0 S APCHSTT=$O(^AUPNVNT("AA",APCHSPAT,APCHSTT)) Q:APCHSTT="" S APCHSND2=APCHSNDM D NTDTYP Q:$D(APCHSQIT)
D WRITE
; <CLEANUP>
NTX K APCHSTT,APCHSTT2,APCHSTT3,APCHSDFN,APCHSND2,APCHSDAT,APCHSIVD,APCHSTXA,APCHWP,APCHX,APCHSNDM
Q
NTDTYP S APCHSTT2=$S($D(^AUTTNTYP(APCHSTT,0)):$P(^(0),U,1),1:APCHSTT) S APCHSTT3=APCHSTT2
S (APCHSIVD,APCHSDFN)="" F S APCHSIVD=$O(^AUPNVNT("AA",APCHSPAT,APCHSTT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) S APCHSND2=APCHSND2-1 Q:APCHSND2=-1 D NTDSP
Q
NTDSP ;
S APCHSDFN=0 F S APCHSDFN=$O(^AUPNVNT("AA",APCHSPAT,APCHSTT,APCHSIVD,APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT)) S Y=-APCHSIVD\1+9999999 D
.S APCHSTXA(APCHSIVD,APCHSTT,APCHSDFN)=""
Q
;
WRITE ;write out Narrative text
S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA(APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
.S APCHSTT=0 F S APCHSTT=$O(APCHSTXA(APCHSIVD,APCHSTT)) Q:APCHSTT=""!($D(APCHSQIT)) D
..S APCHSDFN=0 F S APCHSDFN=$O(APCHSTXA(APCHSIVD,APCHSTT,APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT)) D
...X APCHSCKP Q:$D(APCHSQIT)
...W !,$$FMTE^XLFDT(9999999-APCHSIVD),?23,$P(^AUTTNTYP(APCHSTT,0),U)
... K APCHWP D WP
...S APCHX=0 F S APCHX=$O(APCHWP(APCHX)) Q:APCHX'=+APCHX!($D(APCHSQIT)) D
....X APCHSCKP Q:$D(APCHSQIT)
....W !?3,APCHWP(APCHX)
....Q
...Q
..Q
.Q
Q
WP ;EP - Entry point to print wp fields pass node in APCHWP
NEW APCHG,APCHX,CNT
K ^UTILITY($J,"W")
S APCHX=0
S DIWL=1,DIWR=70 F S APCHX=$O(^AUPNVNT(APCHSDFN,11,APCHX)) Q:APCHX'=+APCHX D
.S X=^AUPNVNT(APCHSDFN,11,APCHX,0) D ^DIWP
.Q
S (Z,CNT)=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S CNT=CNT+1,APCHWP(CNT)=^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),APCHG,CNT,APCHX
Q
VID ;EP
S APCHORD=1 ;order by date
G VII
VIP ;EP
S APCHORD=2 ;order by problem
G VII
VII ;
K APCHSTXA
; <SETUP>
Q:'$D(^AUPNVVI("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT)
S APCHPROB=""
F S APCHPROB=$O(^AUPNVVI("AA",APCHSPAT,APCHPROB)) Q:APCHPROB="" D
.S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVVI("AA",APCHSPAT,APCHPROB,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
..;table them by date,problem or problem,date depending on the component
..S X=0 F S X=$O(^AUPNVVI("AA",APCHSPAT,APCHPROB,APCHSIVD,X)) Q:X'=+X D
...S D=$$VALI^XBDIQ1(9000010.58,X,1201),D=$P(D,".",1) I D]"" S D=9999999-D
...I D="" S D=APCHSIVD
...I APCHORD=1 S APCHSTXA("DATE",D,APCHPROB,X)=""
...I APCHORD=2 S APCHSTXA("PROB",APCHPROB,D,X)=""
D WRITEVI
; <CLEANUP>
VIIX K APCHPROB,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
Q
WRITEVI ;
I APCHORD=1 D Q
.S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("DATE",APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W $$DATE^APCHSMU(9999999-$P(APCHSIVD,"."))
..S APCHPROB=0 F S APCHPROB=$O(APCHSTXA("DATE",APCHSIVD,APCHPROB)) Q:APCHPROB=""!($D(APCHSQIT)) D
...S APCHSICL=12 D GETPROB
...S APCHX=0 F S APCHX=$O(APCHSTXA("DATE",APCHSIVD,APCHPROB,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
....X APCHSCKP Q:$D(APCHSQIT)
....W ?12,"Visit Instructions Signed By: "_$$GET1^DIQ(9000010.58,APCHX,.04),!
...X APCHSCKP Q:$D(APCHSQIT)
...W !
I APCHORD=2 D Q
.S APCHPROB=0 F S APCHPROB=$O(APCHSTXA("PROB",APCHPROB)) Q:APCHPROB=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..S APCHSICL=1 D GETPROB
..S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("PROB",APCHPROB,APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
...S APCHX=0 F S APCHX=$O(APCHSTXA("PROB",APCHPROB,APCHSIVD,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
....X APCHSCKP Q:$D(APCHSQIT)
....W ?5,$$DATE^APCHSMU(9999999-$P(APCHSIVD,"."))
....X APCHSCKP Q:$D(APCHSQIT)
....W ?16,"Visit Instructions Signed By: "_$$GET1^DIQ(9000010.58,APCHX,.04),!
...X APCHSCKP Q:$D(APCHSQIT)
..W !
Q
GETPROB ;
S X=$$GET1^DIQ(9000011,APCHPROB,.05)
I $P(^APCHSCTL(APCHSTYP,0),U,3) S S=$$GET1^DIQ(9000011,APCHPROB,80001) I S]"" S X=X_" [SNOMED: "_S_"]"
S D=$$GET1^DIQ(9000011,APCHPROB,.01) I $P($G(^APCHSCTL(APCHSTYP,2)),U,1)="C" S X=X_" [DX: "_D_"]"
S X="Problem: "_X
S APCHSNRQ="",APCHSTXT=X D PRTTXT^APCHSUTL
Q
WPVI ;
K ^UTILITY($J,"W")
S DIWL=12,DIWR=79,DIWF="|"
D ^DIWP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(APCHSQIT)) D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?12,^UTILITY($J,"W",DIWL,Z,0),!
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),APCHG,CNT,APCHX
Q
REFD ;EP
S APCHORD=1 ;order by date
G REFI
REFP ;EP
S APCHORD=2 ;order by problem
G REFI
REFI ;
K APCHSTXA
; <SETUP>
Q:'$D(^AUPNVREF("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT)
S APCHPROB=""
F S APCHPROB=$O(^AUPNVREF("APRB",APCHSPAT,APCHPROB)) Q:APCHPROB="" D
.S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVREF("APRB",APCHSPAT,APCHPROB,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
..;table them by date,problem or problem,date depending on the component
..S X=0 F S X=$O(^AUPNVREF("APRB",APCHSPAT,APCHPROB,APCHSIVD,X)) Q:X'=+X D
...S D=$$VALI^XBDIQ1(9000010.59,X,1201),D=$P(D,".",1) I D]"" S D=9999999-D
...I D="" S D=$P(APCHSIVD,".")
...I APCHORD=1 S APCHSTXA("DATE",D,APCHPROB,X)=""
...I APCHORD=2 S APCHSTXA("PROB",APCHPROB,D,X)=""
D WRITEREF
; <CLEANUP>
REFX K APCHPROB,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
Q
WRITEREF ;
I APCHORD=1 D Q
.S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("DATE",APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W $$DATE^APCHSMU(9999999-$P(APCHSIVD,"."))
..S APCHPROB=0 F S APCHPROB=$O(APCHSTXA("DATE",APCHSIVD,APCHPROB)) Q:APCHPROB=""!($D(APCHSQIT)) D
...S APCHSICL=12 D GETPROB
...S APCHX=0 F S APCHX=$O(APCHSTXA("DATE",APCHSIVD,APCHPROB,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
....X APCHSCKP Q:$D(APCHSQIT)
....W ?12,"Referral: ",$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.59,APCHX,.01))," ["_$$GET1^DIQ(9000010.59,APCHX,.01)_"]",!
....W ?12,"Ordered by: ",$$GET1^DIQ(9000010.59,APCHX,1202)
....S X=$$GET1^DIQ(9000010.59,APCHX,.05) I X W " ====> Discontinued"
....W !
...X APCHSCKP Q:$D(APCHSQIT)
...W !
I APCHORD=2 D Q
.S APCHPROB=0 F S APCHPROB=$O(APCHSTXA("PROB",APCHPROB)) Q:APCHPROB=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..S APCHSICL=1 D GETPROB
..S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("PROB",APCHPROB,APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
...S APCHX=0 F S APCHX=$O(APCHSTXA("PROB",APCHPROB,APCHSIVD,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
....S X=$$DATE^APCHSMU(9999999-$P(APCHSIVD,"."))_" Referral: "_$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.59,APCHX,.01))_" ["_$$GET1^DIQ(9000010.59,APCHX,.01)_"]"
....S APCHSNRQ="",APCHSTXT=X,APCHSICL=5 D PRTTXT^APCHSUTL
....X APCHSCKP Q:$D(APCHSQIT)
....W ?5,"Ordered by: ",$$GET1^DIQ(9000010.59,APCHX,1202)
....S X=$$GET1^DIQ(9000010.59,APCHX,.05) I X W " ====> Discontinued"
....W !
...X APCHSCKP Q:$D(APCHSQIT)
...W !
Q
TXRD ;EP
S APCHORD=1 ;order by date
G TXRI
TXRP ;EP
S APCHORD=2 ;order by problem
G TXRI
TXRI ;
K APCHSTXA
; <SETUP>
Q:'$D(^AUPNVTXR("AA",APCHSPAT))
X APCHSBRK
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT)
S APCHPROB=""
F S APCHPROB=$O(^AUPNVTXR("APRB",APCHSPAT,APCHPROB)) Q:APCHPROB="" D
.S APCHSIVD=0 F S APCHSIVD=$O(^AUPNVTXR("APRB",APCHSPAT,APCHPROB,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
..;table them by date,problem or problem,date depending on the component
..S X=0 F S X=$O(^AUPNVTXR("APRB",APCHSPAT,APCHPROB,APCHSIVD,X)) Q:X'=+X D
...S D=$$VALI^XBDIQ1(9000010.61,X,1201),D=$P(D,".",1) I D]"" S D=9999999-D
...I D="" S D=$P(APCHSIVD,".")
...I APCHORD=1 S APCHSTXA("DATE",D,APCHPROB,X)=""
...I APCHORD=2 S APCHSTXA("PROB",APCHPROB,D,X)=""
D WRITETXR
; <CLEANUP>
TXRX K APCHPROB,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
Q
WRITETXR ;
I APCHORD=1 D Q
.S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("DATE",APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W $$DATE^APCHSMU(9999999-$P(APCHSIVD,"."))
..S APCHPROB=0 F S APCHPROB=$O(APCHSTXA("DATE",APCHSIVD,APCHPROB)) Q:APCHPROB=""!($D(APCHSQIT)) D
...S APCHSICL=12 D GETPROB
...S APCHX=0 F S APCHX=$O(APCHSTXA("DATE",APCHSIVD,APCHPROB,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
....X APCHSCKP Q:$D(APCHSQIT)
....W ?12,"Treatment/Regimen: ",$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.61,APCHX,.01))," ["_$$GET1^DIQ(9000010.61,APCHX,.01)_"]",!
....W ?12,"Ordered by: ",$$GET1^DIQ(9000010.61,APCHX,1202)
....S X=$$GET1^DIQ(9000010.61,APCHX,.05) I X W " ====> Discontinued"
....W !
...X APCHSCKP Q:$D(APCHSQIT)
...W !
I APCHORD=2 D Q
.S APCHPROB=0 F S APCHPROB=$O(APCHSTXA("PROB",APCHPROB)) Q:APCHPROB=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..S APCHSICL=1 D GETPROB
..S APCHSIVD=0 F S APCHSIVD=$O(APCHSTXA("PROB",APCHPROB,APCHSIVD)) Q:APCHSIVD=""!($D(APCHSQIT)) D
...S APCHX=0 F S APCHX=$O(APCHSTXA("PROB",APCHPROB,APCHSIVD,APCHX)) Q:APCHX=""!($D(APCHSQIT)) D
....S X=$$DATE^APCHSMU(9999999-$P(APCHSIVD,"."))_" Treatment/Regimen: "_$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.61,APCHX,.01))_" ["_$$GET1^DIQ(9000010.61,APCHX,.01)_"]"
....S APCHSNRQ="",APCHSTXT=X,APCHSICL=5 D PRTTXT^APCHSUTL
....X APCHSCKP Q:$D(APCHSQIT)
....W ?5,"Ordered by: ",$$GET1^DIQ(9000010.61,APCHX,1202)
....S X=$$GET1^DIQ(9000010.61,APCHX,.05) I X W " ====> Discontinued"
....W !
...X APCHSCKP Q:$D(APCHSQIT)
...W !
Q
APCHS81 ; IHS/CMI/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
NT ; ******************** NARRATIVE TEXT 9000010.34 ******
+1 KILL APCHSTXA
+2 ; <SETUP>
+3 IF '$DATA(^AUPNVNT("AA",APCHSPAT))
QUIT
+4 XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
+7 SET APCHSTT=""
FOR APCHSQ=0:0
SET APCHSTT=$ORDER(^AUPNVNT("AA",APCHSPAT,APCHSTT))
IF APCHSTT=""
QUIT
SET APCHSND2=APCHSNDM
DO NTDTYP
IF $DATA(APCHSQIT)
QUIT
+8 DO WRITE
+9 ; <CLEANUP>
NTX KILL APCHSTT,APCHSTT2,APCHSTT3,APCHSDFN,APCHSND2,APCHSDAT,APCHSIVD,APCHSTXA,APCHWP,APCHX,APCHSNDM
+1 QUIT
NTDTYP SET APCHSTT2=$SELECT($DATA(^AUTTNTYP(APCHSTT,0)):$PIECE(^(0),U,1),1:APCHSTT)
SET APCHSTT3=APCHSTT2
+1 SET (APCHSIVD,APCHSDFN)=""
FOR
SET APCHSIVD=$ORDER(^AUPNVNT("AA",APCHSPAT,APCHSTT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
SET APCHSND2=APCHSND2-1
IF APCHSND2=-1
QUIT
DO NTDSP
+2 QUIT
NTDSP ;
+1 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(^AUPNVNT("AA",APCHSPAT,APCHSTT,APCHSIVD,APCHSDFN))
IF APCHSDFN'=+APCHSDFN!($DATA(APCHSQIT))
QUIT
SET Y=-APCHSIVD\1+9999999
Begin DoDot:1
+2 SET APCHSTXA(APCHSIVD,APCHSTT,APCHSDFN)=""
End DoDot:1
+3 QUIT
+4 ;
WRITE ;write out Narrative text
+1 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA(APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+2 SET APCHSTT=0
FOR
SET APCHSTT=$ORDER(APCHSTXA(APCHSIVD,APCHSTT))
IF APCHSTT=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+3 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(APCHSTXA(APCHSIVD,APCHSTT,APCHSDFN))
IF APCHSDFN'=+APCHSDFN!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 WRITE !,$$FMTE^XLFDT(9999999-APCHSIVD),?23,$PIECE(^AUTTNTYP(APCHSTT,0),U)
+6 KILL APCHWP
DO WP
+7 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHWP(APCHX))
IF APCHX'=+APCHX!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE !?3,APCHWP(APCHX)
+10 QUIT
End DoDot:4
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
WP ;EP - Entry point to print wp fields pass node in APCHWP
+1 NEW APCHG,APCHX,CNT
+2 KILL ^UTILITY($JOB,"W")
+3 SET APCHX=0
+4 SET DIWL=1
SET DIWR=70
FOR
SET APCHX=$ORDER(^AUPNVNT(APCHSDFN,11,APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+5 SET X=^AUPNVNT(APCHSDFN,11,APCHX,0)
DO ^DIWP
+6 QUIT
End DoDot:1
+7 SET (Z,CNT)=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
SET CNT=CNT+1
SET APCHWP(CNT)=^UTILITY($JOB,"W",DIWL,Z,0)
+8 KILL DIWL,DIWR,DIWF,Z
+9 KILL ^UTILITY($JOB,"W"),APCHG,CNT,APCHX
+10 QUIT
VID ;EP
+1 ;order by date
SET APCHORD=1
+2 GOTO VII
VIP ;EP
+1 ;order by problem
SET APCHORD=2
+2 GOTO VII
VII ;
+1 KILL APCHSTXA
+2 ; <SETUP>
+3 IF '$DATA(^AUPNVVI("AA",APCHSPAT))
QUIT
+4 XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 SET APCHPROB=""
+8 FOR
SET APCHPROB=$ORDER(^AUPNVVI("AA",APCHSPAT,APCHPROB))
IF APCHPROB=""
QUIT
Begin DoDot:1
+9 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVVI("AA",APCHSPAT,APCHPROB,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+10 ;table them by date,problem or problem,date depending on the component
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVVI("AA",APCHSPAT,APCHPROB,APCHSIVD,X))
IF X'=+X
QUIT
Begin DoDot:3
+12 SET D=$$VALI^XBDIQ1(9000010.58,X,1201)
SET D=$PIECE(D,".",1)
IF D]""
SET D=9999999-D
+13 IF D=""
SET D=APCHSIVD
+14 IF APCHORD=1
SET APCHSTXA("DATE",D,APCHPROB,X)=""
+15 IF APCHORD=2
SET APCHSTXA("PROB",APCHPROB,D,X)=""
End DoDot:3
End DoDot:2
End DoDot:1
+16 DO WRITEVI
+17 ; <CLEANUP>
VIIX KILL APCHPROB,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
+1 QUIT
WRITEVI ;
+1 IF APCHORD=1
Begin DoDot:1
+2 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("DATE",APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE $$DATE^APCHSMU(9999999-$PIECE(APCHSIVD,"."))
+5 SET APCHPROB=0
FOR
SET APCHPROB=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHPROB))
IF APCHPROB=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+6 SET APCHSICL=12
DO GETPROB
+7 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHPROB,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?12,"Visit Instructions Signed By: "_$$GET1^DIQ(9000010.58,APCHX,.04),!
End DoDot:4
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+12 IF APCHORD=2
Begin DoDot:1
+13 SET APCHPROB=0
FOR
SET APCHPROB=$ORDER(APCHSTXA("PROB",APCHPROB))
IF APCHPROB=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 SET APCHSICL=1
DO GETPROB
+16 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("PROB",APCHPROB,APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+17 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("PROB",APCHPROB,APCHSIVD,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+18 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+19 WRITE ?5,$$DATE^APCHSMU(9999999-$PIECE(APCHSIVD,"."))
+20 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+21 WRITE ?16,"Visit Instructions Signed By: "_$$GET1^DIQ(9000010.58,APCHX,.04),!
End DoDot:4
+22 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
End DoDot:3
+23 WRITE !
End DoDot:2
End DoDot:1
QUIT
+24 QUIT
GETPROB ;
+1 SET X=$$GET1^DIQ(9000011,APCHPROB,.05)
+2 IF $PIECE(^APCHSCTL(APCHSTYP,0),U,3)
SET S=$$GET1^DIQ(9000011,APCHPROB,80001)
IF S]""
SET X=X_" [SNOMED: "_S_"]"
+3 SET D=$$GET1^DIQ(9000011,APCHPROB,.01)
IF $PIECE($GET(^APCHSCTL(APCHSTYP,2)),U,1)="C"
SET X=X_" [DX: "_D_"]"
+4 SET X="Problem: "_X
+5 SET APCHSNRQ=""
SET APCHSTXT=X
DO PRTTXT^APCHSUTL
+6 QUIT
WPVI ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET DIWL=12
SET DIWR=79
SET DIWF="|"
+3 DO ^DIWP
+4 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+6 WRITE ?12,^UTILITY($JOB,"W",DIWL,Z,0),!
End DoDot:1
+7 KILL DIWL,DIWR,DIWF,Z
+8 KILL ^UTILITY($JOB,"W"),APCHG,CNT,APCHX
+9 QUIT
REFD ;EP
+1 ;order by date
SET APCHORD=1
+2 GOTO REFI
REFP ;EP
+1 ;order by problem
SET APCHORD=2
+2 GOTO REFI
REFI ;
+1 KILL APCHSTXA
+2 ; <SETUP>
+3 IF '$DATA(^AUPNVREF("AA",APCHSPAT))
QUIT
+4 XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 SET APCHPROB=""
+8 FOR
SET APCHPROB=$ORDER(^AUPNVREF("APRB",APCHSPAT,APCHPROB))
IF APCHPROB=""
QUIT
Begin DoDot:1
+9 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVREF("APRB",APCHSPAT,APCHPROB,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+10 ;table them by date,problem or problem,date depending on the component
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVREF("APRB",APCHSPAT,APCHPROB,APCHSIVD,X))
IF X'=+X
QUIT
Begin DoDot:3
+12 SET D=$$VALI^XBDIQ1(9000010.59,X,1201)
SET D=$PIECE(D,".",1)
IF D]""
SET D=9999999-D
+13 IF D=""
SET D=$PIECE(APCHSIVD,".")
+14 IF APCHORD=1
SET APCHSTXA("DATE",D,APCHPROB,X)=""
+15 IF APCHORD=2
SET APCHSTXA("PROB",APCHPROB,D,X)=""
End DoDot:3
End DoDot:2
End DoDot:1
+16 DO WRITEREF
+17 ; <CLEANUP>
REFX KILL APCHPROB,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
+1 QUIT
WRITEREF ;
+1 IF APCHORD=1
Begin DoDot:1
+2 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("DATE",APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE $$DATE^APCHSMU(9999999-$PIECE(APCHSIVD,"."))
+5 SET APCHPROB=0
FOR
SET APCHPROB=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHPROB))
IF APCHPROB=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+6 SET APCHSICL=12
DO GETPROB
+7 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHPROB,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?12,"Referral: ",$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.59,APCHX,.01))," ["_$$GET1^DIQ(9000010.59,APCHX,.01)_"]",!
+10 WRITE ?12,"Ordered by: ",$$GET1^DIQ(9000010.59,APCHX,1202)
+11 SET X=$$GET1^DIQ(9000010.59,APCHX,.05)
IF X
WRITE " ====> Discontinued"
+12 WRITE !
End DoDot:4
+13 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+14 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+15 IF APCHORD=2
Begin DoDot:1
+16 SET APCHPROB=0
FOR
SET APCHPROB=$ORDER(APCHSTXA("PROB",APCHPROB))
IF APCHPROB=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+17 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 SET APCHSICL=1
DO GETPROB
+19 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("PROB",APCHPROB,APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+20 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("PROB",APCHPROB,APCHSIVD,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+21 SET X=$$DATE^APCHSMU(9999999-$PIECE(APCHSIVD,"."))_" Referral: "_$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.59,APCHX,.01))_" ["_$$GET1^DIQ(9000010.59,APCHX,.01)_"]"
+22 SET APCHSNRQ=""
SET APCHSTXT=X
SET APCHSICL=5
DO PRTTXT^APCHSUTL
+23 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+24 WRITE ?5,"Ordered by: ",$$GET1^DIQ(9000010.59,APCHX,1202)
+25 SET X=$$GET1^DIQ(9000010.59,APCHX,.05)
IF X
WRITE " ====> Discontinued"
+26 WRITE !
End DoDot:4
+27 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+28 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+29 QUIT
TXRD ;EP
+1 ;order by date
SET APCHORD=1
+2 GOTO TXRI
TXRP ;EP
+1 ;order by problem
SET APCHORD=2
+2 GOTO TXRI
TXRI ;
+1 KILL APCHSTXA
+2 ; <SETUP>
+3 IF '$DATA(^AUPNVTXR("AA",APCHSPAT))
QUIT
+4 XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 SET APCHPROB=""
+8 FOR
SET APCHPROB=$ORDER(^AUPNVTXR("APRB",APCHSPAT,APCHPROB))
IF APCHPROB=""
QUIT
Begin DoDot:1
+9 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(^AUPNVTXR("APRB",APCHSPAT,APCHPROB,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+10 ;table them by date,problem or problem,date depending on the component
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVTXR("APRB",APCHSPAT,APCHPROB,APCHSIVD,X))
IF X'=+X
QUIT
Begin DoDot:3
+12 SET D=$$VALI^XBDIQ1(9000010.61,X,1201)
SET D=$PIECE(D,".",1)
IF D]""
SET D=9999999-D
+13 IF D=""
SET D=$PIECE(APCHSIVD,".")
+14 IF APCHORD=1
SET APCHSTXA("DATE",D,APCHPROB,X)=""
+15 IF APCHORD=2
SET APCHSTXA("PROB",APCHPROB,D,X)=""
End DoDot:3
End DoDot:2
End DoDot:1
+16 DO WRITETXR
+17 ; <CLEANUP>
TXRX KILL APCHPROB,APCHSTXA,APCHORD,APCHSICL,APCHSTXT,APCHSNRQ
+1 QUIT
WRITETXR ;
+1 IF APCHORD=1
Begin DoDot:1
+2 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("DATE",APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE $$DATE^APCHSMU(9999999-$PIECE(APCHSIVD,"."))
+5 SET APCHPROB=0
FOR
SET APCHPROB=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHPROB))
IF APCHPROB=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+6 SET APCHSICL=12
DO GETPROB
+7 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("DATE",APCHSIVD,APCHPROB,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?12,"Treatment/Regimen: ",$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.61,APCHX,.01))," ["_$$GET1^DIQ(9000010.61,APCHX,.01)_"]",!
+10 WRITE ?12,"Ordered by: ",$$GET1^DIQ(9000010.61,APCHX,1202)
+11 SET X=$$GET1^DIQ(9000010.61,APCHX,.05)
IF X
WRITE " ====> Discontinued"
+12 WRITE !
End DoDot:4
+13 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+14 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+15 IF APCHORD=2
Begin DoDot:1
+16 SET APCHPROB=0
FOR
SET APCHPROB=$ORDER(APCHSTXA("PROB",APCHPROB))
IF APCHPROB=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+17 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 SET APCHSICL=1
DO GETPROB
+19 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSTXA("PROB",APCHPROB,APCHSIVD))
IF APCHSIVD=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+20 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHSTXA("PROB",APCHPROB,APCHSIVD,APCHX))
IF APCHX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:4
+21 SET X=$$DATE^APCHSMU(9999999-$PIECE(APCHSIVD,"."))_" Treatment/Regimen: "_$$CONCPT^AUPNVUTL($$GET1^DIQ(9000010.61,APCHX,.01))_" ["_$$GET1^DIQ(9000010.61,APCHX,.01)_"]"
+22 SET APCHSNRQ=""
SET APCHSTXT=X
SET APCHSICL=5
DO PRTTXT^APCHSUTL
+23 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+24 WRITE ?5,"Ordered by: ",$$GET1^DIQ(9000010.61,APCHX,1202)
+25 SET X=$$GET1^DIQ(9000010.61,APCHX,.05)
IF X
WRITE " ====> Discontinued"
+26 WRITE !
End DoDot:4
+27 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+28 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+29 QUIT
