Routine: AMHUTIL1

AMHUTIL1 ; IHS/CMI/LAB - provider functions 06 Aug 2009 11:15 AM ;

 ;;4.0;IHS BEHAVIORAL HEALTH;**1,2,4,5**;JUN 02, 2010;Build 18

 ;IHS/CMI/LAB - added stage as output parameter

 ;IHS/TUCSON/LAB - patch 1 05/19/97 - fixed setting of array

DEMO(P,T) ;EP - called to exclude demo patients

 I $G(P)="" Q 0

 I $G(T)="" S T="I"

 I T="I" Q 0

 NEW R

 S R=""

 I T="E" D  Q R

 .I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=1 Q

 .NEW %

 .S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 .I '% S R=0 Q

 .I $D(^DIBT(%,1,P)) S R=1 Q

 I T="O" D  Q R

 .I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=0 Q

 .NEW %

 .S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 .I '% S R=1 Q

 .I $D(^DIBT(%,1,P)) S R=0 Q

 .S R=1 Q

Q 0

DEMOCHK(R) ;EP - check demo pat

 NEW DIR,DA

 S R=-1

 S DIR(0)="S^I:Include ALL Patients;E:Exclude DEMO Patients;O:Include ONLY DEMO Patients",DIR("A")="Demo Patient Inclusion/Exclusion",DIR("B")="E"

 KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S R=-1 Q

 S R=Y

CHKD(Y,D) ;EP check dsm with Date

 S D=$G(D)

 I 'Y Q 0

 I '$D(^AMHPROB(Y,0)) Q 0

 ;FIRST LETS FIGURE OUT IF WE WANT IV OR V AND THEN MOVE ON

 S DSC=$$DSMCS(DUZ(2),D)

 S CS=$P(^AMHPROB(Y,0),U,10) I CS=4!(CS=5),CS'=DSC Q 0  ;NOT CORRECT CODING SYSTEM

 NEW M,Z,J

 S M=$P(^AMHPROB(Y,0),U,13) I M D  I 'Z Q Z

 .S Z=1

 .S J=$P(^AMHPROB(Y,0),U,14)

 .I J="" S Z=0 Q

 .I D]"",J]"",J<D S Z=0

 .I D="" S Z=0

 NEW IMP S IMP=$$IMP^AMHUTIL2($S(D:D,1:DT))

 NEW I S I=$P(^AMHPROB(Y,0),U,5)

 ;I I="" Q $P(^AMHPROB(Y,0),U,13)  ;cmi/maw orig

 I IMP=1,$P(^AMHPROB(Y,0),U,5)="",$P(^AMHPROB(Y,0),U,17)]"" Q 0

 I IMP=30,$P(^AMHPROB(Y,0),U,17)="",$P(^AMHPROB(Y,0),U,5)]"" Q 0

 I IMP=1 S I=$P(^AMHPROB(Y,0),U,5)  ;GET ICD9 code that this is mapped to

 I IMP=30 S I=$P(^AMHPROB(Y,0),U,17)

 I I="" Q $S($P(^AMHPROB(Y,0),U,13):0,1:1)  ;cmi/maw modified

 Q $$POVICD9D(I,D)

CHKICD(Y,D,R,A,E) ;EP

 S D=$G(D)

 S R=$G(R)

 S A=$G(A)

 S E=$G(E)

 I $$POVICD9(Y,D,R,A,E)

 Q:$D(^AMHPROB(Y))

DSMCS(S,D) ;EP - called to get coding system

 ;s is site DUZ(2)

 ;d is date

 ;if can't determine default to DSM IV

 I '$G(S) S S=DUZ(2)

 I '$G(D) S D=DT

 I '$D(^AMHSITE(S,0)) Q 4  ;NO SITE PARAMETER FILE SO DEFAULT TO 4

 NEW C,I

 S C=$P($G(^AMHSITE(S,18)),U,11)  ;DATE, IF NO DATE USE 4

 I C="" Q 4

 I D<C Q 4

Q 5

DSMVDT(S) ;

 ;s is site DUZ(2)

 ;if can't determine default to DSM IV

 I '$G(S) S S=DUZ(2)

 I '$D(^AMHSITE(S,0)) Q 4  ;NO SITE PARAMETER FILE SO DEFAULT TO 4

 NEW C,I

 S C=$P($G(^AMHSITE(S,18)),U,11)  ;DATE, IF NO DATE USE 4

Q C

