Routine: APCHPRE

APCHPRE ;IHS/CMI/GRL Patient Health Summary - Pre Visit[ 02/11/2005  11:05 PM ]

 ;;2.0;IHS RPMS/PCC Health Summary;**14**;JUN 24, 1997

EN ;

 Q  ;NOT READY YET

 W:$D(IOF) @IOF

 W !!,$$CTR("*** Print Patient Medical Handout ***"),!!

 K DIC S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 D EXIT Q

 S DFN=+Y

W !

ZIS ;

 W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) D EXIT Q

 S APCHOPT=Y

 I Y="B" D BROWSE,EXIT Q

 S XBRP="PRINT^APCHPRE",XBRC="",XBRX="EXIT^APCHPRE",XBNS="APCH;DFN"

 D ^XBDBQUE

 D EXIT

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^APCHPRE"")"

 S XBRC="",XBRX="EXIT^APCHPRE",XBIOP=0 D ^XBDBQUE

EXIT ;

 D EN^XBVK("APCH")

 D ^XBFMK

S(Y,F,C,T) ;set up array

 I '$G(F) S F=0

 I '$G(T) S T=0

 NEW %,X

 ;blank lines

 F F=1:1:F S X="" D S1

 S X=Y

 I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q

 .F %=1:1:(T-1) S X=" "_X

 F %=1:1:T S X=" "_Y

 D S1

S1 ;

 S %=$P(^TMP("APCHPHS",$J,"PHS",0),U)+1,$P(^TMP("APCHPHS",$J,"PHS",0),U)=%

 S ^TMP("APCHPHS",$J,"PHS",%)=X

PRINT ;

OUTPUT S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"

 K ^TMP("APCH",$J)

 S APCHSPAT=DFN

 D EP^APCHPRE1(DFN) ;gather up data

W ;write out array

 W:$D(IOF) @IOF

 K APCHQUIT

 W !,"********** Patient Medical Handout ********** ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********"

 S APCHX=0 F  S APCHX=$O(^TMP("APCHPHS",$J,"PHS",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT))  D

 .I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)

 .W !,^TMP("APCHPHS",$J,"PHS",APCHX)

.Q

 I $D(APCHQUIT) S APCHSQIT=1

 D EOJ

EOJ ;

 K ^TMP("APCHPHS",$J)

 K APCHX,APCHQUIT,APCHY,APCHSDFN,APCHSBEG,APCHSTOB,APCHSUPI,APCHSED,APCHTOBN,APCHTOB,APCHSPAT

 K APCHLFGV,APCHLFGD,APCHLGLV,APCHLGLD,APCHLFOB,APCHLBE,APCHLCOL,APCHLSIG,APCHSCRN,APCHCOLO

 K APCHPNV,APCHPND,APCHMNV,APCHMND,APCHIMMN,APCHIMMT,APCHICTR,APCHI,APCHIMDU,APCHIMM,APCHLDRE

 K APCHC,APCHOPT,APCHSCVD

 K N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W

HEADER ;

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q

HEAD1 ;

 W:$D(IOF) @IOF

 W !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!!

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

SDEP ;entry point from Scheduling Package with DFN defined

 Q  ;;NOT READY YET

 I '$P($G(^APCCCTRL(DUZ(2),0)),U,14)  ;set site parameter in PCC Master Control file has to be set

 I $$V2(DFN,$$FMTE^XLFDT(DT,-1)) Q  ;IF PT HAD A VISIT IN PAST 120 DAYS DON'T BOTHER

 I SDAMEVT,$P($G(^SD(409.66,SDAMEVT,0)),U)="CHECK-IN" D

 . W !!,"Do you wish to print a Patient Medical Handout to give to the patient?"

 . W !,"If so, enter the device to print the handout on, otherwise enter a '^'."

 . S XBRP="PRINT^APCHPRE",XBRC="",XBRX="EXIT^APCHPRE",XBNS="APCH;DFN"

 . D ^XBDBQUE

