APCDEL.m

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

 ;;2.0;IHS PCC SUITE;;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 GETVISIT

 I APCDVSIT="" W !!,"No VISIT selected!" D EOJ Q

 D ^APCDEIN

 D EN,FULL^VALM1,EXIT K APCDPAT

 D EOJ

 Q

GETPAT ; GET PATIENT

 W !

 S APCDPAT=""

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

 Q:Y<0

 S APCDPAT=+Y

 Q

 ;

GETVISIT ;

 S APCDLOOK="",APCDVSIT=""

 K APCDVLK

 D ^APCDVLK

 I APCDLOOK S AUPNVSIT=APCDLOOK D MOD^AUPNVSIT

 S DIE="^AUPNPAT(",DR=".16///TODAY",DA=APCDPAT D ^DIE

 Q

 ;

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

 ;APCDPAT must = patient ien

 ;APCDVSIT  must = visit 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:'$G(APCDVSIT)

 Q:'$D(^AUPNVSIT(APCDVSIT))

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

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

 D ^APCDEIN

 D EN^VALM("APCD EL PCC DATA ENTRY")

 D CLEAR^VALM1

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

 D ^XBFMK

 Q

 ;

HDR ;EP -- header code

 S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(APCDPAT,0),U)_IOINORM_"   DOB: "_$$FTIME^VALM1($P(^DPT(APCDPAT,0),U,3))_"   Sex: "_$P(^DPT(APCDPAT,0),U,2)

 S VALMHDR(2)=VALMHDR(2)_"   HRN: "_$S($D(^AUPNPAT(APCDPAT,41,DUZ(2),0)):$P(^AUPNPAT(APCDPAT,41,DUZ(2),0),U,2),1:"????")

 I $G(APCDVSIT) S VALMHDR(3)="Visit Date:  "_$$FMTE^XLFDT($P(^AUPNVSIT(APCDVSIT,0),U))_"      Clinic:  "_$$VAL^XBDIQ1(9000010,APCDVSIT,.08)

 Q

 ;

INIT ;EP -- init variables and list array

 D GATHER ;gather up all problems

 S APCDOVRR="" ;for provider narrative lookup

 Q

 ;

GATHER ;EP

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

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

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

 S APCDCUT=APCDHIGH/3 S:APCDCUT'=(APCDCUT\1) APCDCUT=(APCDCUT\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("APCDEL",$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("APCDEL",$J,"IDX",C,C)=""

 .S J=I+APCDCUT I $D(APCDSEL(J)),'$D(APCDDISP(J)) S $E(^TMP("APCDEL",$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("APCDEL",$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,APCDCUT

 S VALMCNT=C

 Q

 ;

INIT2 ;EP

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

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

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

 S APCDCUT=APCDHIGH/3 S:APCDCUT'=(APCDCUT\1) APCDCUT=(APCDCUT\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("APCDEL",$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("APCDEL",$J,"IDX",C,C)=""

 .S J=I+APCDCUT I $D(APCDSEL(J)),'$D(APCDDISP(J)) S $E(^TMP("APCDEL",$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("APCDEL",$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

 Q

 ;

INIT3 ;EP

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

 S APCDHIGH=0,X=0 F  S X=$O(^APCDTKW("AH",X)) Q:X'=+X  S Y=$O(^APCDTKW("AH",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("APCDEL",$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("APCDEL",$J,"IDX",C,C)=""

 .S J=I+APCDCUT I $D(APCDSEL(J)),'$D(APCDDISP(J)) S $E(^TMP("APCDEL",$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("APCDEL",$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

 Q

 ;

HELP ; -- help code

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

 Q

 ;

EXIT ; -- exit code

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

 Q

 ;

EOJ ;

 K VALMHDR,VALMCNT

 D EN1^APCDEKL

 D EN2^APCDEKL

 D ^XBFMK

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

 K X,Y,C,I

 D KILL^AUPNPAT

 Q

EXPND ; -- expand code

 Q

 ;

TEXT ;

 ;;Patient Care Component (PCC)

 ;;

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

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

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

 ;;

 Q

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

 +1       ;;2.0;IHS PCC SUITE;;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 GETVISIT

 +8        IF APCDVSIT=""

               WRITE !!,"No VISIT selected!"

               DO EOJ

               QUIT 

 +9        DO ^APCDEIN

 +10       DO EN

           DO FULL^VALM1

           DO EXIT

           KILL APCDPAT

 +11       DO EOJ

 +12       QUIT 

GETPAT    ; GET PATIENT

 +1        WRITE !

 +2        SET APCDPAT=""

 +3        SET DIC="^AUPNPAT("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +4        IF Y<0

               QUIT 

 +5        SET APCDPAT=+Y

 +6        QUIT 

 +7       ;

