Routine: APCDEH

APCDEH ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 21-SEP-1996 ;

 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 ;; ;

START ;

 W:$D(IOF) @IOF

 F J=1:1:5 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X

 K X,J

 W !!

 S APCDPAT="" D GETPAT

 I APCDPAT="" W !!,"No PATIENT selected!" D EOJ Q

 D GETLOC

 I APCDLOC="" W !!,"No location entered!!" D EOJ Q

 D GETDATE

 I APCDDATE="" W !!,"No date entered!!" D EOJ Q

 D ^APCDEIN

 D EN,FULL^VALM1,EXIT K APCDPAT

 D EOJ

GETLOC ; GET LOCATION

 S APCDLOC="" S DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC

 Q:Y<0

 S APCDLOC=+Y

GETDATE ; GET DATE

 S APCDDATE="",%DT="AEPX",%DT("A")="Enter Date Information Was Collected: " D ^%DT

 Q:Y<0

 S APCDDATE=+Y

 I AUPNDOB]"" S X2=AUPNDOB,X1=APCDDATE D ^%DTC S AUPNDAYS=X ; re-set days of age to visit date-dob

GETPAT ; GET PATIENT

W !

 S APCDPAT=""

 I '$P($G(^APCDSITE(DUZ(2),0)),U,34) S AUPNLK("INAC")=1

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

 Q:Y<0

 W !?25,"Ok" S %=1 D YN^DICN Q:%'=1

 S APCDPAT=+Y

 D INAC^APCDEA(APCDPAT,.X) I 'X S APCDPAT="" Q

EN ;PEP  -- main entry point for APCDEHM PCC DATA ENTRY

 ;APCDPAT must = patient ien

 ;caller must set APCDVSIT,APCDPAT

 ;caller must kill APCDVSIT,APCDPAT and must call

 ;D ^APCDEKL to clean up d/e variables

 Q:'$G(APCDPAT)

 Q:'$D(^DPT(APCDPAT))

 D ^APCDEIN

 D EN^VALM("APCD HISTORICAL DATA ENTRY")

 D CLEAR^VALM1

 K APCDDISP,APCDSEL,^TMP("APCDEH",$J),C,X,I,K,J,APCDHIGH,APCDCUT,APCDCSEL,APCDCNTL

 D ^XBFMK

HDR ;EP -- header code

 S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(APCDPAT,0),U)_IOINORM_"   DOB: "_$$FTIME^VALM1(AUPNDOB)_"   Sex: "_$P(^DPT(APCDPAT,0),U,2)_"   HRN: "_$S($D(^AUPNPAT(APCDPAT,41,DUZ(2),0)):$P(^AUPNPAT(APCDPAT,41,DUZ(2),0),U,2),1:"????")

 S VALMHDR(3)="Date of Update: "_$$FMTE^XLFDT(DT)

INIT3 ;EP

 K APCDDISP,APCDSEL,APCDHIGH,^TMP("APCDEH",$J)

 S APCDHIGH=0,X=0 F  S X=$O(^APCDTKW("ANVI",X)) Q:X'=+X  S Y=$O(^APCDTKW("ANVI",X,"")) S APCDHIGH=APCDHIGH+1,APCDSEL(APCDHIGH)=Y

 S APCDCUT=((APCDHIGH/3)+1)\1

 S (C,I)=0,J=1,K=1 F  S I=$O(APCDSEL(I)) Q:I'=+I!($D(APCDDISP(I)))  D

 .S C=C+1,^TMP("APCDEH",$J,C,0)=I_") "_$S($D(APCDCSEL(I)):"*",1:" ")_$S($P(^APCDTKW(APCDSEL(I),0),U,12)="":$E($P(^(0),U),1,20),1:$P(^(0),U,12)) S APCDDISP(I)="",^TMP("APCDEH",$J,"IDX",C,C)=""

 .S J=I+APCDCUT I $D(APCDSEL(J)),'$D(APCDDISP(J)) S $E(^TMP("APCDEH",$J,C,0),28)=J_") "_$S($D(APCDCSEL(J)):"*",1:" ")_$S($P(^APCDTKW(APCDSEL(J),0),U,12)="":$E($P(^APCDTKW(APCDSEL(J),0),U),1,20),1:$P(^(0),U,12)) S APCDDISP(J)=""

 .S K=J+APCDCUT I $D(APCDSEL(K)),'$D(APCDDISP(K)) S $E(^TMP("APCDEH",$J,C,0),55)=K_") "_$S($D(APCDCSEL(K)):"*",1:" ")_$S($P(^APCDTKW(APCDSEL(K),0),U,12)="":$E($P(^APCDTKW(APCDSEL(K),0),U),1,20),1:$P(^(0),U,12)) S APCDDISP(K)=""

 K APCDDISP,APCDOTHR

 S VALMCNT=C

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

