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
Q
GETLOC ; GET LOCATION
S APCDLOC="" S DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC
Q:Y<0
S APCDLOC=+Y
Q
;
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
Q
;
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
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
Q
;
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)
Q
;
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
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 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
Q
EXPND ; -- expand code
Q
;
TEXT ;
;;Patient Care Component (PCC)
;;
;;**********************************************************
;;***** PCC DATA ENTRY UPDATE HISTORICAL DATA BY ITEM *****
;;**********************************************************
;;
Q
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