V2(P,EDATE) ;

 NEW APCHBDAT,A,B,C,G,V,X

 S APCHBDAT=$$FMADD^XLFDT(DT,-120)

 I '$D(^AUPNVSIT("AC",P)) Q ""

 K ^TMP($J,"A")

 S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHBDAT)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)

 I '$D(^TMP($J,"A",1)) Q ""

 S (X,G)=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G)  S V=$P(^TMP($J,"A",X),U,5) D

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$P(^AUPNVSIT(V,0),U,9)

 .Q:$P(^AUPNVSIT(V,0),U,11)

 .Q:"A"'[$P(^AUPNVSIT(V,0),U,7)

 .Q:$P(^AUPNVSIT(V,0),U,6)'=DUZ(2)

 .S T=$O(^ATXAX("B","APCH CLINIC STOP FOR PT HS",0))

 .S C=$P(^AUPNVSIT(V,0),U,8)

 .Q:$G(C)']""

 .Q:$D(^ATXAX(T,21,"B",C))

 .S G=G+1

.Q

 Q $S(G<1:"",1:1)

APCHPRE   ;IHS/CMI/GRL Patient Health Summary - Pre Visit[ 02/11/2005  11:05 PM ]

 +1       ;;2.0;IHS RPMS/PCC Health Summary;**14**;JUN 24, 1997

 +2       ;

EN        ;

 +1       ;NOT READY YET

           QUIT

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE !!,$$CTR("*** Print Patient Medical Handout ***"),!!

 +4        KILL DIC

           SET DIC="^AUPNPAT("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +5        IF Y=-1

               DO EXIT

               QUIT

 +6        SET DFN=+Y

 +7        WRITE !

ZIS       ;

 +1        WRITE !

           SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               DO EXIT

               QUIT

 +3        SET APCHOPT=Y

 +4        IF Y="B"

               DO BROWSE

               DO EXIT

               QUIT

 +5        SET XBRP="PRINT^APCHPRE"

           SET XBRC=""

           SET XBRX="EXIT^APCHPRE"

           SET XBNS="APCH;DFN"

 +6        DO ^XBDBQUE

 +7        DO EXIT

 +8        QUIT

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""PRINT^APCHPRE"")"

 +2        SET XBRC=""

           SET XBRX="EXIT^APCHPRE"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT

EXIT      ;

 +1        DO EN^XBVK("APCH")

 +2        DO ^XBFMK

 +3        QUIT

S(Y,F,C,T) ;set up array

 +1        IF '$GET(F)

               SET F=0

 +2        IF '$GET(T)

               SET T=0

 +3        NEW %,X

 +4       ;blank lines

 +5        FOR F=1:1:F

               SET X=""

               DO S1

 +6        SET X=Y

 +7        IF $GET(C)

               SET L=$LENGTH(Y)

               SET T=(80-L)/2

               Begin DoDot:1

 +8                FOR %=1:1:(T-1)

                       SET X=" "_X

               End DoDot:1

               DO S1

               QUIT

 +9        FOR %=1:1:T

               SET X=" "_Y

 +10       DO S1

 +11       QUIT

S1        ;

 +1        SET %=$PIECE(^TMP("APCHPHS",$JOB,"PHS",0),U)+1

           SET $PIECE(^TMP("APCHPHS",$JOB,"PHS",0),U)=%

 +2        SET ^TMP("APCHPHS",$JOB,"PHS",%)=X

 +3        QUIT

PRINT     ;

OUTPUT     SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"

 +1        KILL ^TMP("APCH",$JOB)

 +2        SET APCHSPAT=DFN

 +3       ;gather up data

           DO EP^APCHPRE1(DFN)

