APCHS81.m

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=""