AMHLEA1 ; IHS/CMI/LAB - ADD NEW CHR ACTIVITY RECORDS ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;add new records
;get all items for a record, check record, file record
;if not complete record, issue warning and delete record
BEGIN ;add adm record
D GETTYPE
I AMHPTYPE="" D EXIT Q
D GETDATE
I AMHDATE="" D EXIT Q
D CREATE
D EXIT
Q
GETTYPE ;EP
S AMHPTYPE=""
S DIR(0)="S^M:MENTAL HEALTH DEFAULTS;S:SOCIAL SERVICES DEFAULTS;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER",DIR("A")="Which set of defaults do you want to use in Data Entry" K DA D ^DIR K DIR
Q:$D(DIRUT)
S AMHPTYPE=Y
Q
GETDATE ;EP - GET DATE OF ENCOUNTER
W !!
S AMHDATE="",DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter ENCOUNTER DATE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
S AMHDATE=Y
Q
CREATE ;EP
S AMHACTN=1
S APCDOVRR=""
K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHREC(",DLAYGO=9002011,DIADD=1,X=AMHDATE D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,$C(7),$C(7),"Behavioral Health Record is NOT complete!! Deleting Record.",! D PAUSE Q
S AMHR=+Y,DIE="^AMHREC(",DA=AMHR,DR="5100///NOW",DR(2,9002011.5101)=".02////^S X=DUZ" D ^DIE K DIE,DA,DR
D GETPROV
S DA=AMHR,DIE="^AMHREC(",DR="[AMH ADD ADM RECORD]" D CALLDIE^AMHLEIN
I $D(Y)!('$D(^AMHRPROV("AD",AMHR))) W !!,"Incomplete record!! Deleting record!!" D DEL G EXIT
D GETPOV
I '$D(^AMHRPRO("AD",AMHR))!('$D(^AMHRPROV("AD",AMHR))) W !!,"Incomplete record!! Deleting record!!" D DEL G EXIT
S AMHOKAY=0 D RECCHECK^AMHLE2 I AMHOKAY W !,"Incomplete record!! Deleting record!!" D DEL G EXIT
W ! S DIE="^AMHREC(",DR="8101",DA=AMHR D CALLDIE^AMHLEIN
;S X=$$ESIG^AMHESIG(AMHR)
;I X D ESIGGFI^AMHESIG
D EXIT
Q
EXIT ;
D ^XBFMK
D EN^XBVK("AMH")
Q
DEL ;EP
I $$IINTAKE^AMHLEDEL(AMHR) W !!,"This visit has an Initial Intake with Updates, it can not be deleted",!,"until the update documents have been deleted." D PAUSE Q
S AMHVDLT=$P(^AMHREC(AMHR,0),U,16)
S AMHRDEL=AMHR
D EN^AMHLEDEL
W !,"Record deleted." D PAUSE
Q
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
GETPROV ;get providers
K DIR,DIC,DA,DTOUT,DIRUT,DUOUT,DIC,X,Y S DIR("B")=$P(^VA(200,DUZ,0),U),DIR(0)="9002011.02,.01O",DIR("A")="Enter PRIMARY PROVIDER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=""
S X=+Y,DIC("DR")=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04///PRIMARY",DIC="^AMHRPROV(",DIC(0)="MLQ",DIADD=1,DLAYGO=9002011.02 K DD,DO D FILE^DICN K DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
I Y=-1 W !!,"Creating Primary Provider entry failed!!!",$C(7),$C(7) H 2
Q
GETPOV ;
D EN^XBNEW("EP^AMHLEA1","AMH*")
Q
EP ;EP - ask for POV and file each
I 'AMHR W !!,"NO RECORD DEFINED!!" Q
I '$D(^AMHREC(AMHR)) W !!,"NO RECORD!!" Q
S APCDOVRR=""
D POV
D CHK
Q
CHK ;
Q:$D(^AMHRPRO("AD",AMHR))
W !!,$C(7),$C(7),"At least ONE POV is REQUIRED!!"
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 $G(Y)=0 G EP
Q
POV ;
S DIC("A")=$S($G(AMHGROUP):"Enter another Problem (POV): ",'$D(^AMHRPRO("AD",AMHR)):"Enter PRIMARY Problem-POV: ",1:"Enter ANOTHER Problem-POV: "),DIC("S")="I '$P(^(0),U,13)",DIC="^AMHPROB(",DIC(0)="AEMQ",DIC("B")=99
W ! D ^DIC
I Y=-1 D ^XBFMK Q
S AMHPOV=$P(Y,U,2),AMHPOVP=+Y
;call FILE^DICN to file this POV
FILE ;
D ^XBFMK
K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHRPRO(",DLAYGO=9002011.01,DIADD=1,X=AMHPOVP,DIC("DR")="" D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 D ^XBFMK W !!,$C(7),$C(7),"Behavioral Health POV failed!! Notify Site Manager." Q
S AMHRPRO=+Y,AMHPOVR=^AMHRPRO(AMHRPRO,0)
D ^XBFMK
S DIE("NO^")="",DA=AMHRPRO,DIE="^AMHRPRO(",DR=".02////"_$G(AMHPAT)_";.03////"_AMHR_";.04 Provider Narrative.....:" S DIE("NO^")="" D CALLDIE^AMHLEIN
S AMHPOVR=^AMHRPRO(AMHRPRO,0)
I $P(AMHPOVR,U,4)="" S X=$E($P(^AMHPROB($P(AMHPOVR,U),0),U,2),1,79),X=$TR(X,";"," "),DIE="^AMHRPRO(",DR=".04///"_X,DA=AMHRPRO S DIE("NO^")="" D CALLDIE^AMHLEIN
I $D(Y) D ^XBFMK W !!,$C(7),$C(7),"DIE failed when updating POV" D PAUSE^AMHLEA Q
Q
AMHLEA1 ; IHS/CMI/LAB - ADD NEW CHR ACTIVITY RECORDS ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;add new records
+4 ;get all items for a record, check record, file record
+5 ;if not complete record, issue warning and delete record
BEGIN ;add adm record
+1 DO GETTYPE
+2 IF AMHPTYPE=""
DO EXIT
QUIT
+3 DO GETDATE
+4 IF AMHDATE=""
DO EXIT
QUIT
+5 DO CREATE
+6 DO EXIT
+7 QUIT
GETTYPE ;EP
+1 SET AMHPTYPE=""
+2 SET DIR(0)="S^M:MENTAL HEALTH DEFAULTS;S:SOCIAL SERVICES DEFAULTS;C:CHEMICAL DEPENDENCY or ALCOHOL/SUBSTANCE ABUSE;O:OTHER"
SET DIR("A")="Which set of defaults do you want to use in Data Entry"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 SET AMHPTYPE=Y
+5 QUIT
GETDATE ;EP - GET DATE OF ENCOUNTER
+1 WRITE !!
+2 SET AMHDATE=""
SET DIR(0)="DO^:"_DT_":EPTX"
SET DIR("A")="Enter ENCOUNTER DATE"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 SET AMHDATE=Y
+5 QUIT
CREATE ;EP
+1 SET AMHACTN=1
+2 SET APCDOVRR=""
+3 KILL DD,D0,DO,DINUM,DIC,DA,DR
SET DIC(0)="EL"
SET DIC="^AMHREC("
SET DLAYGO=9002011
SET DIADD=1
SET X=AMHDATE
DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+4 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health Record is NOT complete!! Deleting Record.",!
DO PAUSE
QUIT
+5 SET AMHR=+Y
SET DIE="^AMHREC("
SET DA=AMHR
SET DR="5100///NOW"
SET DR(2,9002011.5101)=".02////^S X=DUZ"
DO ^DIE
KILL DIE,DA,DR
+6 DO GETPROV
+7 SET DA=AMHR
SET DIE="^AMHREC("
SET DR="[AMH ADD ADM RECORD]"
DO CALLDIE^AMHLEIN
+8 IF $DATA(Y)!('$DATA(^AMHRPROV("AD",AMHR)))
WRITE !!,"Incomplete record!! Deleting record!!"
DO DEL
GOTO EXIT
+9 DO GETPOV
+10 IF '$DATA(^AMHRPRO("AD",AMHR))!('$DATA(^AMHRPROV("AD",AMHR)))
WRITE !!,"Incomplete record!! Deleting record!!"
DO DEL
GOTO EXIT
+11 SET AMHOKAY=0
DO RECCHECK^AMHLE2
IF AMHOKAY
WRITE !,"Incomplete record!! Deleting record!!"
DO DEL
GOTO EXIT
+12 WRITE !
SET DIE="^AMHREC("
SET DR="8101"
SET DA=AMHR
DO CALLDIE^AMHLEIN
+13 ;S X=$$ESIG^AMHESIG(AMHR)
+14 ;I X D ESIGGFI^AMHESIG
+15 DO EXIT
+16 QUIT
EXIT ;
+1 DO ^XBFMK
+2 DO EN^XBVK("AMH")
+3 QUIT
DEL ;EP
+1 IF $$IINTAKE^AMHLEDEL(AMHR)
WRITE !!,"This visit has an Initial Intake with Updates, it can not be deleted",!,"until the update documents have been deleted."
DO PAUSE
QUIT
+2 SET AMHVDLT=$PIECE(^AMHREC(AMHR,0),U,16)
+3 SET AMHRDEL=AMHR
+4 DO EN^AMHLEDEL
+5 WRITE !,"Record deleted."
DO PAUSE
+6 QUIT
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
GETPROV ;get providers
+1 KILL DIR,DIC,DA,DTOUT,DIRUT,DUOUT,DIC,X,Y
SET DIR("B")=$PIECE(^VA(200,DUZ,0),U)
SET DIR(0)="9002011.02,.01O"
SET DIR("A")="Enter PRIMARY PROVIDER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
QUIT
+3 IF Y=""
QUIT
+4 SET X=+Y
SET DIC("DR")=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04///PRIMARY"
SET DIC="^AMHRPROV("
SET DIC(0)="MLQ"
SET DIADD=1
SET DLAYGO=9002011.02
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DO,DD,D0,DG,DH,DI,DIW,DIU,DIADD,DIE,DQ,DLAYGO
+5 IF Y=-1
WRITE !!,"Creating Primary Provider entry failed!!!",$CHAR(7),$CHAR(7)
HANG 2
+6 QUIT
GETPOV ;
+1 DO EN^XBNEW("EP^AMHLEA1","AMH*")
+2 QUIT
EP ;EP - ask for POV and file each
+1 IF 'AMHR
WRITE !!,"NO RECORD DEFINED!!"
QUIT
+2 IF '$DATA(^AMHREC(AMHR))
WRITE !!,"NO RECORD!!"
QUIT
+3 SET APCDOVRR=""
+4 DO POV
+5 DO CHK
+6 QUIT
CHK ;
+1 IF $DATA(^AMHRPRO("AD",AMHR))
QUIT
+2 WRITE !!,$CHAR(7),$CHAR(7),"At least ONE POV is REQUIRED!!"
+3 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
+4 IF $GET(Y)=0
GOTO EP
+5 QUIT
POV ;
+1 SET DIC("A")=$SELECT($GET(AMHGROUP):"Enter another Problem (POV): ",'$DATA(^AMHRPRO("AD",AMHR)):"Enter PRIMARY Problem-POV: ",1:"Enter ANOTHER Problem-POV: ")
SET DIC("S")="I '$P(^(0),U,13)"
SET DIC="^AMHPROB("
SET DIC(0)="AEMQ"
SET DIC("B")=99
+2 WRITE !
DO ^DIC
+3 IF Y=-1
DO ^XBFMK
QUIT
+4 SET AMHPOV=$PIECE(Y,U,2)
SET AMHPOVP=+Y
+5 ;call FILE^DICN to file this POV
FILE ;
+1 DO ^XBFMK
+2 KILL DD,D0,DO,DINUM,DIC,DA,DR
SET DIC(0)="EL"
SET DIC="^AMHRPRO("
SET DLAYGO=9002011.01
SET DIADD=1
SET X=AMHPOVP
SET DIC("DR")=""
DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+3 IF Y=-1
DO ^XBFMK
WRITE !!,$CHAR(7),$CHAR(7),"Behavioral Health POV failed!! Notify Site Manager."
QUIT
+4 SET AMHRPRO=+Y
SET AMHPOVR=^AMHRPRO(AMHRPRO,0)
+5 DO ^XBFMK
+6 SET DIE("NO^")=""
SET DA=AMHRPRO
SET DIE="^AMHRPRO("
SET DR=".02////"_$GET(AMHPAT)_";.03////"_AMHR_";.04 Provider Narrative.....:"
SET DIE("NO^")=""
DO CALLDIE^AMHLEIN
+7 SET AMHPOVR=^AMHRPRO(AMHRPRO,0)
+8 IF $PIECE(AMHPOVR,U,4)=""
SET X=$EXTRACT($PIECE(^AMHPROB($PIECE(AMHPOVR,U),0),U,2),1,79)
SET X=$TRANSLATE(X,";"," ")
SET DIE="^AMHRPRO("
SET DR=".04///"_X
SET DA=AMHRPRO
SET DIE("NO^")=""
DO CALLDIE^AMHLEIN
+9 IF $DATA(Y)
DO ^XBFMK
WRITE !!,$CHAR(7),$CHAR(7),"DIE failed when updating POV"
DO PAUSE^AMHLEA
QUIT
+10 QUIT