POVICD9(Y,D,R,A,E) ;EP

 ;Y=ien of entry in MHSS PROBLEM/DSM CODE file

 ;E - indicates we are in EHR so it is accepted since PCC accepted it

 ;R - ien of MHSS RECORD if known and in a record

 ;D - date of visit for which this pov is being added

 ;A - equal to DA of MHSS RECORD PROBLEMS file, to be used if in fileman's edit??? and not in BH software?, maybe someone is doing D P^DI and editting the .01 field of the file??

 I $G(E) Q 1  ;take whatever EHR passes as EHR rules

 S R=$G(R)

 S D=$G(D)

 S A=$G(A)

 S Y=$G(Y)

 I 'Y Q 0  ;pass an IEN!

 NEW I,V,M,Z,J,K,IMP,DCS,CS

 ;FIRST LETS FIGURE OUT IF WE WANT IV OR V AND THEN MOVE ON

 ;S DSC=$$DSMCS(DUZ(2),D)

 I '$G(E),$P(^AMHPROB(Y,0),U,18) Q 0  ;NOT SELECTABLE IN BH ENTRY

 S IMP=$$IMP^AMHUTIL2($S(R:$P($P($G(^AMHREC(R,0)),U),"."),1:DT))

 ;If IMP is 1 allow any with an icd9 pointer or if both icd9 and icd10 are blank

 ;If IMP is 30 allow any with an icd10 pointer or if both icd9 and icd10 are blank

 I '$D(^AMHPROB(Y,0)) Q 0  ;pass a VALID IEN!

 ;FIRST LETS FIGURE OUT IF WE WANT IV OR V AND THEN MOVE ON

 S DSC=$$DSMCS(DUZ(2),D)

 S CS=$P(^AMHPROB(Y,0),U,10) I CS=4!(CS=5),CS'=DSC Q 0  ;NOT CORRECT CODING SYSTEM

 S M=$P(^AMHPROB(Y,0),U,13) I M D  I 'Z Q Z

 .S Z=1

 .S J=$P(^AMHPROB(Y,0),U,14)

 .I J="" S Z=0 Q

 .I D="",R S D=$P($P($G(^AMHREC(R,0)),U),".")

 .I D="" S D=DT

 .I D]"",J]"",J'>D S Z=0

 .I D="" S Z=0

 S J=$P(^AMHPROB(Y,0),U,16)

 I J D  I 'Z Q Z

 .S Z=1

 .I D="",R S D=$P($P($G(^AMHREC(R,0)),U),".")

 .I D]"",J]"",J>D S Z=0

 .I J>DT S Z=0

 I IMP=1,$P(^AMHPROB(Y,0),U,5)="",$P(^AMHPROB(Y,0),U,17)]"" Q 0

 I IMP=30,$P(^AMHPROB(Y,0),U,17)="",$P(^AMHPROB(Y,0),U,5)]"" Q 0

 I IMP=1 S I=$P(^AMHPROB(Y,0),U,5)  ;GET ICD9 code that this is mapped to

 I IMP=30 S I=$P(^AMHPROB(Y,0),U,17)

 I I="" Q $S('$P(^AMHPROB(Y,0),U,13):1,1:0)   ;if there is no icd code to look at then just check status field and quit

 ;now figure out if valid based on what data is passed.

 ;if passed in D, use it and quit

 I D Q $$POVICD9D(I,D)

 I R,$D(^AMHREC(R,0)) S D=$P($P(^AMHREC(R,0),U,1),".") Q $$POVICD9D(I,D)

 I A S V=$P($G(^AMHRPRO(A,0)),U,3) I V,$D(^AMHREC(V,0)) S D=$P($P(^AMHREC(V,0),U,1),".") Q $$POVICD9D(I,D)

 Q $$POVICD9D(I)

POVICD9D(Y,D) ;

 NEW A,I

 S D=$G(D)

 I $$VERSION^XPDUTL("BCSV")]"",$T(ICDDX^ICDEX)="" Q $P($$ICDDX^ICDCODE(Y,D),U,10)  ;CSV

 I $$VERSION^XPDUTL("BCSV")]"",$T(ICDDX^ICDEX)]"" Q $P($$ICDDX^ICDEX(Y,D),U,10)  ;CSV

 ;10TH PIECE OF THAT CALL DOESN'T WORK IF CSV NOT INSTALLED

 I $T(ICDDX^ICDEX)="" S Y=$P($$ICDDX^ICDCODE(Y,D),U,1)

 I $T(ICDDX^ICDEX)]"" S Y=$P($$ICDDX^ICDEX(Y,D),U,1)

 I $G(Y)<0 Q 0  ;cmi/maw added for return of -1

 S A=$P($G(^ICD9(Y,9999999)),U,4),I=$P(^ICD9(Y,0),U,11)

 I D]"",I]"",D>I Q 0

 I D]"",A]"",D<A Q 0

Q 1

PRIMPOV(V,F) ;EP - primary provider in many different formats

 I 'V Q ""

 I '$D(^AMHREC(V)) Q ""

 NEW %,Y,P,C,Z

 S (Z,P)="",(Y,C)=0

 S Y=$O(^AMHRPRO("AD",V,0)) I Y S P=$P(^AMHRPRO(Y,0),U),Z=Y

 I 'P Q P

 I '$D(^AMHPROB(P)) Q ""

 I $G(F)="" S F="C"

 S %="" D @F

Q %

SECPOV(V,N,F) ;EP

 I 'V Q ""

 I '$D(^AMHREC(V)) Q ""

 I '$G(N) Q ""

 NEW %,Y,P,C,Z

 S (Z,P)="",(Y,C)=0

 S Y=0,C=-1 F  S Y=$O(^AMHRPRO("AD",V,Y)) Q:Y'=+Y   S C=C+1 I C=N S P=$P(^AMHRPRO(Y,0),U),Z=Y

 I 'P Q P

 I '$D(^AMHPROB(P)) Q ""

 I $G(F)="" S F="C"

 S %="" D @F

Q %

POV ;EP

 NEW Z,C,%,S,I,J

 S (C,Y)=0 F  S Y=$O(^AMHRPRO("AD",V,Y)) Q:Y'=+Y   S C=C+1 S APCLV(C)="",P=$P(^AMHRPRO(Y,0),U),Z=Y D

 .I F=99 D  Q

 ..F I=1:1 S S=$T(@I) Q:S=""  S %="" D @I S $P(APCLV(C),U,I)=%

 .I F[";" D  Q

 ..F J=1:1 S I=$P(F,";",J) Q:I=""  I I'=99 S %="" D @I S $P(APCLV(C),U,I)=% ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J

 .S %="",I=F D @I S $P(APCLV(C),U)=%

.Q

ADMDX ;EP

 I 'V Q ""

 I '$D(^AMHREC(V)) Q ""

 NEW %,Y,Z

 S %="",Z=$O(^AUPNVINP("AD",V,0))

 I 'Z Q %

 S P=$P(^AUPNVINP(Z,0),U,12)

 I 'P Q P

 I '$D(^AMHPROB(P)) Q ""

 I $G(F)="" S F="C"

 S %="" D @F

Q %

B ;

 S %=$P(^AMHPROB(P,0),U,10) Q

I ;

 S %=P Q

E ;

 S %=$P(^AMHPROB(P,0),U,3) Q

C ;EP

 S %=$P(^AMHPROB(P,0),U) Q

D ;EP

 S %=$P(^AMHRPRO(Z,0),U,7) Q

J ;

 S %=$P(^AMHRPRO(Z,0),U,9) I % S %=$P(^AMHPROB(%,0),U) Q

P ;

 S %=$P(^AMHRPRO(Z,0),U,11) Q

N ;

 S %=$$GET1^DIQ(9002011.01,Z,.04)

S ;stage

 S %=$P(^AMHRPRO(Z,0),U,5) Q

1 ;

 S %=$$VD^APCLV($P(^AMHRPRO(Y,0),U,3),"I")

2 ;

 S %=$$VD^APCLV($P(^AMHRPRO(Y,0),U,3),"S")

3 ;

 S %=$P(^AMHRPRO(Y,0),U,2)

4 ;

 S %=$$PATIENT^APCLV($P(^AMHRPRO(Y,0),U,3),"E")

5 ;

 S %=Y

6 D E Q

7 D C Q

9 D D Q

10 S %=$$VAL^XBDIQ1(9000010.07,Y,.07) Q

11 D J Q

12 D P Q

13 S %=$$VAL^XBDIQ1(9000010.07,Y,.11) Q

14 D N Q

15 S %=$P(^AMHRPRO(Y,0),U,12) Q

16 S %=$$VAL^XBDIQ1(9000010.07,Y,.12) Q

17 S %=$$VAL^XBDIQ1(9000010.07,Y,.13) Q

18 S %=$$VAL^XBDIQ1(9000010.07,Y,.05) Q

19 S %=$$VALI^XBDIQ1(9000010.07,Y,.06) Q

20 S %=$$VAL^XBDIQ1(9000010.07,Y,.06) Q

DATEEDIT ;EP

 I $P(X,".",2)="" D HLP^DDSUTL("You must enter a valid date/time. Time is required.") S DDSERROR=1 Q

UID(AMHA) ;EP-Given DFN return unique patient record id.

 ; AMHA can be DFN, but is not required if DFN or DA exists.

 ; pt record id = 6DIGIT_PADDFN

 ;     where 6DIGIT is the ASUFAC at the time of implementation of

 ;     this functionality.  I.e., the existing ASUFAC was frozen and

 ;     stuffed into the .25 field of the RPMS SITE file.

 ; PADDFN = DFN right justified in a field of 10.

 ; If not there, stuff the ASUFAC into RPMS SITE for durability.

 ;I '$P($G(^AUTTSITE(1,1)),U,3) S $P(^AUTTSITE(1,1),U,3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),U,1),0),U,10)

 ; If AMHA is not specified, try DFN, then DA if DIC=AUPNPAT.

 I '$G(AMHA),$G(DFN) S AMHA=DFN

 I '$G(AMHA),$G(DA),$G(DIC)="^AUPNPAT(" S AMHA=DA

 I '$G(AMHA) Q "DFN undefined."

 I '$D(^AUPNPAT(AMHA)) Q "No entry in AUPNPAT(."

 Q $$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)_$E("0000000000",1,10-$L(AMHA))_AMHA

