BCHUADD1.m

BCHUADD1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;IHS/CMI/LAB - fixed dir call to allow 1-30 characters

 ;

 ;

GETPAT ;EP

 W:$D(IOF) @IOF W !!!!!?15,"******   P A T I E N T   I N F O R M A T I O N   ******",!!

 W !,"If this encounter involved a particular patient, please enter the patient's",!,"chart # or name now.  If this is not a single patient encounter,",!,"but a group encounter or an Non-Patient encounter, simply HIT the"

 W !,"ENTER key to exit back and Enter N for All Other Activities.",!

 W !,"Please enter the patient information now.",!

 S DFN=""

 S DIR(0)="FO^1:30",DIR("A")="Enter PATIENT NAME or CHART #"

 S DIR("?",1)="     To find a patient, you can enter the patient's chart number;"

 S DIR("?",2)="     lastname,firstname; SSN; or DOB."

 S DIR("?",3)=" "

 S DIR("?",4)="     If the patient cannot be found in the Patient Registration"

 S DIR("?",5)="     database and you would like to capture demographic information"

 S DIR("?",6)="     for this patient into the CHR database, answer NO when asked"

 S DIR("?",7)="     if you would like to try another lookup.  You will then be"

 S DIR("?",8)="     given the opportunity to capture the patient's demographic"

 S DIR("?",9)="     data on the following screen."

 S DIR("?",10)=""

 S DIR("?",11)="     Registered patient demographic data can only be edited via the"

 S DIR("?")="     Patient Registration system."

 D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I X="" W !!,"No Patient entered.  Required " G ASK

 I $D(DIRUT) W !,"No patient entered!! - Required." G ASK

 S (X,BCHNAME)=Y,DIC="^AUPNPAT(",DIC(0)="MQE" D ^DIC K DIC

 ;I X="" W !!,"No Patient entered.  If this is not a patient related encounter use the ",!,"'All Other Activities option'.",! D PAUSE^BCHUTIL1 Q

 I Y=-1 D NOREG Q

 W !?25,"Ok" S %=1 D YN^DICN I %'=1 W !!,"Try again.",! G GETPAT

 S DFN=+Y D DIRX^BCHUADD S BCHF=".04",BCHV=""

 S DIE="^BCHR(",DA=BCHR,DR=".04///`"_DFN D ^DIE K DA,DIE,DR

 I $D(Y) W !!,"PATIENT NOT VALID!  TRY AGAIN" K Y G GETPAT

 Q

 ;

NOREG ;

 W !,"That patient cannot be found in the Registration database."

 W ! S DIR(0)="Y",DIR("A")="Do you want to try to lookup the patient in registration again",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) W !,"Exiting..." S BCHQUIT=1 Q

 I Y G GETPAT

 W !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!

 S DIC("B")=BCHNAME S DIC="^BCHRPAT(",DIC(0)="AEMQL" D ^DIC K DIC

 ;SCREENMAN CALL

 ;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW

 ;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS

 ;K DR,DA,DDSFILE,DIC,DIE

 ;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q

 ;Q:$G(^BCHR(BCHR,11))]""

 I Y=-1 W !!,"A patient is Required" G ASK

 S BCHNRPAT=+Y

 I $P(Y,U,3) D  I 1

 .W !!,"Please review and update if necessary this non-registered patient's data:"

 .S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR

 E  D

 .W !!,"You now have the opportunity to update this patient's demographic data,"

 .W !,"(DOB, Gender, Community of Residene, Tribe)",!

 .S DIR(0)="Y",DIR("A")="Do you want to update this patient's demographic information?",DIR("B")="N" KILL DA D ^DIR KILL DIR

 .I 'Y Q

 .I $D(DIRUT) Q

 .S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR

 ;UPDATE CHR RECORD FILE

 S DA=BCHR,DIE="^BCHR(",DR="1112////"_BCHNRPAT D ^DIE K DA,DIE,DR

 Q

ASK ;

 S DIR(0)="Y",DIR("A")="Do you wish to EXIT and DELETE this record",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) S BCHQUIT=1 Q

 I Y S BCHQUIT=1 Q

 G GETPAT

 ;

