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
Q
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))
Q
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
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
Q
P ;
S %=$P(^AMHRPRO(Z,0),U,11) Q
N ;
S %=$$GET1^DIQ(9002011.01,Z,.04)
Q
S ;stage
S %=$P(^AMHRPRO(Z,0),U,5) Q
;
1 ;
S %=$$VD^APCLV($P(^AMHRPRO(Y,0),U,3),"I")
Q
2 ;
S %=$$VD^APCLV($P(^AMHRPRO(Y,0),U,3),"S")
Q
3 ;
S %=$P(^AMHRPRO(Y,0),U,2)
Q
4 ;
S %=$$PATIENT^APCLV($P(^AMHRPRO(Y,0),U,3),"E")
Q
5 ;
S %=Y
Q
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
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")
Q
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)")
Q
CPT(Y,D) ;EP - screen on CPT
S D=$G(D)
I $$CHKCPT(Y,D)
Q:$D(^ICPT(Y))
Q
;
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
Q
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
Q
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
Q
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
Q
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)
Q
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)
Q
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