EXIT ; -- exit code

 K DISP,APCDSEL,APCHIGH,APCDCUT,APCDANS,APCDC,APCDI,APCDX,APCDY,APCDCRIT,APCDTEXT,APCDMOD,APCDMODE,APCDMNE,APCDVLK,APCDLOOK

EOJ ;

 K VALMHDR,VALMCNT

 D EN^APCDEKL

 D EN2^APCDEKL

 D ^XBFMK

 K APCDPAT,APCDVSIT,APCDCUT,APCDHIGH,APCDSEL,APCDDISP,APCDANS,APCDC,APCDI

 K X,Y,C,I

 D KILL^AUPNPAT

EXPND ; -- expand code

TEXT ;

 ;;Patient Care Component (PCC)

;;

 ;;**********************************************************

 ;;*****  PCC DATA ENTRY UPDATE HISTORICAL DATA BY ITEM *****

 ;;**********************************************************

;;

APCDEH    ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 21-SEP-1996 ;

 +1       ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 +2       ;; ;

START     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        FOR J=1:1:5

               SET X=$PIECE($TEXT(TEXT+J),";;",2)

               WRITE !?80-$LENGTH(X)\2,X

 +3        KILL X,J

 +4        WRITE !!

 +5        SET APCDPAT=""

           DO GETPAT

 +6        IF APCDPAT=""

               WRITE !!,"No PATIENT selected!"

               DO EOJ

               QUIT

 +7        DO GETLOC

 +8        IF APCDLOC=""

               WRITE !!,"No location entered!!"

               DO EOJ

               QUIT

 +9        DO GETDATE

 +10       IF APCDDATE=""

               WRITE !!,"No date entered!!"

               DO EOJ

               QUIT

 +11       DO ^APCDEIN

 +12       DO EN

           DO FULL^VALM1

           DO EXIT

           KILL APCDPAT

 +13       DO EOJ

 +14       QUIT

GETLOC    ; GET LOCATION

 +1        SET APCDLOC=""

           SET DIC="^AUTTLOC("

           SET DIC(0)="AEMQ"

           DO ^DIC

 +2        IF Y<0

               QUIT

 +3        SET APCDLOC=+Y

 +4        QUIT

 +5       ;

GETDATE   ; GET DATE

 +1        SET APCDDATE=""

           SET %DT="AEPX"

           SET %DT("A")="Enter Date Information Was Collected: "

           DO ^%DT

 +2        IF Y<0

               QUIT

 +3        SET APCDDATE=+Y

 +4       ; re-set days of age to visit date-dob

           IF AUPNDOB]""

               SET X2=AUPNDOB

               SET X1=APCDDATE

               DO ^%DTC

               SET AUPNDAYS=X

 +5        QUIT

 +6       ;

GETPAT    ; GET PATIENT

 +1        WRITE !

 +2        SET APCDPAT=""

 +3        IF '$PIECE($GET(^APCDSITE(DUZ(2),0)),U,34)

               SET AUPNLK("INAC")=1

 +4        SET DIC="^AUPNPAT("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +5        IF Y<0

               QUIT

 +6        WRITE !?25,"Ok"

           SET %=1

           DO YN^DICN

           IF %'=1

               QUIT

 +7        SET APCDPAT=+Y

 +8        DO INAC^APCDEA(APCDPAT,.X)

           IF 'X

               SET APCDPAT=""

               QUIT

 +9        QUIT

 +10      ;

EN        ;PEP  -- main entry point for APCDEHM PCC DATA ENTRY

 +1       ;APCDPAT must = patient ien

 +2       ;caller must set APCDVSIT,APCDPAT

 +3       ;caller must kill APCDVSIT,APCDPAT and must call

 +4       ;D ^APCDEKL to clean up d/e variables

 +5        IF '$GET(APCDPAT)

               QUIT

 +6        IF '$DATA(^DPT(APCDPAT))

               QUIT

 +7        DO ^APCDEIN

 +8        DO EN^VALM("APCD HISTORICAL DATA ENTRY")

 +9        DO CLEAR^VALM1

 +10       KILL APCDDISP,APCDSEL,^TMP("APCDEH",$JOB),C,X,I,K,J,APCDHIGH,APCDCUT,APCDCSEL,APCDCNTL

 +11       DO ^XBFMK

 +12       QUIT

 +13      ;