RECCHECK ;EP 

 K BCHOKAY,BCHERROR

 S BCHR0=^BCHR(BCHR,0)

 I $P(BCHR0,U,2)="" W !,"PROGRAM Missing!  " S BCHERROR=1

 I $P(BCHR0,U,3)="" W !,"PROVIDER/CHR Missing!  " S BCHERROR=1

 I $P(BCHR0,U,6)="" W !,"ACTIVITY LOCATION Missing!  " S BCHERROR=1

 I $P(BCHR0,U,11)="" W !,"TRAVEL TIME Missing!" S BCHERROR=1

 I $P(BCHR0,U,12)="" W !,"# SERVED Missing!" S BCHERROR=1

 I '$D(^BCHRPROB("AD",BCHR)) W !,"At least one ASSESSMENT/POV is Required and is Missing!  " S BCHERROR=1

 NEW X,Y

 S X=0 F  S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X  D

 .I $P(^BCHRPROB(X,0),U,1)="" W !,"Assessment Problem code Missing!" S BCHERROR=1

 .I $P(^BCHRPROB(X,0),U,4)="" W !,"Service Code for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!" S BCHERROR=1

 .I $P(^BCHRPROB(X,0),U,5)="" W !,"Service Minutes for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!" S BCHERROR=1

 .I $P(^BCHRPROB(X,0),U,6)="" W !,"Narrative for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!" S BCHERROR=1

 I $P(^BCHR(BCHR,0),U,4)="",$P($G(^BCHR(BCHR,11)),U,12)="" G E

 I '$P(^BCHR(BCHR,0),U,12) G E  ;non patient

 I $P(^BCHR(BCHR,0),U,29) G E

 I '$O(^BCHR(BCHR,41,0)) W !,"REFERRED TO CHR BY is Missing and is Required!  " S BCHERROR=1

 I '$O(^BCHR(BCHR,42,0)) W !,"REFERRED BY CHR TO is Missing and is Required!  " S BCHERROR=1

E ;do you wish to edit?  if not, delete, if yes, go back to edit

 Q:'$G(BCHERROR)

 S DIR(0)="S^E:Edit the Record and Correct the Error;D:Delete the Record",DIR("A")="Do you wish to",DIR("B")="E" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 I $G(BCHUEDT) D EDIT Q

 I Y="D" Q

 D GETRECD^BCHUADD

 G RECCHECK

EDIT ;

 I Y="D" D EXITMSG^BCHUADD S BCHRWDEL=1 Q

 D 2^BCHUEDT

 G RECCHECK

PROTOCOL ;PEP - announce chr record has been added

 Q  ;NO PCC LINK PER V2.0 SPECS

 D SETARRAY

 S X=+$O(^ORD(101,"B","BCH CHR RECORD EVENT",0))_";ORD(101,"

 D EN^XQOR

 K BCHEV ;kill event array

 Q

SETARRAY ;set up array for pcc protocol call

 S BCHEV("PKG")=$O(^DIC(9.4,"C","BCH","")),BCHPKG=BCHEV("PKG") ;apcdpkg - system wide, required by pcc link

 S BCHEV("SITE")=^BCHSITE(DUZ(2),0) ;pass site parameters

 S BCHEV("CHR IEN")=BCHR ;record in CHR RECORD FILE

 S BCHEV("DATA0")=^BCHR(BCHR,0)

 S BCHEV("DATA12")=$G(^BCHR(BCHR,12))

 S BCHEV("DATA13")=$G(^BCHR(BCHR,13))

 I $P(BCHEV("DATA0"),U,6) S BCHEV("ACTLOC")=^BCHTACTL($P(BCHEV("DATA0"),U,6),0)

 S (X,C)=0 F  S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X=""  D

 .Q:'$D(^BCHRPROB(X,0))

 .Q:$P(^BCHRPROB(X,0),U)=""

 .Q:$P(^BCHRPROB(X,0),U,4)=""

 .Q:$P(^BCHRPROB(X,0),U,6)=""

 .S C=C+1,BCHEV("POV",C)=^BCHRPROB(X,0),BCHEV("POV",C,"ICD9")=$P(^BCHTPROB($P(^BCHRPROB(X,0),U),0),U,5),BCHEV("POV",C,"SRV")=^BCHTSERV($P(^BCHRPROB(X,0),U,4),0)

 S (X,C)=0 F  S X=$O(^BCHRPED("AD",BCHR,X)) Q:X=""  D

 .Q:'$D(^BCHRPED(X,0))

 .Q:$P(^BCHRPED(X,0),U)=""

 .S C=C+1,BCHEV("EDUC",C)=^BCHRPED(X,0)

 K C,X

 Q