W         ;write out array

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        KILL APCHQUIT

 +3        WRITE !,"********** Patient Medical Handout ********** ["_$PIECE(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********"

 +4        SET APCHX=0

FOR

               SET APCHX=$ORDER(^TMP("APCHPHS",$JOB,"PHS",APCHX))

               IF APCHX'=+APCHX!($DATA(APCHQUIT))

                   QUIT

               Begin DoDot:1

 +5                IF $Y>(IOSL-3)

                       DO HEADER

                       IF $DATA(APCHQUIT)

                           QUIT

 +6                WRITE !,^TMP("APCHPHS",$JOB,"PHS",APCHX)

 +7                QUIT

               End DoDot:1

 +8        IF $DATA(APCHQUIT)

               SET APCHSQIT=1

 +9        DO EOJ

 +10       QUIT

 +11      ;

EOJ       ;

 +1        KILL ^TMP("APCHPHS",$JOB)

 +2        KILL APCHX,APCHQUIT,APCHY,APCHSDFN,APCHSBEG,APCHSTOB,APCHSUPI,APCHSED,APCHTOBN,APCHTOB,APCHSPAT

 +3        KILL APCHLFGV,APCHLFGD,APCHLGLV,APCHLGLD,APCHLFOB,APCHLBE,APCHLCOL,APCHLSIG,APCHSCRN,APCHCOLO

 +4        KILL APCHPNV,APCHPND,APCHMNV,APCHMND,APCHIMMN,APCHIMMT,APCHICTR,APCHI,APCHIMDU,APCHIMM,APCHLDRE

 +5        KILL APCHC,APCHOPT,APCHSCVD

 +6        KILL N,%,T,F,X,Y,B,C,E,F,H,L,N,P,T,W

 +7        QUIT

HEADER    ;

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCHQUIT=""

                       QUIT

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!!

 +3        QUIT

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 +2       ;----------

 +3       ;

 +4       ;

 +5       ;

SDEP      ;entry point from Scheduling Package with DFN defined

 +1       ;;NOT READY YET

           QUIT

 +2       ;set site parameter in PCC Master Control file has to be set

           IF '$PIECE($GET(^APCCCTRL(DUZ(2),0)),U,14)

 +3       ;IF PT HAD A VISIT IN PAST 120 DAYS DON'T BOTHER

           IF $$V2(DFN,$$FMTE^XLFDT(DT,-1))

               QUIT

 +4        IF SDAMEVT

               IF $PIECE($GET(^SD(409.66,SDAMEVT,0)),U)="CHECK-IN"

                   Begin DoDot:1

 +5                    WRITE !!,"Do you wish to print a Patient Medical Handout to give to the patient?"

 +6                    WRITE !,"If so, enter the device to print the handout on, otherwise enter a '^'."

 +7                    SET XBRP="PRINT^APCHPRE"

                       SET XBRC=""

                       SET XBRX="EXIT^APCHPRE"

                       SET XBNS="APCH;DFN"

 +8                    DO ^XBDBQUE

                   End DoDot:1

 +9        QUIT

 +10      ;

 +11      ;

 +12      ;

V2(P,EDATE) ;

 +1        NEW APCHBDAT,A,B,C,G,V,X

 +2        SET APCHBDAT=$$FMADD^XLFDT(DT,-120)

 +3        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT ""

 +4        KILL ^TMP($JOB,"A")

 +5        SET A="^TMP($J,""A"","

           SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHBDAT)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(B,A)

 +6        IF '$DATA(^TMP($JOB,"A",1))

               QUIT ""

 +7        SET (X,G)=0

FOR

               SET X=$ORDER(^TMP($JOB,"A",X))

               IF X'=+X!(G)

                   QUIT

               SET V=$PIECE(^TMP($JOB,"A",X),U,5)

               Begin DoDot:1

 +8                IF '$DATA(^AUPNVSIT(V,0))

                       QUIT

 +9                IF '$PIECE(^AUPNVSIT(V,0),U,9)

                       QUIT

 +10               IF $PIECE(^AUPNVSIT(V,0),U,11)

                       QUIT

 +11               IF "A"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       QUIT

 +12               IF $PIECE(^AUPNVSIT(V,0),U,6)'=DUZ(2)

                       QUIT

 +13               SET T=$ORDER(^ATXAX("B","APCH CLINIC STOP FOR PT HS",0))

 +14               SET C=$PIECE(^AUPNVSIT(V,0),U,8)

 +15               IF $GET(C)']""

                       QUIT

 +16               IF $DATA(^ATXAX(T,21,"B",C))

                       QUIT

 +17               SET G=G+1

 +18               QUIT

               End DoDot:1

 +19       QUIT $SELECT(G<1:"",1:1)

 +20      ;

APCHPRE.m