ACHSPAM ; IHS/ITSC/PMF - DOCUMENT PAYMENT - ENTER/EDIT MEDICAL DATA ; JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7,14,17,23**;JUN 11,2001;Build 43
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Remove code that deleted Dental info.
;IHS/SET/JVK ACHS*3.1*7 10/15/2003 - FIX THE CALL DUZ(2) FOR VERSION 22
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
EDIT ;EP - From Option. Edit EOBR Medical data.
D SEL
I ($D(DUOUT))!($D(DTOUT))!'$D(ACHSDIEN) D END Q
;
;
ENTER ;EP - After document paid.
I $E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)=18 D ^ACHSZCK1 ;ACHS*3.1*17 ADDED FOR BEMJ SITES RECORD CHECK# AND COMMENTS
;IF THIS IS 'BLANKET ORDER'
I $$DOC^ACHS(0,3) W !,"UNABLE TO PROCESS MEDICAL DATA FOR BLANKET ORDER." D RTRN^ACHS D END Q
S DA=ACHSDIEN
;IHS/SET/JVK *3.1*7 10/10/03 MAKE CHANGES BELOW FOR FILEMAN 22 CHANGES
;S DA(2)=DUZ(2) ; Must be set for x-ref to be set correctly.
I $G(^DD("VERSION"))>21 S DA(1)=DUZ(2) ; Must be set for x-ref to be set correctly.
I $G(^DD("VERSION"))<22 S DA(2)=DUZ(2) ; Must be set for x-ref to be set correctly.
;END CHANGES IHS/SET/JVK *3.1*7
S DIE="^ACHSF("_DUZ(2)_",""D"","
S DLAYGO=9002080
;ACHS*3.1*17 ADDED PRINT CHECK DATE FOR BEMJ TRIBAL SITES SITES
;S DR=$S(ACHSTYP=1:"90;91;92;94//1;",1:"")_"95;96;97"_$S($$PARM^ACHS(0,8)="Y":";51",1:"")
S DR=$S(ACHSTYP=1:"90;91;92;94//1;",1:"")_"95;96;97"_$S($$PARM^ACHS(0,8)="Y":";51",1:"")_$S($E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)=18:";52",1:"")
S DR(2,9002080.195)=".01"
S DR(2,9002080.196)=".01:1"
S DR(2,9002080.197)=".01:6;"_$S(ACHSTYP=2:"7;8",1:"")_";9"
D ^DIE
;
;IF 'POST EOBR TO PAT CARE CMPNT' AND LINK TO PCC IS ON
I $$PARM^ACHS(2,22)="Y",$$LINK^ACHSPAP1 S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) D ^ACHSPAP ;LINK TO PCC 1/2
;
;IF 'REFERRAL' PTR
I $$DOC^ACHS(2,7) D
.D DX^ACHSBMC ;TRANSFER DX INFO TO RCIS
.D PX^ACHSBMC ;TRANSFER PX INFO TO RCIS
;
; This makes sure that a bug in FileMan doesn't leave extraneous
; nodes in the ^ACHSF( global. WHAT BUG??????? NEEDS TESTING
;F ACHS=1:1:50 I $D(^ACHSF(ACHS,"D",ACHSDIEN,11)),$D(^ACHSF(ACHS,"D",ACHSDIEN))=10 D;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;. K ^ACHSF(ACHS,"D",ACHSDIEN,11);IHS/SET/GTH ACHS*3.1*5 12/06/2002
;. S DA(2)=DUZ(2),DA(1)=ACHSDIEN,DA=0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;. F S DA=$O(^ACHSF(DA(2),"D",DA(1),11,DA)) Q:'DA S X=$P(^(DA,0),U) X ^DD(9002080.197,.01,1,1,1);IHS/SET/GTH ACHS*3.1*5 12/06/2002
;.Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;
D END
Q
;
SEL ;EP - Select document, display data.
D ^ACHSUD ;SELECT DOCUMENT
I $D(DUOUT)!$D(DTOUT)!'$D(ACHSDIEN) D END Q
S ACHSTIEN=1
K ACHSSIG
D INIT^ACHSRP2 ;INITIALIZE DOCUMENT/TRANSACTION VARIABLES
D ^ACHSAV ;DOCUMENT DISPLAY; THIS RTN ALSO DOES INIT^ACHSRP2
S ACHSADJ=""
;
D A0A^ACHSUSC ;DISPLAY DOCUMENT CANCEL/SUPPLEMENTAL INFO. THIS
; CALL BYPASSES THE INIT^ACHSRP2 IN ACHSUSC
;
K ACHSADJ
I $D(ACHSDIEN),'$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") W !,"LOCK FAILED AT SEL+9^ACHSPAM" K ACHSDIEN
Q
;
REF ;EP - From option. Enter/Edit Referral medical data.
D SEL
I $D(DTOUT)!$D(DTOUT)!'$D(ACHSDIEN) D END Q
;
I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)!($P(^(0),U,4)=2) W *7,!,"NO ENTRY OF REFERRAL DATA TO THIS TYPE DOCUMENT ALLOWED.",! D RTRN^ACHS G END
S DIE="^ACHSF("_DUZ(2)_",""D"",",DA=ACHSDIEN,DR="80:83;84:87"
D ^DIE
W !
S ACHS("DX")=4,ACHS("PX")=6
;
D CDRG ;Compute and set DRG or Referral
; DRG & Referral Estimated cost.
;
END ; Unlock, kill vars, quit.
I $D(ACHSDIEN),'$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")
K ACHSPROV,ACHSCONP,ACHSCAN,ACHSDRG,ACHSSCC,ACHSCOPT,ACHSDOCR,ACHSESDA,ACHSESDO,ACHSFDT,ACHSODT
K ACHSTDT,ACHSHON,ACHSORDN,ACHSBLKF,ACHSIPA,ACHSSIG,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSPCCL
K DIC,DIE,DLAYGO,DR,D0,D1,DIADD,LAYGO ;*3.1*23 added DIADD AND LAYGO
Q
;
CDRG ;EP - Compute and set DRG or Referral DRG & Referral Estimated cost.
Q ;BYPASS CALCULATING DRG UNTIL FURTHER DEVELOPMENT
S X="ACHSGRP"
X ^%ZOSF("TEST")
E Q:ACHS("DX")=9 S DIE="^ACHSF("_DUZ(2)_",""D"",",DA=ACHSDIEN,DR="78:79" D ^DIE W ! Q
S DFN=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,22) ;PATIENT PTR
Q:'$D(^DPT(DFN,0))
D KILLS^ACHSGRP
S (ACHSOR,ACHSSD)="",ACHSSD1=1,ACHS=0,ACHSSEX=$P($G(^DPT(DFN,0)),U,2),AGE=(DT-$P($G(^DPT(DFN,0)),U,3))\365.25
F ACHSICDI=1:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("DX"),ACHS)) Q:'ACHS S ACHSICDX(ACHSICDI)=$P($G(^(ACHS,0)),U),ACHSICDX(ACHSICDI,0)=$G(^ICD9(ACHSICDX(ACHSICDI),0))
S ACHSICDT=ACHSICDI-1,ACHS=0
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
;F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($G(ICD0(D1,0)),U,2) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0 D
;ACHS*3.1*23
;F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($$ICDOP^ICDCODE(D1),U,3) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0 D
F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($$ICDOP^ICDEX((D1),,,"I"),U,3) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0 D
.S ACHSORG($P(^ICD(ACHSORG,0),U,5),ACHSORG)=""
.Q
F ACHSNSD=1:1:ACHSICDT S ACHS=ACHSICDX(ACHSNSD,0),SD=SD_$P(ACHS,U,2) S:$P(ACHS,U,2)'["g" SD1=0
F ACHSICDJ=1:1:ACHSICDT D ARR^ACHSGRP
I ACHS("DX")=9 G KGRP:'$D(ACHSICDE) S X=+$E($P(ACHSICDE($O(ACHSICDE(""))),U),4,99) G KGRP:'X S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,8),U)=X G KGRP
S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,3)=""
I $D(ACHSICDE) S X=+$E($P(ACHSICDE($O(ACHSICDE(""))),U),4,99) I X S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,3)=X D CRECT
KGRP ;
D KILLS^ACHSGRP
Q
;
CRECT ; Compute Referral Estimated cost.
S ACHSDRGW=+^ICD(X,9999999),(ACHS,ACHSRECT)=0
F ACHSI=0:1 S ACHS=$O(^AMER(2.1,ACHS)) Q:'ACHS S X=$G(^AMER(2.1,ACHS,0)),ACHSX=(ACHSDRGW*$P(X,U,2))+$P(X,U,3),ACHSX=+$J(ACHSX,1,2),ACHSRECT=ACHSRECT+ACHSX
I ACHSI S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,4)=+$J(ACHSRECT/ACHSI,1,2)
K ACHSDRGW,ACHSI,ACHSRECT,ACHSX
Q
;
CHKDT ;EP - Compare discharge date (X) and admission date (ACHSXXXZ).
Q:'$D(ACHSXXXZ)
I X<ACHSXXXZ W !!,*7,"Discharge Date CANNOT be BEFORE Admission Date!!",!! K X
Q
;
ACHSPAM ; IHS/ITSC/PMF - DOCUMENT PAYMENT - ENTER/EDIT MEDICAL DATA ; JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7,14,17,23**;JUN 11,2001;Build 43
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Remove code that deleted Dental info.
+3 ;IHS/SET/JVK ACHS*3.1*7 10/15/2003 - FIX THE CALL DUZ(2) FOR VERSION 22
+4 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
EDIT ;EP - From Option. Edit EOBR Medical data.
+1 DO SEL
+2 IF ($DATA(DUOUT))!($DATA(DTOUT))!'$DATA(ACHSDIEN)
DO END
QUIT
+3 ;
+4 ;
ENTER ;EP - After document paid.
+1 ;ACHS*3.1*17 ADDED FOR BEMJ SITES RECORD CHECK# AND COMMENTS
IF $EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,2)=18
DO ^ACHSZCK1
+2 ;IF THIS IS 'BLANKET ORDER'
+3 IF $$DOC^ACHS(0,3)
WRITE !,"UNABLE TO PROCESS MEDICAL DATA FOR BLANKET ORDER."
DO RTRN^ACHS
DO END
QUIT
+4 SET DA=ACHSDIEN
+5 ;IHS/SET/JVK *3.1*7 10/10/03 MAKE CHANGES BELOW FOR FILEMAN 22 CHANGES
+6 ;S DA(2)=DUZ(2) ; Must be set for x-ref to be set correctly.
+7 ; Must be set for x-ref to be set correctly.
IF $GET(^DD("VERSION"))>21
SET DA(1)=DUZ(2)
+8 ; Must be set for x-ref to be set correctly.
IF $GET(^DD("VERSION"))<22
SET DA(2)=DUZ(2)
+9 ;END CHANGES IHS/SET/JVK *3.1*7
+10 SET DIE="^ACHSF("_DUZ(2)_",""D"","
+11 SET DLAYGO=9002080
+12 ;ACHS*3.1*17 ADDED PRINT CHECK DATE FOR BEMJ TRIBAL SITES SITES
+13 ;S DR=$S(ACHSTYP=1:"90;91;92;94//1;",1:"")_"95;96;97"_$S($$PARM^ACHS(0,8)="Y":";51",1:"")
+14 SET DR=$SELECT(ACHSTYP=1:"90;91;92;94//1;",1:"")_"95;96;97"_$SELECT($$PARM^ACHS(0,8)="Y":";51",1:"")_$SELECT($EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10),1,2)=18:";52",1:"")
+15 SET DR(2,9002080.195)=".01"
+16 SET DR(2,9002080.196)=".01:1"
+17 SET DR(2,9002080.197)=".01:6;"_$SELECT(ACHSTYP=2:"7;8",1:"")_";9"
+18 DO ^DIE
+19 ;
+20 ;IF 'POST EOBR TO PAT CARE CMPNT' AND LINK TO PCC IS ON
+21 ;LINK TO PCC 1/2
IF $$PARM^ACHS(2,22)="Y"
IF $$LINK^ACHSPAP1
SET ACHSDOCR=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
DO ^ACHSPAP
+22 ;
+23 ;IF 'REFERRAL' PTR
+24 IF $$DOC^ACHS(2,7)
Begin DoDot:1
+25 ;TRANSFER DX INFO TO RCIS
DO DX^ACHSBMC
+26 ;TRANSFER PX INFO TO RCIS
DO PX^ACHSBMC
End DoDot:1
+27 ;
+28 ; This makes sure that a bug in FileMan doesn't leave extraneous
+29 ; nodes in the ^ACHSF( global. WHAT BUG??????? NEEDS TESTING
+30 ;F ACHS=1:1:50 I $D(^ACHSF(ACHS,"D",ACHSDIEN,11)),$D(^ACHSF(ACHS,"D",ACHSDIEN))=10 D;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+31 ;. K ^ACHSF(ACHS,"D",ACHSDIEN,11);IHS/SET/GTH ACHS*3.1*5 12/06/2002
+32 ;. S DA(2)=DUZ(2),DA(1)=ACHSDIEN,DA=0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+33 ;. F S DA=$O(^ACHSF(DA(2),"D",DA(1),11,DA)) Q:'DA S X=$P(^(DA,0),U) X ^DD(9002080.197,.01,1,1,1);IHS/SET/GTH ACHS*3.1*5 12/06/2002
+34 ;.Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+35 ;
+36 DO END
+37 QUIT
+38 ;
SEL ;EP - Select document, display data.
+1 ;SELECT DOCUMENT
DO ^ACHSUD
+2 IF $DATA(DUOUT)!$DATA(DTOUT)!'$DATA(ACHSDIEN)
DO END
QUIT
+3 SET ACHSTIEN=1
+4 KILL ACHSSIG
+5 ;INITIALIZE DOCUMENT/TRANSACTION VARIABLES
DO INIT^ACHSRP2
+6 ;DOCUMENT DISPLAY; THIS RTN ALSO DOES INIT^ACHSRP2
DO ^ACHSAV
+7 SET ACHSADJ=""
+8 ;
+9 ;DISPLAY DOCUMENT CANCEL/SUPPLEMENTAL INFO. THIS
DO A0A^ACHSUSC
+10 ; CALL BYPASSES THE INIT^ACHSRP2 IN ACHSUSC
+11 ;
+12 KILL ACHSADJ
+13 IF $DATA(ACHSDIEN)
IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+")
WRITE !,"LOCK FAILED AT SEL+9^ACHSPAM"
KILL ACHSDIEN
+14 QUIT
+15 ;
REF ;EP - From option. Enter/Edit Referral medical data.
+1 DO SEL
+2 IF $DATA(DTOUT)!$DATA(DTOUT)!'$DATA(ACHSDIEN)
DO END
QUIT
+3 ;
+4 IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)!($PIECE(^(0),U,4)=2)
WRITE *7,!,"NO ENTRY OF REFERRAL DATA TO THIS TYPE DOCUMENT ALLOWED.",!
DO RTRN^ACHS
GOTO END
+5 SET DIE="^ACHSF("_DUZ(2)_",""D"","
SET DA=ACHSDIEN
SET DR="80:83;84:87"
+6 DO ^DIE
+7 WRITE !
+8 SET ACHS("DX")=4
SET ACHS("PX")=6
+9 ;
+10 ;Compute and set DRG or Referral
DO CDRG
+11 ; DRG & Referral Estimated cost.
+12 ;
END ; Unlock, kill vars, quit.
+1 IF $DATA(ACHSDIEN)
IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")
+2 KILL ACHSPROV,ACHSCONP,ACHSCAN,ACHSDRG,ACHSSCC,ACHSCOPT,ACHSDOCR,ACHSESDA,ACHSESDO,ACHSFDT,ACHSODT
+3 KILL ACHSTDT,ACHSHON,ACHSORDN,ACHSBLKF,ACHSIPA,ACHSSIG,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSPCCL
+4 ;*3.1*23 added DIADD AND LAYGO
KILL DIC,DIE,DLAYGO,DR,D0,D1,DIADD,LAYGO
+5 QUIT
+6 ;
CDRG ;EP - Compute and set DRG or Referral DRG & Referral Estimated cost.
+1 ;BYPASS CALCULATING DRG UNTIL FURTHER DEVELOPMENT
QUIT
+2 SET X="ACHSGRP"
+3 XECUTE ^%ZOSF("TEST")
+4 IF '$TEST
IF ACHS("DX")=9
QUIT
SET DIE="^ACHSF("_DUZ(2)_",""D"","
SET DA=ACHSDIEN
SET DR="78:79"
DO ^DIE
WRITE !
QUIT
+5 ;PATIENT PTR
SET DFN=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,22)
+6 IF '$DATA(^DPT(DFN,0))
QUIT
+7 DO KILLS^ACHSGRP
+8 SET (ACHSOR,ACHSSD)=""
SET ACHSSD1=1
SET ACHS=0
SET ACHSSEX=$PIECE($GET(^DPT(DFN,0)),U,2)
SET AGE=(DT-$PIECE($GET(^DPT(DFN,0)),U,3))\365.25
+9 FOR ACHSICDI=1:1
SET ACHS=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("DX"),ACHS))
IF 'ACHS
QUIT
SET ACHSICDX(ACHSICDI)=$PIECE($GET(^(ACHS,0)),U)
SET ACHSICDX(ACHSICDI,0)=$GET(^ICD9(ACHSICDX(ACHSICDI),0))
+10 SET ACHSICDT=ACHSICDI-1
SET ACHS=0
+11 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+12 ;F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($G(ICD0(D1,0)),U,2) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0 D
+13 ;ACHS*3.1*23
+14 ;F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($$ICDOP^ICDCODE(D1),U,3) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0 D
+15 FOR ACHSNOR=0:1
SET ACHS=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS))
IF 'ACHS
QUIT
IF +^(ACHS,0)>0
SET D1=+^(0)
SET ACHSOR=ACHSOR_$PIECE($$ICDOP^ICDEX((D1),,,"I"),U,3)
FOR ACHSORG=0:0
SET ACHSORG=$ORDER(^ICD0(D1,"DR",ACHSORG))
IF ACHSORG'>0
QUIT
Begin DoDot:1
+16 SET ACHSORG($PIECE(^ICD(ACHSORG,0),U,5),ACHSORG)=""
+17 QUIT
End DoDot:1
+18 FOR ACHSNSD=1:1:ACHSICDT
SET ACHS=ACHSICDX(ACHSNSD,0)
SET SD=SD_$PIECE(ACHS,U,2)
IF $PIECE(ACHS,U,2)'["g"
SET SD1=0
+19 FOR ACHSICDJ=1:1:ACHSICDT
DO ARR^ACHSGRP
+20 IF ACHS("DX")=9
IF '$DATA(ACHSICDE)
GOTO KGRP
SET X=+$EXTRACT($PIECE(ACHSICDE($ORDER(ACHSICDE(""))),U),4,99)
IF 'X
GOTO KGRP
SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,8),U)=X
GOTO KGRP
+21 SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,3)=""
+22 IF $DATA(ACHSICDE)
SET X=+$EXTRACT($PIECE(ACHSICDE($ORDER(ACHSICDE(""))),U),4,99)
IF X
SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,3)=X
DO CRECT
KGRP ;
+1 DO KILLS^ACHSGRP
+2 QUIT
+3 ;
CRECT ; Compute Referral Estimated cost.
+1 SET ACHSDRGW=+^ICD(X,9999999)
SET (ACHS,ACHSRECT)=0
+2 FOR ACHSI=0:1
SET ACHS=$ORDER(^AMER(2.1,ACHS))
IF 'ACHS
QUIT
SET X=$GET(^AMER(2.1,ACHS,0))
SET ACHSX=(ACHSDRGW*$PIECE(X,U,2))+$PIECE(X,U,3)
SET ACHSX=+$JUSTIFY(ACHSX,1,2)
SET ACHSRECT=ACHSRECT+ACHSX
+3 IF ACHSI
SET $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,4)=+$JUSTIFY(ACHSRECT/ACHSI,1,2)
+4 KILL ACHSDRGW,ACHSI,ACHSRECT,ACHSX
+5 QUIT
+6 ;
CHKDT ;EP - Compare discharge date (X) and admission date (ACHSXXXZ).
+1 IF '$DATA(ACHSXXXZ)
QUIT
+2 IF X<ACHSXXXZ
WRITE !!,*7,"Discharge Date CANNOT be BEFORE Admission Date!!",!!
KILL X
+3 QUIT
+4 ;