UPNONREG ;EP

 W !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!

 S DIC="^BCHRPAT(",DIC(0)="AEMQL" D ^DIC K DIC

 ;SCREENMAN CALL

 ;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW

 ;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS

 ;K DR,DA,DDSFILE,DIC,DIE

 ;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q

 ;Q:$G(^BCHR(BCHR,11))]""

 I Y=-1 K DIC,Y Q

 S BCHNRPAT=+Y

 W !!,"Please review and update if necessary this non-registered patient's data:"

 S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR

 Q

BCHUADD1  ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ; 

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;IHS/CMI/LAB - fixed dir call to allow 1-30 characters

 +3       ;

 +4       ;

GETPAT    ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

           WRITE !!!!!?15,"******   P A T I E N T   I N F O R M A T I O N   ******",!!

 +2        WRITE !,"If this encounter involved a particular patient, please enter the patient's",!,"chart # or name now.  If this is not a single patient encounter,",!,"but a group encounter or an Non-Patient encounter, simply HIT the"

 +3        WRITE !,"ENTER key to exit back and Enter N for All Other Activities.",!

 +4        WRITE !,"Please enter the patient information now.",!

 +5        SET DFN=""

 +6        SET DIR(0)="FO^1:30"

           SET DIR("A")="Enter PATIENT NAME or CHART #"

 +7        SET DIR("?",1)="     To find a patient, you can enter the patient's chart number;"

 +8        SET DIR("?",2)="     lastname,firstname; SSN; or DOB."

 +9        SET DIR("?",3)=" "

 +10       SET DIR("?",4)="     If the patient cannot be found in the Patient Registration"

 +11       SET DIR("?",5)="     database and you would like to capture demographic information"

 +12       SET DIR("?",6)="     for this patient into the CHR database, answer NO when asked"

 +13       SET DIR("?",7)="     if you would like to try another lookup.  You will then be"

 +14       SET DIR("?",8)="     given the opportunity to capture the patient's demographic"

 +15       SET DIR("?",9)="     data on the following screen."

 +16       SET DIR("?",10)=""

 +17       SET DIR("?",11)="     Registered patient demographic data can only be edited via the"

 +18       SET DIR("?")="     Patient Registration system."

 +19       DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +20       IF X=""

               WRITE !!,"No Patient entered.  Required "

               GOTO ASK

 +21       IF $DATA(DIRUT)

               WRITE !,"No patient entered!! - Required."

               GOTO ASK

 +22       SET (X,BCHNAME)=Y

           SET DIC="^AUPNPAT("

           SET DIC(0)="MQE"

           DO ^DIC

           KILL DIC

 +23      ;I X="" W !!,"No Patient entered.  If this is not a patient related encounter use the ",!,"'All Other Activities option'.",! D PAUSE^BCHUTIL1 Q

 +24       IF Y=-1

               DO NOREG

               QUIT 

 +25       WRITE !?25,"Ok"

           SET %=1

           DO YN^DICN

           IF %'=1

               WRITE !!,"Try again.",!

               GOTO GETPAT

 +26       SET DFN=+Y

           DO DIRX^BCHUADD

           SET BCHF=".04"

           SET BCHV=""

 +27       SET DIE="^BCHR("

           SET DA=BCHR

           SET DR=".04///`"_DFN

           DO ^DIE

           KILL DA,DIE,DR

 +28       IF $DATA(Y)

               WRITE !!,"PATIENT NOT VALID!  TRY AGAIN"

               KILL Y

               GOTO GETPAT

 +29       QUIT 

 +30      ;

