Routine: APCDEPO

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

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

GETLOC ; GET LOCATION

 S APCDLOC=DUZ(2)

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

 Q:Y<0

 S APCDLOC=+Y

GETDATE ; GET DATE

 S APCDDATE=DT

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

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

EOJ ; END OF JOB

 D ^APCDEKL

 K APCDEPO

 K %DT,%W,%A,C,DI,DIG,DIH,DIPGM,DIW

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       ;;

APCDEPO.m