UIDV(VISIT) ;EP - generate unique ID for visit

 I '$G(VISIT) Q VISIT

 NEW X

 ;I '$P($G(^AUTTSITE(1,1)),"^",3) S $P(^AUTTSITE(1,1),"^",3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),"^",1),0),"^",10)

 S X=$$GET1^DIQ(9999999.06,$P(^AUTTSITE(1,0),U),.32)

 Q X_$$LZERO(VISIT,10)

LZERO(V,L) ;EP - left zero fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V

Q V

DAYSBACK ;EP - called from option

 W !,"This option is used to edit the parameter definition for the "

 W !,"Number of days back the BH-EHR should look for displaying visits"

 W !,"to the user.",!!

 D EDITPAR^XPAREDIT("AMHBH DAYS BACK")

EDITTIUT ;EP - called from option

 W !!,"This option is used to edit the parameters for the list"

 W !,"of preferred TIU Note Titles that the BH-EHR should display"

 W !,"to the user when they select a TIU title for the following:"

 W !?5," - Behavioral Health record Progress Note/SOAP"

 W !?5," - Treatment Plan Narrative"

 W !?5," - Group Note Narrative"

 W !?5," - Intake Document Narrative"

 W !!

ED1 ;

 K DIR

 S DIR(0)="SO^P:Behavioral Health record Progress Note/SOAP;T:Treatment Plan Narrative;G:Group Note Narrative;I:Intake Document Narrative"

 S DIR("A")="Enter the type of Preferred TIU Note Titles to Update" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 I Y="" Q

 S AMHY=Y_"X"

 S AMHPAR=$P($T(@AMHY),";;",2)

 D EDITPAR^XPAREDIT(AMHPAR)

 G ED1

PX ;;AMHBH TIU TITLES 9002011-1108

TX ;;AMHBH TIU TITLES TP .21

GX ;;AMHBH TIU TITLES GROUP-.17

IX ;;AMHBH TIU TITLES INTAKE-.09

EDITHLD ;EP - called from option

 W !!,"This option is used to edit the default hospital locations"

 W !,"do be displayed to the user when creating a TIU Note."

 W !!

HL1 ;

 D EDITPAR^XPAREDIT("AMHBH HOSPITAL LOCATION (TIU)")

CPT(Y,D) ;EP - screen on CPT

 S D=$G(D)

 I $$CHKCPT(Y,D)

 Q:$D(^ICPT(Y))

CHKCPT(Y,D) ;EP

 NEW A,I,%

 S %=$$CPT^ICPTCOD(Y,D)

 I $G(%)<0 Q 0  ;cmi/maw added for return of -1

 I $$VERSION^XPDUTL("BCSV")]"" Q $P(%,U,7)

 S A="",I=$P(^ICPT(Y,0),U,7)  ;CAN'T RELY ON A IN OLD MODE

 ;A is date added, I is date inactivated/deleted

 I I]"",D]"",I<D Q 0

Q 1

OPEN ;

 NEW O,A,C,N

 S O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 S A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 S C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 S N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 Q:O=""

 I A,O>A D  Q

 .D EN^DDIOL("Open Date cannot be before admit date.  You must change")

 .D EN^DDIOL("or remove the admit date before changing the open date.")

 .D PUT^DDSVAL(DIE,.DA,.01,DDSOLD,,"I")

 .S DDSBR=1

 I C,O>C D  Q

 .D EN^DDIOL("Open Date cannot be before the closed date.  You must change")

 .D EN^DDIOL("or remove the closed date before changing the open date.")

 .D PUT^DDSVAL(DIE,.DA,.01,DDSOLD,,"I")

 .S DDSBR=1

 I N,O>N D  Q

 .D EN^DDIOL("Open Date cannot be before the next review date.  You must change")

 .D EN^DDIOL("or remove the next review date before changing the open date.")

 .D PUT^DDSVAL(DIE,.DA,.01,DDSOLD,,"I")

 .S DDSBR=1

ADMIT ;

 NEW O,A,C,N

 S O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 S A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 S C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 S N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 Q:A=""

 I O>A D  Q

 .D EN^DDIOL("Admit date cannot be before open date.  You must change")

 .D EN^DDIOL("the open date before changing the admit date.")

 .D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 .S DDSBR=5

 I C,A>C D  Q

 .D EN^DDIOL("Admit Date cannot be before the closed date.  You must change")

 .D EN^DDIOL("or remove the closed date before changing the admit date.")

 .D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 .S DDSBR=5

 ;I N,A>N D  Q

 ;.D EN^DDIOL("Admit Date cannot be before the next review date.  You must change")

 ;.D EN^DDIOL("or remove the next review date before changing the admit date.")

 ;.D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 ;.S DDSBR=1