NOREG     ;

 +1        WRITE !,"That patient cannot be found in the Registration database."

 +2        WRITE !

           SET DIR(0)="Y"

           SET DIR("A")="Do you want to try to lookup the patient in registration again"

           SET DIR("B")="Y"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               WRITE !,"Exiting..."

               SET BCHQUIT=1

               QUIT 

 +4        IF Y

               GOTO GETPAT

 +5        WRITE !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!

 +6        SET DIC("B")=BCHNAME

           SET DIC="^BCHRPAT("

           SET DIC(0)="AEMQL"

           DO ^DIC

           KILL DIC

 +7       ;SCREENMAN CALL

 +8       ;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW

 +9       ;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS

 +10      ;K DR,DA,DDSFILE,DIC,DIE

 +11      ;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q

 +12      ;Q:$G(^BCHR(BCHR,11))]""

 +13       IF Y=-1

               WRITE !!,"A patient is Required"

               GOTO ASK

 +14       SET BCHNRPAT=+Y

 +15       IF $PIECE(Y,U,3)

               Begin DoDot:1

 +16               WRITE !!,"Please review and update if necessary this non-registered patient's data:"

 +17               SET DIE="^BCHRPAT("

                   SET DR="[BCH EDIT NON REG PT]"

                   SET DA=BCHNRPAT

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

               IF 1

 +18      IF '$TEST

               Begin DoDot:1

 +19               WRITE !!,"You now have the opportunity to update this patient's demographic data,"

 +20               WRITE !,"(DOB, Gender, Community of Residene, Tribe)",!

 +21               SET DIR(0)="Y"

                   SET DIR("A")="Do you want to update this patient's demographic information?"

                   SET DIR("B")="N"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +22               IF 'Y

                       QUIT 

 +23               IF $DATA(DIRUT)

                       QUIT 

 +24               SET DIE="^BCHRPAT("

                   SET DR="[BCH EDIT NON REG PT]"

                   SET DA=BCHNRPAT

                   DO ^DIE

                   KILL DA,DIE,DR

               End DoDot:1

 +25      ;UPDATE CHR RECORD FILE

 +26       SET DA=BCHR

           SET DIE="^BCHR("

           SET DR="1112////"_BCHNRPAT

           DO ^DIE

           KILL DA,DIE,DR

 +27       QUIT 

ASK       ;

 +1        SET DIR(0)="Y"

           SET DIR("A")="Do you wish to EXIT and DELETE this record"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               SET BCHQUIT=1

               QUIT 

 +3        IF Y

               SET BCHQUIT=1

               QUIT 

 +4        GOTO GETPAT

 +5       ;

