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