NRD ;

 NEW O,A,C,N

 S O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 S A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 S C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 S N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 Q:N=""

 I O,O>N D  Q

 .D EN^DDIOL("Next review date cannot be before open date.  You must change")

 .D EN^DDIOL("the open date before changing the next review date.")

 .D PUT^DDSVAL(DIE,.DA,.12,DDSOLD,,"I")

 .S DDSBR=6

 ;I A,A>N D  Q

 ;.D EN^DDIOL("Next Review Date cannot be before the closed date.  You must change")

 ;.D EN^DDIOL("or remove the closed date before changing the admit date.")

 ;.D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 ;.S DDSBR=1

 ;I N,A>N D  Q

 ;.D EN^DDIOL("Admit Date cannot be before the next review date.  You must change")

 ;.D EN^DDIOL("or remove the next review date before changing the admit date.")

 ;.D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 ;.S DDSBR=1

CLOSED ;

 NEW O,A,C,N

 S O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 S A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 S C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 S N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 Q:C=""

 I O,O>C D  Q

 .D EN^DDIOL("Closed date cannot be before open date.  You must change")

 .D EN^DDIOL("the open date before changing the closed date.")

 .D PUT^DDSVAL(DIE,.DA,.05,DDSOLD,,"I")

 .S DDSBR=7

 I A,A>C D  Q

 .D EN^DDIOL("Admit Date cannot be before the closed date.  You must change")

 .D EN^DDIOL("or remove the admit date before changing the closed date.")

 .D PUT^DDSVAL(DIE,.DA,.05,DDSOLD,,"I")

 .S DDSBR=7

TARGET(R) ;EP

 I $O(^AMHRPA("AD",R,0)) Q

 NEW E

 D PUT^DDSVAL(9002011,AMHR,1106,"@",.E)

 D REQ^DDSUTL("TARGET","AMH PREV ACT TARGET BLK",5.3,0)

TAR1(R) ;EP

 K DLAYGO

 I $O(^AMHRPA("AD",R,0)) D REQ^DDSUTL("TARGET","AMH PREV ACT TARGET BLK",5.3,1) Q

 D REQ^DDSUTL("TARGET","AMH PREV ACT TARGET BLK",5.3,0)

AMHUTIL1  ; IHS/CMI/LAB - provider functions 06 Aug 2009 11:15 AM ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**1,2,4,5**;JUN 02, 2010;Build 18

 +2       ;IHS/CMI/LAB - added stage as output parameter

 +3       ;

 +4       ;IHS/TUCSON/LAB - patch 1 05/19/97 - fixed setting of array

DEMO(P,T) ;EP - called to exclude demo patients

 +1        IF $GET(P)=""

               QUIT 0

 +2        IF $GET(T)=""

               SET T="I"

 +3        IF T="I"

               QUIT 0

 +4        NEW R

 +5        SET R=""

 +6        IF T="E"

               Begin DoDot:1

 +7                IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"

                       SET R=1

                       QUIT

 +8                NEW %

 +9                SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 +10               IF '%

                       SET R=0

                       QUIT

 +11               IF $DATA(^DIBT(%,1,P))

                       SET R=1

                       QUIT

               End DoDot:1

               QUIT R

 +12       IF T="O"

               Begin DoDot:1

 +13               IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"

                       SET R=0

                       QUIT

 +14               NEW %

 +15               SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))

 +16               IF '%

                       SET R=1

                       QUIT

 +17               IF $DATA(^DIBT(%,1,P))

                       SET R=0

                       QUIT

 +18               SET R=1

                   QUIT

               End DoDot:1

               QUIT R

 +19       QUIT 0

 +20      ;

DEMOCHK(R) ;EP - check demo pat

 +1        NEW DIR,DA

 +2        SET R=-1

 +3        SET DIR(0)="S^I:Include ALL Patients;E:Exclude DEMO Patients;O:Include ONLY DEMO Patients"

           SET DIR("A")="Demo Patient Inclusion/Exclusion"

           SET DIR("B")="E"

 +4        KILL DA

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               SET R=-1

               QUIT

 +6        SET R=Y

 +7        QUIT

CHKD(Y,D) ;EP check dsm with Date

 +1        SET D=$GET(D)

 +2        IF 'Y

               QUIT 0

 +3        IF '$DATA(^AMHPROB(Y,0))

               QUIT 0

 +4       ;FIRST LETS FIGURE OUT IF WE WANT IV OR V AND THEN MOVE ON

 +5        SET DSC=$$DSMCS(DUZ(2),D)

 +6       ;NOT CORRECT CODING SYSTEM

           SET CS=$PIECE(^AMHPROB(Y,0),U,10)

           IF CS=4!(CS=5)

               IF CS'=DSC

                   QUIT 0

 +7        NEW M,Z,J

 +8        SET M=$PIECE(^AMHPROB(Y,0),U,13)

           IF M

               Begin DoDot:1

 +9                SET Z=1

 +10               SET J=$PIECE(^AMHPROB(Y,0),U,14)

 +11               IF J=""

                       SET Z=0

                       QUIT

 +12               IF D]""

                       IF J]""

                           IF J<D

                               SET Z=0

 +13               IF D=""

                       SET Z=0

               End DoDot:1

               IF 'Z

                   QUIT Z

 +14       NEW IMP

           SET IMP=$$IMP^AMHUTIL2($SELECT(D:D,1:DT))

 +15       NEW I

           SET I=$PIECE(^AMHPROB(Y,0),U,5)

 +16      ;I I="" Q $P(^AMHPROB(Y,0),U,13)  ;cmi/maw orig

 +17       IF IMP=1

               IF $PIECE(^AMHPROB(Y,0),U,5)=""

                   IF $PIECE(^AMHPROB(Y,0),U,17)]""

                       QUIT 0

 +18       IF IMP=30

               IF $PIECE(^AMHPROB(Y,0),U,17)=""

                   IF $PIECE(^AMHPROB(Y,0),U,5)]""

                       QUIT 0

 +19      ;GET ICD9 code that this is mapped to

           IF IMP=1

               SET I=$PIECE(^AMHPROB(Y,0),U,5)

 +20       IF IMP=30

               SET I=$PIECE(^AMHPROB(Y,0),U,17)

 +21      ;cmi/maw modified

           IF I=""

               QUIT $SELECT($PIECE(^AMHPROB(Y,0),U,13):0,1:1)

 +22       QUIT $$POVICD9D(I,D)

 +23      ;