RECCHECK  ;EP 

 +1        KILL BCHOKAY,BCHERROR

 +2        SET BCHR0=^BCHR(BCHR,0)

 +3        IF $PIECE(BCHR0,U,2)=""

               WRITE !,"PROGRAM Missing!  "

               SET BCHERROR=1

 +4        IF $PIECE(BCHR0,U,3)=""

               WRITE !,"PROVIDER/CHR Missing!  "

               SET BCHERROR=1

 +5        IF $PIECE(BCHR0,U,6)=""

               WRITE !,"ACTIVITY LOCATION Missing!  "

               SET BCHERROR=1

 +6        IF $PIECE(BCHR0,U,11)=""

               WRITE !,"TRAVEL TIME Missing!"

               SET BCHERROR=1

 +7        IF $PIECE(BCHR0,U,12)=""

               WRITE !,"# SERVED Missing!"

               SET BCHERROR=1

 +8        IF '$DATA(^BCHRPROB("AD",BCHR))

               WRITE !,"At least one ASSESSMENT/POV is Required and is Missing!  "

               SET BCHERROR=1

 +9        NEW X,Y

 +10       SET X=0

           FOR 

               SET X=$ORDER(^BCHRPROB("AD",BCHR,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +11               IF $PIECE(^BCHRPROB(X,0),U,1)=""

                       WRITE !,"Assessment Problem code Missing!"

                       SET BCHERROR=1

 +12               IF $PIECE(^BCHRPROB(X,0),U,4)=""

                       WRITE !,"Service Code for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!"

                       SET BCHERROR=1

 +13               IF $PIECE(^BCHRPROB(X,0),U,5)=""

                       WRITE !,"Service Minutes for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!"

                       SET BCHERROR=1

 +14               IF $PIECE(^BCHRPROB(X,0),U,6)=""

                       WRITE !,"Narrative for Assessment ",$$VAL^XBDIQ1(90002.01,X,.01)," is Missing!"

                       SET BCHERROR=1

               End DoDot:1

 +15       IF $PIECE(^BCHR(BCHR,0),U,4)=""

               IF $PIECE($GET(^BCHR(BCHR,11)),U,12)=""

                   GOTO E

 +16      ;non patient

           IF '$PIECE(^BCHR(BCHR,0),U,12)

               GOTO E

 +17       IF $PIECE(^BCHR(BCHR,0),U,29)

               GOTO E

 +18       IF '$ORDER(^BCHR(BCHR,41,0))

               WRITE !,"REFERRED TO CHR BY is Missing and is Required!  "

               SET BCHERROR=1

 +19       IF '$ORDER(^BCHR(BCHR,42,0))

               WRITE !,"REFERRED BY CHR TO is Missing and is Required!  "

               SET BCHERROR=1

E         ;do you wish to edit?  if not, delete, if yes, go back to edit

 +1        IF '$GET(BCHERROR)

               QUIT 

 +2        SET DIR(0)="S^E:Edit the Record and Correct the Error;D:Delete the Record"

           SET DIR("A")="Do you wish to"

           SET DIR("B")="E"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        IF $GET(BCHUEDT)

               DO EDIT

               QUIT 

 +5        IF Y="D"

               QUIT 

 +6        DO GETRECD^BCHUADD

 +7        GOTO RECCHECK

EDIT      ;

 +1        IF Y="D"

               DO EXITMSG^BCHUADD

               SET BCHRWDEL=1

               QUIT 

 +2        DO 2^BCHUEDT

 +3        GOTO RECCHECK

PROTOCOL  ;PEP - announce chr record has been added

 +1       ;NO PCC LINK PER V2.0 SPECS

           QUIT 

 +2        DO SETARRAY

 +3        SET X=+$ORDER(^ORD(101,"B","BCH CHR RECORD EVENT",0))_";ORD(101,"

 +4        DO EN^XQOR

 +5       ;kill event array

           KILL BCHEV

 +6        QUIT 

SETARRAY  ;set up array for pcc protocol call

 +1       ;apcdpkg - system wide, required by pcc link

           SET BCHEV("PKG")=$ORDER(^DIC(9.4,"C","BCH",""))

           SET BCHPKG=BCHEV("PKG")

 +2       ;pass site parameters

           SET BCHEV("SITE")=^BCHSITE(DUZ(2),0)

 +3       ;record in CHR RECORD FILE

           SET BCHEV("CHR IEN")=BCHR

 +4        SET BCHEV("DATA0")=^BCHR(BCHR,0)

 +5        SET BCHEV("DATA12")=$GET(^BCHR(BCHR,12))

 +6        SET BCHEV("DATA13")=$GET(^BCHR(BCHR,13))

 +7        IF $PIECE(BCHEV("DATA0"),U,6)

               SET BCHEV("ACTLOC")=^BCHTACTL($PIECE(BCHEV("DATA0"),U,6),0)

 +8        SET (X,C)=0

           FOR 

               SET X=$ORDER(^BCHRPROB("AD",BCHR,X))

               IF X=""

                   QUIT 

               Begin DoDot:1

 +9                IF '$DATA(^BCHRPROB(X,0))

                       QUIT 

 +10               IF $PIECE(^BCHRPROB(X,0),U)=""

                       QUIT 

 +11               IF $PIECE(^BCHRPROB(X,0),U,4)=""

                       QUIT 

 +12               IF $PIECE(^BCHRPROB(X,0),U,6)=""

                       QUIT 

 +13               SET C=C+1

                   SET BCHEV("POV",C)=^BCHRPROB(X,0)

                   SET BCHEV("POV",C,"ICD9")=$PIECE(^BCHTPROB($PIECE(^BCHRPROB(X,0),U),0),U,5)

                   SET BCHEV("POV",C,"SRV")=^BCHTSERV($PIECE(^BCHRPROB(X,0),U,4),0)

               End DoDot:1

 +14       SET (X,C)=0

           FOR 

               SET X=$ORDER(^BCHRPED("AD",BCHR,X))

               IF X=""

                   QUIT 

               Begin DoDot:1

 +15               IF '$DATA(^BCHRPED(X,0))

                       QUIT 

 +16               IF $PIECE(^BCHRPED(X,0),U)=""

                       QUIT 

 +17               SET C=C+1

                   SET BCHEV("EDUC",C)=^BCHRPED(X,0)

               End DoDot:1

 +18       KILL C,X

 +19       QUIT 

UPNONREG  ;EP

 +1        WRITE !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!

 +2        SET DIC="^BCHRPAT("

           SET DIC(0)="AEMQL"

           DO ^DIC

           KILL DIC

 +3       ;SCREENMAN CALL

 +4       ;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW

 +5       ;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS

 +6       ;K DR,DA,DDSFILE,DIC,DIE

 +7       ;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q

 +8       ;Q:$G(^BCHR(BCHR,11))]""

 +9        IF Y=-1

               KILL DIC,Y

               QUIT 

 +10       SET BCHNRPAT=+Y

 +11       WRITE !!,"Please review and update if necessary this non-registered patient's data:"

 +12       SET DIE="^BCHRPAT("

           SET DR="[BCH EDIT NON REG PT]"

           SET DA=BCHNRPAT

           DO ^DIE

           KILL DA,DIE,DR

 +13       QUIT