GETVISIT  ;

 +1        SET APCDLOOK=""

           SET APCDVSIT=""

 +2        KILL APCDVLK

 +3        DO ^APCDVLK

 +4        IF APCDLOOK

               SET AUPNVSIT=APCDLOOK

               DO MOD^AUPNVSIT

 +5        SET DIE="^AUPNPAT("

           SET DR=".16///TODAY"

           SET DA=APCDPAT

           DO ^DIE

 +6        QUIT 

 +7       ;

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

 +1       ;APCDPAT must = patient ien

 +2       ;APCDVSIT  must = visit ien

 +3       ;caller must set APCDVSIT,APCDPAT

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

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

 +6        IF '$GET(APCDPAT)

               QUIT 

 +7        IF '$GET(APCDVSIT)

               QUIT 

 +8        IF '$DATA(^AUPNVSIT(APCDVSIT))

               QUIT 

 +9        IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,11)

               QUIT 

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

               QUIT 

 +11       DO ^APCDEIN

 +12       DO EN^VALM("APCD EL PCC DATA ENTRY")

 +13       DO CLEAR^VALM1

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

 +15       DO ^XBFMK

 +16       QUIT 

 +17      ;

HDR       ;EP -- header code

 +1        SET VALMHDR(2)="Patient Name: "_IORVON_$PIECE(^DPT(APCDPAT,0),U)_IOINORM_"   DOB: "_$$FTIME^VALM1($PIECE(^DPT(APCDPAT,0),U,3))_"   Sex: "_$PIECE(^DPT(APCDPAT,0),U,2)

 +2        SET VALMHDR(2)=VALMHDR(2)_"   HRN: "_$SELECT($DATA(^AUPNPAT(APCDPAT,41,DUZ(2),0)):$PIECE(^AUPNPAT(APCDPAT,41,DUZ(2),0),U,2),1:"????")

 +3        IF $GET(APCDVSIT)

               SET VALMHDR(3)="Visit Date:  "_$$FMTE^XLFDT($PIECE(^AUPNVSIT(APCDVSIT,0),U))_"      Clinic:  "_$$VAL^XBDIQ1(9000010,APCDVSIT,.08)

 +4        QUIT 

 +5       ;

INIT      ;EP -- init variables and list array

 +1       ;gather up all problems

           DO GATHER

 +2       ;for provider narrative lookup

           SET APCDOVRR=""

 +3        QUIT 

 +4       ;

GATHER    ;EP

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

 +2        SET APCDHIGH=0

           SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

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

               SET APCDHIGH=APCDHIGH+1

               SET APCDSEL(APCDHIGH)=Y

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

 +4        SET APCDCUT=APCDHIGH/3

           IF APCDCUT'=(APCDCUT\1)

               SET APCDCUT=(APCDCUT\1)+1

 +5        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

 +6                SET C=C+1

                   SET ^TMP("APCDEL",$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("APCDEL",$JOB,"IDX",C,C)=""

 +7                SET J=I+APCDCUT

                   IF $DATA(APCDSEL(J))

                       IF '$DATA(APCDDISP(J))

                           SET $EXTRACT(^TMP("APCDEL",$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)=""

 +8                SET K=J+APCDCUT

                   IF $DATA(APCDSEL(K))

                       IF '$DATA(APCDDISP(K))

                           SET $EXTRACT(^TMP("APCDEL",$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

 +9        KILL APCDDISP,APCDCUT

 +10       SET VALMCNT=C

 +11       QUIT 

 +12      ;

INIT2     ;EP

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

 +2        SET APCDHIGH=0

           SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

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

               SET APCDHIGH=APCDHIGH+1

               SET APCDSEL(APCDHIGH)=Y

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

 +4        SET APCDCUT=APCDHIGH/3

           IF APCDCUT'=(APCDCUT\1)

               SET APCDCUT=(APCDCUT\1)+1

 +5        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

 +6                SET C=C+1

                   SET ^TMP("APCDEL",$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("APCDEL",$JOB,"IDX",C,C)=""

 +7                SET J=I+APCDCUT

                   IF $DATA(APCDSEL(J))

                       IF '$DATA(APCDDISP(J))

                           SET $EXTRACT(^TMP("APCDEL",$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)=""

 +8                SET K=J+APCDCUT

                   IF $DATA(APCDSEL(K))

                       IF '$DATA(APCDDISP(K))

                           SET $EXTRACT(^TMP("APCDEL",$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

 +9        KILL APCDDISP,APCDOTHR

 +10       SET VALMCNT=C

 +11       QUIT 

 +12      ;

INIT3     ;EP

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

 +2        SET APCDHIGH=0

           SET X=0

           FOR 

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

               IF X'=+X

                   QUIT 

               SET Y=$ORDER(^APCDTKW("AH",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("APCDEL",$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("APCDEL",$JOB,"IDX",C,C)=""

 +6                SET J=I+APCDCUT

                   IF $DATA(APCDSEL(J))

                       IF '$DATA(APCDDISP(J))

                           SET $EXTRACT(^TMP("APCDEL",$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("APCDEL",$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 EN1^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 VISIT BY ITEM *****

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

 +6       ;;

 +7        QUIT