CHKICD(Y,D,R,A,E) ;EP

 +1        SET D=$GET(D)

 +2        SET R=$GET(R)

 +3        SET A=$GET(A)

 +4        SET E=$GET(E)

 +5        IF $$POVICD9(Y,D,R,A,E)

 +6        IF $DATA(^AMHPROB(Y))

               QUIT

 +7        QUIT

DSMCS(S,D) ;EP - called to get coding system

 +1       ;s is site DUZ(2)

 +2       ;d is date

 +3       ;if can't determine default to DSM IV

 +4        IF '$GET(S)

               SET S=DUZ(2)

 +5        IF '$GET(D)

               SET D=DT

 +6       ;NO SITE PARAMETER FILE SO DEFAULT TO 4

           IF '$DATA(^AMHSITE(S,0))

               QUIT 4

 +7        NEW C,I

 +8       ;DATE, IF NO DATE USE 4

           SET C=$PIECE($GET(^AMHSITE(S,18)),U,11)

 +9        IF C=""

               QUIT 4

 +10       IF D<C

               QUIT 4

 +11       QUIT 5

DSMVDT(S) ;

 +1       ;s is site DUZ(2)

 +2       ;if can't determine default to DSM IV

 +3        IF '$GET(S)

               SET S=DUZ(2)

 +4       ;NO SITE PARAMETER FILE SO DEFAULT TO 4

           IF '$DATA(^AMHSITE(S,0))

               QUIT 4

 +5        NEW C,I

 +6       ;DATE, IF NO DATE USE 4

           SET C=$PIECE($GET(^AMHSITE(S,18)),U,11)

 +7        QUIT C

 +8       ;

POVICD9(Y,D,R,A,E) ;EP

 +1       ;Y=ien of entry in MHSS PROBLEM/DSM CODE file

 +2       ;E - indicates we are in EHR so it is accepted since PCC accepted it

 +3       ;R - ien of MHSS RECORD if known and in a record

 +4       ;D - date of visit for which this pov is being added

 +5       ;A - equal to DA of MHSS RECORD PROBLEMS file, to be used if in fileman's edit??? and not in BH software?, maybe someone is doing D P^DI and editting the .01 field of the file??

 +6       ;

 +7       ;take whatever EHR passes as EHR rules

           IF $GET(E)

               QUIT 1

 +8        SET R=$GET(R)

 +9        SET D=$GET(D)

 +10       SET A=$GET(A)

 +11       SET Y=$GET(Y)

 +12      ;pass an IEN!

           IF 'Y

               QUIT 0

 +13       NEW I,V,M,Z,J,K,IMP,DCS,CS

 +14      ;FIRST LETS FIGURE OUT IF WE WANT IV OR V AND THEN MOVE ON

 +15      ;S DSC=$$DSMCS(DUZ(2),D)

 +16      ;NOT SELECTABLE IN BH ENTRY

           IF '$GET(E)

               IF $PIECE(^AMHPROB(Y,0),U,18)

                   QUIT 0

 +17       SET IMP=$$IMP^AMHUTIL2($SELECT(R:$PIECE($PIECE($GET(^AMHREC(R,0)),U),"."),1:DT))

 +18      ;If IMP is 1 allow any with an icd9 pointer or if both icd9 and icd10 are blank

 +19      ;If IMP is 30 allow any with an icd10 pointer or if both icd9 and icd10 are blank

 +20      ;pass a VALID IEN!

           IF '$DATA(^AMHPROB(Y,0))

               QUIT 0

 +21      ;FIRST LETS FIGURE OUT IF WE WANT IV OR V AND THEN MOVE ON

 +22       SET DSC=$$DSMCS(DUZ(2),D)

 +23      ;NOT CORRECT CODING SYSTEM

           SET CS=$PIECE(^AMHPROB(Y,0),U,10)

           IF CS=4!(CS=5)

               IF CS'=DSC

                   QUIT 0

 +24       SET M=$PIECE(^AMHPROB(Y,0),U,13)

           IF M

               Begin DoDot:1

 +25               SET Z=1

 +26               SET J=$PIECE(^AMHPROB(Y,0),U,14)

 +27               IF J=""

                       SET Z=0

                       QUIT

 +28               IF D=""

                       IF R

                           SET D=$PIECE($PIECE($GET(^AMHREC(R,0)),U),".")

 +29               IF D=""

                       SET D=DT

 +30               IF D]""

                       IF J]""

                           IF J'>D

                               SET Z=0

 +31               IF D=""

                       SET Z=0

               End DoDot:1

               IF 'Z

                   QUIT Z

 +32       SET J=$PIECE(^AMHPROB(Y,0),U,16)

 +33       IF J

               Begin DoDot:1

 +34               SET Z=1

 +35               IF D=""

                       IF R

                           SET D=$PIECE($PIECE($GET(^AMHREC(R,0)),U),".")

 +36               IF D]""

                       IF J]""

                           IF J>D

                               SET Z=0

 +37               IF J>DT

                       SET Z=0

               End DoDot:1

               IF 'Z

                   QUIT Z

 +38       IF IMP=1

               IF $PIECE(^AMHPROB(Y,0),U,5)=""

                   IF $PIECE(^AMHPROB(Y,0),U,17)]""

                       QUIT 0

 +39       IF IMP=30

               IF $PIECE(^AMHPROB(Y,0),U,17)=""

                   IF $PIECE(^AMHPROB(Y,0),U,5)]""

                       QUIT 0

 +40      ;GET ICD9 code that this is mapped to

           IF IMP=1

               SET I=$PIECE(^AMHPROB(Y,0),U,5)

 +41       IF IMP=30

               SET I=$PIECE(^AMHPROB(Y,0),U,17)

 +42      ;if there is no icd code to look at then just check status field and quit

           IF I=""

               QUIT $SELECT('$PIECE(^AMHPROB(Y,0),U,13):1,1:0)

 +43      ;now figure out if valid based on what data is passed.

 +44      ;if passed in D, use it and quit

 +45       IF D

               QUIT $$POVICD9D(I,D)

 +46       IF R

               IF $DATA(^AMHREC(R,0))

                   SET D=$PIECE($PIECE(^AMHREC(R,0),U,1),".")

                   QUIT $$POVICD9D(I,D)

 +47       IF A

               SET V=$PIECE($GET(^AMHRPRO(A,0)),U,3)

               IF V

                   IF $DATA(^AMHREC(V,0))

                       SET D=$PIECE($PIECE(^AMHREC(V,0),U,1),".")

                       QUIT $$POVICD9D(I,D)

 +48       QUIT $$POVICD9D(I)

 +49      ;

POVICD9D(Y,D) ;

 +1        NEW A,I

 +2        SET D=$GET(D)

 +3       ;CSV

           IF $$VERSION^XPDUTL("BCSV")]""

               IF $TEXT(ICDDX^ICDEX)=""

                   QUIT $PIECE($$ICDDX^ICDCODE(Y,D),U,10)

 +4       ;CSV

           IF $$VERSION^XPDUTL("BCSV")]""

               IF $TEXT(ICDDX^ICDEX)]""

                   QUIT $PIECE($$ICDDX^ICDEX(Y,D),U,10)

 +5       ;10TH PIECE OF THAT CALL DOESN'T WORK IF CSV NOT INSTALLED

 +6        IF $TEXT(ICDDX^ICDEX)=""

               SET Y=$PIECE($$ICDDX^ICDCODE(Y,D),U,1)

 +7        IF $TEXT(ICDDX^ICDEX)]""

               SET Y=$PIECE($$ICDDX^ICDEX(Y,D),U,1)

 +8       ;cmi/maw added for return of -1

           IF $GET(Y)<0

               QUIT 0

 +9        SET A=$PIECE($GET(^ICD9(Y,9999999)),U,4)

           SET I=$PIECE(^ICD9(Y,0),U,11)

 +10       IF D]""

               IF I]""

                   IF D>I

                       QUIT 0

 +11       IF D]""

               IF A]""

                   IF D<A

                       QUIT 0

 +12       QUIT 1

 +13      ;

