APCDEPO ; IHS/CMI/LAB - ENTER NON-VISIT DATA ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
; APCDFLG=0 ... RUN
; APCDFLG=1 ... ERROR
;
; APCDMODE=A ... ADD
; APCDMODE=M ... MOD
HDR ; Write Header
W:$D(IOF) @IOF
F APCDJ=1:1:7 S APCDX=$P($T(TEXT+APCDJ),";;",2) W !?80-$L(APCDX)\2,APCDX
K APCDX,APCDJ
;W !!
;
D ^APCDEIN
Q:APCDFLG
S APCDPAT="",APCDEPO=1
;F APCDL=0:0 S APCDPAT="" D GETPAT Q:APCDPAT="" F APCDL=0:0 S APCDLOC="" D GETLOC Q:APCDLOC="" F APCDL=0:0 S APCDDATE="" D GETDATE Q:APCDDATE="" F APCDL=0:0 D PROCESS Q:APCDEMF
F S APCDPAT="" D GETPAT Q:APCDPAT=""
D EOJ
Q
;
GETPAT ; GET PATIENT
I APCDPAT S DIE="^AUPNPAT(",DR=".16///TODAY",DA=APCDPAT D ^DIE
W !
S APCDPAT=""
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
S APCDPAT=+Y
S APCDDATE=DT,APCDLOC=DUZ(2)
I AUPNDOB]"" S X2=AUPNDOB,X1=APCDDATE D ^%DTC S AUPNDAYS=X ; re-set days of age to visit date-dob
D GETMNE
Q
;
GETLOC ; GET LOCATION
S APCDLOC=DUZ(2)
Q
S APCDLOC="" S DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC
Q:Y<0
S APCDLOC=+Y
Q
;
GETDATE ; GET DATE
S APCDDATE=DT
Q
;
;
PROCESS ; PROCESS MNEMONIC
D GETMNE
K DIU,DIV S DIE="^AUPNPAT(",DR=".16///TODAY",DA=APCDPAT D ^DIE K DIV,DIU,DIE,DR,DA
S APCDEMF=1
Q
;
GETMNE ; GET MNEMONIC
W !
S DIR(0)="S^A:ADD a Problem;M:Modify a Problem",DIR("A")="Do you want to",DIR("B")="A" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) GETMNEK
S APCDMODE=Y
S X="PO",DIC="^APCDTKW(",DIC(0)="E",DIC("S")="I $L($P(^(0),U))<5,'$P(^(0),U,8)" D ^DIC K DIC("A"),DIC("S")
G:Y<0 GETMNEK
S APCDMNE=+Y,APCDMNE("NAME")=$P(Y,U,2)
D ^APCDEA3
S APCDDATE="" G GETMNEK
;
;
GETMNEK ; KILL GETMNE SPECIFIC VARIABLES
K APCDVSIT,APCDX
Q
;
EOJ ; END OF JOB
D ^APCDEKL
K APCDEPO
K %DT,%W,%A,C,DI,DIG,DIH,DIPGM,DIW
Q
TEXT ;
;;
;;PCC Data Entry Module
;;
;;*******************************
;;* Entry of PROBLEM Data *
;;*******************************
;;
APCDEPO ; IHS/CMI/LAB - ENTER NON-VISIT DATA ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ; APCDFLG=0 ... RUN
+4 ; APCDFLG=1 ... ERROR
+5 ;
+6 ; APCDMODE=A ... ADD
+7 ; APCDMODE=M ... MOD
HDR ; Write Header
+1 IF $DATA(IOF)
WRITE @IOF
+2 FOR APCDJ=1:1:7
SET APCDX=$PIECE($TEXT(TEXT+APCDJ),";;",2)
WRITE !?80-$LENGTH(APCDX)\2,APCDX
+3 KILL APCDX,APCDJ
+4 ;W !!
+5 ;
+6 DO ^APCDEIN
+7 IF APCDFLG
QUIT
+8 SET APCDPAT=""
SET APCDEPO=1
+9 ;F APCDL=0:0 S APCDPAT="" D GETPAT Q:APCDPAT="" F APCDL=0:0 S APCDLOC="" D GETLOC Q:APCDLOC="" F APCDL=0:0 S APCDDATE="" D GETDATE Q:APCDDATE="" F APCDL=0:0 D PROCESS Q:APCDEMF
+10 FOR
SET APCDPAT=""
DO GETPAT
IF APCDPAT=""
QUIT
+11 DO EOJ
+12 QUIT
+13 ;
GETPAT ; GET PATIENT
+1 IF APCDPAT
SET DIE="^AUPNPAT("
SET DR=".16///TODAY"
SET DA=APCDPAT
DO ^DIE
+2 WRITE !
+3 SET APCDPAT=""
+4 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+5 IF Y<0
QUIT
+6 SET APCDPAT=+Y
+7 SET APCDDATE=DT
SET APCDLOC=DUZ(2)
+8 ; re-set days of age to visit date-dob
IF AUPNDOB]""
SET X2=AUPNDOB
SET X1=APCDDATE
DO ^%DTC
SET AUPNDAYS=X
+9 DO GETMNE
+10 QUIT
+11 ;
GETLOC ; GET LOCATION
+1 SET APCDLOC=DUZ(2)
+2 QUIT
+3 SET APCDLOC=""
SET DIC="^AUTTLOC("
SET DIC(0)="AEMQ"
DO ^DIC
+4 IF Y<0
QUIT
+5 SET APCDLOC=+Y
+6 QUIT
+7 ;
GETDATE ; GET DATE
+1 SET APCDDATE=DT
+2 QUIT
+3 ;
+4 ;
PROCESS ; PROCESS MNEMONIC
+1 DO GETMNE
+2 KILL DIU,DIV
SET DIE="^AUPNPAT("
SET DR=".16///TODAY"
SET DA=APCDPAT
DO ^DIE
KILL DIV,DIU,DIE,DR,DA
+3 SET APCDEMF=1
+4 QUIT
+5 ;
GETMNE ; GET MNEMONIC
+1 WRITE !
+2 SET DIR(0)="S^A:ADD a Problem;M:Modify a Problem"
SET DIR("A")="Do you want to"
SET DIR("B")="A"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
GOTO GETMNEK
+4 SET APCDMODE=Y
+5 SET X="PO"
SET DIC="^APCDTKW("
SET DIC(0)="E"
SET DIC("S")="I $L($P(^(0),U))<5,'$P(^(0),U,8)"
DO ^DIC
KILL DIC("A"),DIC("S")
+6 IF Y<0
GOTO GETMNEK
+7 SET APCDMNE=+Y
SET APCDMNE("NAME")=$PIECE(Y,U,2)
+8 DO ^APCDEA3
+9 SET APCDDATE=""
GOTO GETMNEK
+10 ;
+11 ;
GETMNEK ; KILL GETMNE SPECIFIC VARIABLES
+1 KILL APCDVSIT,APCDX
+2 QUIT
+3 ;
EOJ ; END OF JOB
+1 DO ^APCDEKL
+2 KILL APCDEPO
+3 KILL %DT,%W,%A,C,DI,DIG,DIH,DIPGM,DIW
+4 QUIT
TEXT ;
+1 ;;
+2 ;;PCC Data Entry Module
+3 ;;
+4 ;;*******************************
+5 ;;* Entry of PROBLEM Data *
+6 ;;*******************************
+7 ;;