HDR       ;EP -- header code

 +1        SET VALMHDR(2)="Patient Name: "_IORVON_$PIECE(^DPT(APCDPAT,0),U)_IOINORM_"   DOB: "_$$FTIME^VALM1(AUPNDOB)_"   Sex: "_$PIECE(^DPT(APCDPAT,0),U,2)_"   HRN: "_$SELECT($DATA(^AUPNPAT(APCDPAT,41,DUZ(2),0)):$PIECE(^AUPNPAT(APCDPAT,41,DUZ(2),0),U,2),

1:"????")

 +2        SET VALMHDR(3)="Date of Update: "_$$FMTE^XLFDT(DT)

 +3        QUIT

 +4       ;

INIT3     ;EP

 +1        KILL APCDDISP,APCDSEL,APCDHIGH,^TMP("APCDEH",$JOB)

 +2        SET APCDHIGH=0

           SET X=0

FOR

               SET X=$ORDER(^APCDTKW("ANVI",X))

               IF X'=+X

                   QUIT

               SET Y=$ORDER(^APCDTKW("ANVI",X,""))

               SET APCDHIGH=APCDHIGH+1

               SET APCDSEL(APCDHIGH)=Y

 +3        SET APCDCUT=((APCDHIGH/3)+1)\1

 +4        SET (C,I)=0

           SET J=1

           SET K=1

FOR

               SET I=$ORDER(APCDSEL(I))

               IF I'=+I!($DATA(APCDDISP(I)))

                   QUIT

               Begin DoDot:1

 +5                SET C=C+1

                   SET ^TMP("APCDEH",$JOB,C,0)=I_") "_$SELECT($DATA(APCDCSEL(I)):"*",1:" ")_$SELECT($PIECE(^APCDTKW(APCDSEL(I),0),U,12)="":$EXTRACT($PIECE(^(0),U),1,20),1:$PIECE(^(0),U,12))

                   SET APCDDISP(I)=""

                   SET ^TMP("APCDEH",$JOB,"IDX",C,C)=""

 +6                SET J=I+APCDCUT

                   IF $DATA(APCDSEL(J))

                       IF '$DATA(APCDDISP(J))

                           SET $EXTRACT(^TMP("APCDEH",$JOB,C,0),28)=J_") "_$SELECT($DATA(APCDCSEL(J)):"*",1:" ")_$SELECT($PIECE(^APCDTKW(APCDSEL(J),0),U,12)="":$EXTRACT($PIECE(^APCDTKW(APCDSEL(J),0),U),1,20),1:$PIECE(^(0),U,12))

                           SET APCDDISP(J)=""

 +7                SET K=J+APCDCUT

                   IF $DATA(APCDSEL(K))

                       IF '$DATA(APCDDISP(K))

                           SET $EXTRACT(^TMP("APCDEH",$JOB,C,0),55)=K_") "_$SELECT($DATA(APCDCSEL(K)):"*",1:" ")_$SELECT($PIECE(^APCDTKW(APCDSEL(K),0),U,12)="":$EXTRACT($PIECE(^APCDTKW(APCDSEL(K),0),U),1,20),1:$PIECE(^(0),U,12))

                           SET APCDDISP(K)=""

               End DoDot:1

 +8        KILL APCDDISP,APCDOTHR

 +9        SET VALMCNT=C

 +10       QUIT

 +11      ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT

 +3       ;

EXIT      ; -- exit code

 +1        KILL DISP,APCDSEL,APCHIGH,APCDCUT,APCDANS,APCDC,APCDI,APCDX,APCDY,APCDCRIT,APCDTEXT,APCDMOD,APCDMODE,APCDMNE,APCDVLK,APCDLOOK

 +2        QUIT

 +3       ;

EOJ       ;

 +1        KILL VALMHDR,VALMCNT

 +2        DO EN^APCDEKL

 +3        DO EN2^APCDEKL

 +4        DO ^XBFMK

 +5        KILL APCDPAT,APCDVSIT,APCDCUT,APCDHIGH,APCDSEL,APCDDISP,APCDANS,APCDC,APCDI

 +6        KILL X,Y,C,I

 +7        DO KILL^AUPNPAT

 +8        QUIT

EXPND     ; -- expand code

 +1        QUIT

 +2       ;

TEXT      ;

 +1       ;;Patient Care Component (PCC)

 +2       ;;

 +3       ;;**********************************************************

 +4       ;;*****  PCC DATA ENTRY UPDATE HISTORICAL DATA BY ITEM *****

 +5       ;;**********************************************************

 +6       ;;

 +7        QUIT

APCDEH.m