PRIMPOV(V,F) ;EP - primary provider in many different formats

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AMHREC(V))

               QUIT ""

 +3        NEW %,Y,P,C,Z

 +4        SET (Z,P)=""

           SET (Y,C)=0

 +5        SET Y=$ORDER(^AMHRPRO("AD",V,0))

           IF Y

               SET P=$PIECE(^AMHRPRO(Y,0),U)

               SET Z=Y

 +6        IF 'P

               QUIT P

 +7        IF '$DATA(^AMHPROB(P))

               QUIT ""

 +8        IF $GET(F)=""

               SET F="C"

 +9        SET %=""

           DO @F

 +10       QUIT %

 +11      ;

SECPOV(V,N,F) ;EP

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AMHREC(V))

               QUIT ""

 +3        IF '$GET(N)

               QUIT ""

 +4        NEW %,Y,P,C,Z

 +5        SET (Z,P)=""

           SET (Y,C)=0

 +6        SET Y=0

           SET C=-1

FOR

               SET Y=$ORDER(^AMHRPRO("AD",V,Y))

               IF Y'=+Y

                   QUIT

               SET C=C+1

               IF C=N

                   SET P=$PIECE(^AMHRPRO(Y,0),U)

                   SET Z=Y

 +7        IF 'P

               QUIT P

 +8        IF '$DATA(^AMHPROB(P))

               QUIT ""

 +9        IF $GET(F)=""

               SET F="C"

 +10       SET %=""

           DO @F

 +11       QUIT %

 +12      ;

POV       ;EP

 +1        NEW Z,C,%,S,I,J

 +2        SET (C,Y)=0

FOR

               SET Y=$ORDER(^AMHRPRO("AD",V,Y))

               IF Y'=+Y

                   QUIT

               SET C=C+1

               SET APCLV(C)=""

               SET P=$PIECE(^AMHRPRO(Y,0),U)

               SET Z=Y

               Begin DoDot:1

 +3                IF F=99

                       Begin DoDot:2

 +4                        FOR I=1:1

                               SET S=$TEXT(@I)

                               IF S=""

                                   QUIT

                               SET %=""

                               DO @I

                               SET $PIECE(APCLV(C),U,I)=%

                       End DoDot:2

                       QUIT

 +5                IF F[";"

                       Begin DoDot:2

 +6       ;IHS/TUCSON/LAB - patch 1 05/19/97 changed ,I TO ,J

                           FOR J=1:1

                               SET I=$PIECE(F,";",J)

                               IF I=""

                                   QUIT

                               IF I'=99

                                   SET %=""

                                   DO @I

                                   SET $PIECE(APCLV(C),U,I)=%

                       End DoDot:2

                       QUIT

 +7                SET %=""

                   SET I=F

                   DO @I

                   SET $PIECE(APCLV(C),U)=%

 +8                QUIT

               End DoDot:1

 +9        QUIT

ADMDX     ;EP

 +1        IF 'V

               QUIT ""

 +2        IF '$DATA(^AMHREC(V))

               QUIT ""

 +3        NEW %,Y,Z

 +4        SET %=""

           SET Z=$ORDER(^AUPNVINP("AD",V,0))

 +5        IF 'Z

               QUIT %

 +6        SET P=$PIECE(^AUPNVINP(Z,0),U,12)

 +7        IF 'P

               QUIT P

 +8        IF '$DATA(^AMHPROB(P))

               QUIT ""

 +9        IF $GET(F)=""

               SET F="C"

 +10       SET %=""

           DO @F

 +11       QUIT %

 +12      ;

B         ;

 +1        SET %=$PIECE(^AMHPROB(P,0),U,10)

           QUIT

I         ;

 +1        SET %=P

           QUIT

E         ;

 +1        SET %=$PIECE(^AMHPROB(P,0),U,3)

           QUIT

C         ;EP

 +1        SET %=$PIECE(^AMHPROB(P,0),U)

           QUIT

D         ;EP

 +1        SET %=$PIECE(^AMHRPRO(Z,0),U,7)

           QUIT

J         ;

 +1        SET %=$PIECE(^AMHRPRO(Z,0),U,9)

           IF %

               SET %=$PIECE(^AMHPROB(%,0),U)

               QUIT

 +2        QUIT

P         ;

 +1        SET %=$PIECE(^AMHRPRO(Z,0),U,11)

           QUIT

N         ;

 +1        SET %=$$GET1^DIQ(9002011.01,Z,.04)

 +2        QUIT

S         ;stage

 +1        SET %=$PIECE(^AMHRPRO(Z,0),U,5)

           QUIT

 +2       ;

1         ;

 +1        SET %=$$VD^APCLV($PIECE(^AMHRPRO(Y,0),U,3),"I")

 +2        QUIT

2         ;

 +1        SET %=$$VD^APCLV($PIECE(^AMHRPRO(Y,0),U,3),"S")

 +2        QUIT

3         ;

 +1        SET %=$PIECE(^AMHRPRO(Y,0),U,2)

 +2        QUIT

4         ;

 +1        SET %=$$PATIENT^APCLV($PIECE(^AMHRPRO(Y,0),U,3),"E")

 +2        QUIT

5         ;

 +1        SET %=Y

 +2        QUIT

6          DO E

           QUIT

7          DO C

           QUIT

9          DO D

           QUIT

10         SET %=$$VAL^XBDIQ1(9000010.07,Y,.07)

           QUIT

11         DO J

           QUIT

12         DO P

           QUIT

13         SET %=$$VAL^XBDIQ1(9000010.07,Y,.11)

           QUIT

14         DO N

           QUIT

15         SET %=$PIECE(^AMHRPRO(Y,0),U,12)

           QUIT

16         SET %=$$VAL^XBDIQ1(9000010.07,Y,.12)

           QUIT

17         SET %=$$VAL^XBDIQ1(9000010.07,Y,.13)

           QUIT

18         SET %=$$VAL^XBDIQ1(9000010.07,Y,.05)

           QUIT

19         SET %=$$VALI^XBDIQ1(9000010.07,Y,.06)

           QUIT

20         SET %=$$VAL^XBDIQ1(9000010.07,Y,.06)

           QUIT

DATEEDIT  ;EP

 +1        IF $PIECE(X,".",2)=""

               DO HLP^DDSUTL("You must enter a valid date/time. Time is required.")

               SET DDSERROR=1

               QUIT

 +2        QUIT

UID(AMHA) ;EP-Given DFN return unique patient record id.

 +1       ; AMHA can be DFN, but is not required if DFN or DA exists.

 +2       ;

 +3       ; pt record id = 6DIGIT_PADDFN

 +4       ;     where 6DIGIT is the ASUFAC at the time of implementation of

 +5       ;     this functionality.  I.e., the existing ASUFAC was frozen and

 +6       ;     stuffed into the .25 field of the RPMS SITE file.

 +7       ; PADDFN = DFN right justified in a field of 10.

 +8       ;

 +9       ; If not there, stuff the ASUFAC into RPMS SITE for durability.

 +10      ;I '$P">P">P">P">P">P">P">P($G(^AUTTSITE(1,1)),U,3) S $P">P">P">P">P">P">P">P(^AUTTSITE(1,1),U,3)=$P">P">P">P">P">P">P">P(^AUTTLOC($P">P">P">P">P">P">P">P(^AUTTSITE(1,0),U,1),0),U,10)

 +11      ;

 +12      ; If AMHA is not specified, try DFN, then DA if DIC=AUPNPAT.

 +13       IF '$GET(AMHA)

               IF $GET(DFN)

                   SET AMHA=DFN

 +14       IF '$GET(AMHA)

               IF $GET(DA)

                   IF $GET(DIC)="^AUPNPAT("

                       SET AMHA=DA

 +15      ;

 +16       IF '$GET(AMHA)

               QUIT "DFN undefined."

 +17       IF '$DATA(^AUPNPAT(AMHA))

               QUIT "No entry in AUPNPAT(."

 +18      ;

 +19       QUIT $$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)_$EXTRACT("0000000000",1,10-$LENGTH(AMHA))_AMHA

 +20      ;

UIDV(VISIT) ;EP - generate unique ID for visit

 +1        IF '$GET(VISIT)

               QUIT VISIT

 +2        NEW X

 +3       ;I '$P">P">P">P">P">P">P">P($G(^AUTTSITE(1,1)),"^",3) S $P">P">P">P">P">P">P">P(^AUTTSITE(1,1),"^",3)=$P">P">P">P">P">P">P">P(^AUTTLOC($P">P">P">P">P">P">P">P(^AUTTSITE(1,0),"^",1),0),"^",10)

 +4        SET X=$$GET1^DIQ(9999999.06,$PIECE(^AUTTSITE(1,0),U),.32)

 +5        QUIT X_$$LZERO(VISIT,10)

 +6       ;

LZERO(V,L) ;EP - left zero fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V="0"_V

 +3        QUIT V

 +4       ;

DAYSBACK  ;EP - called from option

 +1        WRITE !,"This option is used to edit the parameter definition for the "

 +2        WRITE !,"Number of days back the BH-EHR should look for displaying visits"

 +3        WRITE !,"to the user.",!!

 +4        DO EDITPAR^XPAREDIT("AMHBH DAYS BACK")

 +5        QUIT

EDITTIUT  ;EP - called from option

 +1        WRITE !!,"This option is used to edit the parameters for the list"

 +2        WRITE !,"of preferred TIU Note Titles that the BH-EHR should display"

 +3        WRITE !,"to the user when they select a TIU title for the following:"

 +4        WRITE !?5," - Behavioral Health record Progress Note/SOAP"

 +5        WRITE !?5," - Treatment Plan Narrative"

 +6        WRITE !?5," - Group Note Narrative"

 +7        WRITE !?5," - Intake Document Narrative"

 +8        WRITE !!

ED1       ;

 +1        KILL DIR

 +2        SET DIR(0)="SO^P:Behavioral Health record Progress Note/SOAP;T:Treatment Plan Narrative;G:Group Note Narrative;I:Intake Document Narrative"

 +3        SET DIR("A")="Enter the type of Preferred TIU Note Titles to Update"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               QUIT

 +5        IF Y=""

               QUIT

 +6        SET AMHY=Y_"X"

 +7        SET AMHPAR=$PIECE($TEXT(@AMHY),";;",2)

 +8        DO EDITPAR^XPAREDIT(AMHPAR)

 +9        GOTO ED1

PX        ;;AMHBH TIU TITLES 9002011-1108

TX        ;;AMHBH TIU TITLES TP .21

GX        ;;AMHBH TIU TITLES GROUP-.17

IX        ;;AMHBH TIU TITLES INTAKE-.09

 +1       ;

 +2       ;

EDITHLD   ;EP - called from option

 +1        WRITE !!,"This option is used to edit the default hospital locations"

 +2        WRITE !,"do be displayed to the user when creating a TIU Note."

 +3        WRITE !!

HL1       ;

 +1        DO EDITPAR^XPAREDIT("AMHBH HOSPITAL LOCATION (TIU)")

 +2        QUIT

CPT(Y,D)  ;EP - screen on CPT

 +1        SET D=$GET(D)

 +2        IF $$CHKCPT(Y,D)

 +3        IF $DATA(^ICPT(Y))

               QUIT

 +4        QUIT

 +5       ;

CHKCPT(Y,D) ;EP

 +1        NEW A,I,%

 +2        SET %=$$CPT^ICPTCOD(Y,D)

 +3       ;cmi/maw added for return of -1

           IF $GET(%)<0

               QUIT 0

 +4        IF $$VERSION^XPDUTL("BCSV")]""

               QUIT $PIECE(%,U,7)

 +5       ;CAN'T RELY ON A IN OLD MODE

           SET A=""

           SET I=$PIECE(^ICPT(Y,0),U,7)

 +6       ;A is date added, I is date inactivated/deleted

 +7        IF I]""

               IF D]""

                   IF I<D

                       QUIT 0

 +8        QUIT 1

 +9       ;

OPEN      ;

 +1        NEW O,A,C,N

 +2        SET O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 +3        SET A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 +4        SET C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 +5        SET N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 +6        IF O=""

               QUIT

 +7        IF A

               IF O>A

                   Begin DoDot:1

 +8                    DO EN^DDIOL("Open Date cannot be before admit date.  You must change")

 +9                    DO EN^DDIOL("or remove the admit date before changing the open date.")

 +10                   DO PUT^DDSVAL(DIE,.DA,.01,DDSOLD,,"I")

 +11                   SET DDSBR=1

                   End DoDot:1

                   QUIT

 +12       IF C

               IF O>C

                   Begin DoDot:1

 +13                   DO EN^DDIOL("Open Date cannot be before the closed date.  You must change")

 +14                   DO EN^DDIOL("or remove the closed date before changing the open date.")

 +15                   DO PUT^DDSVAL(DIE,.DA,.01,DDSOLD,,"I")

 +16                   SET DDSBR=1

                   End DoDot:1

                   QUIT

 +17       IF N

               IF O>N

                   Begin DoDot:1

 +18                   DO EN^DDIOL("Open Date cannot be before the next review date.  You must change")

 +19                   DO EN^DDIOL("or remove the next review date before changing the open date.")

 +20                   DO PUT^DDSVAL(DIE,.DA,.01,DDSOLD,,"I")

 +21                   SET DDSBR=1

                   End DoDot:1

                   QUIT

 +22       QUIT

ADMIT     ;

 +1        NEW O,A,C,N

 +2        SET O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 +3        SET A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 +4        SET C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 +5        SET N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 +6        IF A=""

               QUIT

 +7        IF O>A

               Begin DoDot:1

 +8                DO EN^DDIOL("Admit date cannot be before open date.  You must change")

 +9                DO EN^DDIOL("the open date before changing the admit date.")

 +10               DO PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 +11               SET DDSBR=5

               End DoDot:1

               QUIT

 +12       IF C

               IF A>C

                   Begin DoDot:1

 +13                   DO EN^DDIOL("Admit Date cannot be before the closed date.  You must change")

 +14                   DO EN^DDIOL("or remove the closed date before changing the admit date.")

 +15                   DO PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 +16                   SET DDSBR=5

                   End DoDot:1

                   QUIT

 +17      ;I N,A>N D  Q

 +18      ;.D EN^DDIOL("Admit Date cannot be before the next review date.  You must change")

 +19      ;.D EN^DDIOL("or remove the next review date before changing the admit date.")

 +20      ;.D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 +21      ;.S DDSBR=1

 +22       QUIT

NRD       ;

 +1        NEW O,A,C,N

 +2        SET O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 +3        SET A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 +4        SET C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 +5        SET N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 +6        IF N=""

               QUIT

 +7        IF O

               IF O>N

                   Begin DoDot:1

 +8                    DO EN^DDIOL("Next review date cannot be before open date.  You must change")

 +9                    DO EN^DDIOL("the open date before changing the next review date.")

 +10                   DO PUT^DDSVAL(DIE,.DA,.12,DDSOLD,,"I")

 +11                   SET DDSBR=6

                   End DoDot:1

                   QUIT

 +12      ;I A,A>N D  Q

 +13      ;.D EN^DDIOL("Next Review Date cannot be before the closed date.  You must change")

 +14      ;.D EN^DDIOL("or remove the closed date before changing the admit date.")

 +15      ;.D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 +16      ;.S DDSBR=1

 +17      ;I N,A>N D  Q

 +18      ;.D EN^DDIOL("Admit Date cannot be before the next review date.  You must change")

 +19      ;.D EN^DDIOL("or remove the next review date before changing the admit date.")

 +20      ;.D PUT^DDSVAL(DIE,.DA,.04,DDSOLD,,"I")

 +21      ;.S DDSBR=1

 +22       QUIT

CLOSED    ;

 +1        NEW O,A,C,N

 +2        SET O=$$GET^DDSVAL(9002011.58,DA,.01,,"I")

 +3        SET A=$$GET^DDSVAL(9002011.58,DA,.04,,"I")

 +4        SET C=$$GET^DDSVAL(9002011.58,DA,.05,,"I")

 +5        SET N=$$GET^DDSVAL(9002011.58,DA,.12,,"I")

 +6        IF C=""

               QUIT

 +7        IF O

               IF O>C

                   Begin DoDot:1

 +8                    DO EN^DDIOL("Closed date cannot be before open date.  You must change")

 +9                    DO EN^DDIOL("the open date before changing the closed date.")

 +10                   DO PUT^DDSVAL(DIE,.DA,.05,DDSOLD,,"I")

 +11                   SET DDSBR=7

                   End DoDot:1

                   QUIT

 +12       IF A

               IF A>C

                   Begin DoDot:1

 +13                   DO EN^DDIOL("Admit Date cannot be before the closed date.  You must change")

 +14                   DO EN^DDIOL("or remove the admit date before changing the closed date.")

 +15                   DO PUT^DDSVAL(DIE,.DA,.05,DDSOLD,,"I")

 +16                   SET DDSBR=7

                   End DoDot:1

                   QUIT

 +17       QUIT

TARGET(R) ;EP

 +1        IF $ORDER(^AMHRPA("AD",R,0))

               QUIT

 +2        NEW E

 +3        DO PUT^DDSVAL(9002011,AMHR,1106,"@",.E)

 +4        DO REQ^DDSUTL("TARGET","AMH PREV ACT TARGET BLK",5.3,0)

 +5        QUIT

TAR1(R)   ;EP

 +1        KILL DLAYGO

 +2        IF $ORDER(^AMHRPA("AD",R,0))

               DO REQ^DDSUTL("TARGET","AMH PREV ACT TARGET BLK",5.3,1)

               QUIT

 +3        DO REQ^DDSUTL("TARGET","AMH PREV ACT TARGET BLK",5.3,0)

 +4        QUIT

AMHUTIL1.m