ADGCRB6 ; IHS/ADC/PDW/ENM - A SHEET lines 12-14 ; [ 10/16/2000 1:58 PM ]
;;5.3;ADMISSION/DISCHARGE/TRANSFER;**3,1008,1016**;MAR 25, 1999;Build 20
;
;cmi/anch/maw 12/7/2007 patch 1008 added code set versioning H13,ICD
;
A ; -- driver
I DGDS D H14,L14 Q
D H12,L12,H13,H14,L14 Q
;
H12 ; -- sub heading 12
W !,DGLIN1,!,"40 Injury Date 41 Alleged Injury Cause"
;W ?41,"42 E-Code",?51,"43 Place of Injury 44 Code",! Q
;ihs/cmi/maw 07/02/2012 PATCH 1016 changed E-Code to External Cause
W ?41,"42 Cause",?61,"43 Place of Injury 44 Code",! Q
;
L12 ; -- data line 12 (injury data)
Q:'$D(DGPOVDA)
;W ?3,$$IDT,?17,$P($$ICD,U,2),?44,$P($$ICD,U),?54,$$PLC
;ihs/cmi/maw 07/02/2012 PATCH 1016 moved location of data
W ?3,$$IDT,?17,$P($$ICD,U,2),?44,$P($$ICD,U),?54,$$PLC
W ?75,$P(DGPOVN0,U,11) Q
;
H13 ; -- underlying cause of death
N DGN11 S DGN11=$G(^AUPNPAT(DFN,11)) ;IHS/DSD/ENM 10/19/99
N X S X=$P(DGN11,U,14) Q:'X
W !,DGLIN1,!,"47 Underlying Cause of Death & Code",!
;W ?49,$E($P(^ICD9(X,0),U,3),1,16),?67,$P(^(0),U) Q
W ?49,$E($P($$ICDDX^ICDCODE(X),U,4),1,16),?67,$P($$ICDDX^ICDCODE(X),U,2) Q
;
H14 ; -- sub heading 14
W !,DGLIN1,!,"49 Date Printed",?17,"50 Attending Physician"
I DGDS W ?42,"50a Phys Code",?62,"51 Printed By",! Q
W ?42,"50a Phys Code",?58,"51 Admit Clerk/Coder",! Q
;
L14 ; -- data line 14
;IHS/ITSC/ENM 10/16/2000 "Break Cmd removed"
W ?4,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3)
I DGDS D Q
. W ?21,$P($$PRV,U),?47,$P($$PRV,U,2),?66,$P(^VA(200,DUZ,0),U,2),!
W ?21,$P($$PRV,U),?47,$P($$PRV,U,2),?66,$$ADMCLK,$$CODER,! Q
;
IDT() ; -- injury date
N Y S Y=$P(DGPOVN0,U,13) Q:'Y "" X ^DD("DD") Q Y
;
ICD() ; -- cause of injury
;Q $P($G(^ICD9(+$P(DGPOVN0,U,9),0)),U)_U_$P($G(^(0)),U,3)
Q $P($$ICDDX^ICDCODE(+$P(DGPOVN0,U,9)),U,2)_U_$P($$ICDDX^ICDCODE(+$P(DGPOVN0,U,9)),U,4)
;
PLC() ; -- place of injury
N Y,C S Y=$P(DGPOVN0,U,11) Q:Y="" ""
S C=^DD(9000010.07,.11,0) D Y^DIQ Q Y
;
PRV() ; -- provider name & code
N X,Y,DA,DGAR,PROV
S X=0 F S X=$O(^AUPNVPRV("AD",DGVSDA,X)) Q:'X D
. Q:'$D(^AUPNVPRV(X,0)) S:$P(^(0),U,4)="P" DA=+^(0)
I '$D(DA) Q ""
I $P(^DD(9000010.06,.01,0),U,2)["200" S PROV=DA
E S PROV=$G(^DIC(16,DA,"A3")) I PROV="" Q ""
K DGAR D ENP^XBDIQ1(200,PROV,".01;9999999.039","DGAR(")
Q DGAR(.01)_U_DGAR(9999999.039)
;
ADMCLK() ; -- admitting clerk
NEW X
S X=$P($G(^DGPM(DGFN,"USR")),U) I X="" Q X
Q $P($G(^VA(200,X,0)),U,2)
;
CODEROLD() ; -- coding clerk
N DGX,DA,PROV,DGAR,ANS
S DGX=0 F S DGX=$O(^AUPNVPRV("AD",DGVSDA,DGX)) Q:'DGX!($D(ANS)) D
. Q:'$D(^AUPNVPRV(DGX,0)) Q:$P(^(0),U,4)="P" S DA=+^(0)
. I $P(^DD(9000010.06,.01,0),U,2)["200" S PROV=DA
. E S PROV=$G(^DIC(16,DA,"A3")) Q:PROV=""
. K DGAR D ENP^XBDIQ1(200,PROV,"1;53.5","DGAR(","I")
. Q:DGAR(53.5)=""
. Q:$$VAL^XBDIQ1(7,DGAR(53.5,"I"),9999999.01)'="88"
. S ANS="/"_DGAR(1)
Q $G(ANS)
;
CODER() ;-- coding clerk searhc/maw 4/17/98
N DGCD,DGX,DGXIEN
S DGX=0 F S DGX=$O(^APCDFORM("AB",DGVSDA,DGX)) Q:DGX="" D
. S DGXIEN=$O(^APCDFORM("AB",DGVSDA,DGX,0))
. I '$D(^APCDFORM(DGX,11,DGXIEN,0)) S DGCD="" Q DGCD
. S DGCD=$P(^APCDFORM(DGX,11,DGXIEN,0),U,2)
. S DGCD=$P(^VA(200,DGCD,0),U,2)
. S DGCD="/"_DGCD
Q $G(DGCD) ;IHS/DSD/ENM 02/19/99
;
ADGCRB6 ; IHS/ADC/PDW/ENM - A SHEET lines 12-14 ; [ 10/16/2000 1:58 PM ]
+1 ;;5.3;ADMISSION/DISCHARGE/TRANSFER;**3,1008,1016**;MAR 25, 1999;Build 20
+2 ;
+3 ;cmi/anch/maw 12/7/2007 patch 1008 added code set versioning H13,ICD
+4 ;
A ; -- driver
+1 IF DGDS
DO H14
DO L14
QUIT
+2 DO H12
DO L12
DO H13
DO H14
DO L14
QUIT
+3 ;
H12 ; -- sub heading 12
+1 WRITE !,DGLIN1,!,"40 Injury Date 41 Alleged Injury Cause"
+2 ;W ?41,"42 E-Code",?51,"43 Place of Injury 44 Code",! Q
+3 ;ihs/cmi/maw 07/02/2012 PATCH 1016 changed E-Code to External Cause
+4 WRITE ?41,"42 Cause",?61,"43 Place of Injury 44 Code",!
QUIT
+5 ;
L12 ; -- data line 12 (injury data)
+1 IF '$DATA(DGPOVDA)
QUIT
+2 ;W ?3,$$IDT,?17,$P($$ICD,U,2),?44,$P($$ICD,U),?54,$$PLC
+3 ;ihs/cmi/maw 07/02/2012 PATCH 1016 moved location of data
+4 WRITE ?3,$$IDT,?17,$PIECE($$ICD,U,2),?44,$PIECE($$ICD,U),?54,$$PLC
+5 WRITE ?75,$PIECE(DGPOVN0,U,11)
QUIT
+6 ;
H13 ; -- underlying cause of death
+1 ;IHS/DSD/ENM 10/19/99
NEW DGN11
SET DGN11=$GET(^AUPNPAT(DFN,11))
+2 NEW X
SET X=$PIECE(DGN11,U,14)
IF 'X
QUIT
+3 WRITE !,DGLIN1,!,"47 Underlying Cause of Death & Code",!
+4 ;W ?49,$E($P(^ICD9(X,0),U,3),1,16),?67,$P(^(0),U) Q
+5 WRITE ?49,$EXTRACT($PIECE($$ICDDX^ICDCODE(X),U,4),1,16),?67,$PIECE($$ICDDX^ICDCODE(X),U,2)
QUIT
+6 ;
H14 ; -- sub heading 14
+1 WRITE !,DGLIN1,!,"49 Date Printed",?17,"50 Attending Physician"
+2 IF DGDS
WRITE ?42,"50a Phys Code",?62,"51 Printed By",!
QUIT
+3 WRITE ?42,"50a Phys Code",?58,"51 Admit Clerk/Coder",!
QUIT
+4 ;
L14 ; -- data line 14
+1 ;IHS/ITSC/ENM 10/16/2000 "Break Cmd removed"
+2 WRITE ?4,$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
+3 IF DGDS
Begin DoDot:1
+4 WRITE ?21,$PIECE($$PRV,U),?47,$PIECE($$PRV,U,2),?66,$PIECE(^VA(200,DUZ,0),U,2),!
End DoDot:1
QUIT
+5 WRITE ?21,$PIECE($$PRV,U),?47,$PIECE($$PRV,U,2),?66,$$ADMCLK,$$CODER,!
QUIT
+6 ;
IDT() ; -- injury date
+1 NEW Y
SET Y=$PIECE(DGPOVN0,U,13)
IF 'Y
QUIT ""
XECUTE ^DD("DD")
QUIT Y
+2 ;
ICD() ; -- cause of injury
+1 ;Q $P($G(^ICD9(+$P(DGPOVN0,U,9),0)),U)_U_$P($G(^(0)),U,3)
+2 QUIT $PIECE($$ICDDX^ICDCODE(+$PIECE(DGPOVN0,U,9)),U,2)_U_$PIECE($$ICDDX^ICDCODE(+$PIECE(DGPOVN0,U,9)),U,4)
+3 ;
PLC() ; -- place of injury
+1 NEW Y,C
SET Y=$PIECE(DGPOVN0,U,11)
IF Y=""
QUIT ""
+2 SET C=^DD(9000010.07,.11,0)
DO Y^DIQ
QUIT Y
+3 ;
PRV() ; -- provider name & code
+1 NEW X,Y,DA,DGAR,PROV
+2 SET X=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",DGVSDA,X))
IF 'X
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVPRV(X,0))
QUIT
IF $PIECE(^(0),U,4)="P"
SET DA=+^(0)
End DoDot:1
+4 IF '$DATA(DA)
QUIT ""
+5 IF $PIECE(^DD(9000010.06,.01,0),U,2)["200"
SET PROV=DA
+6 IF '$TEST
SET PROV=$GET(^DIC(16,DA,"A3"))
IF PROV=""
QUIT ""
+7 KILL DGAR
DO ENP^XBDIQ1(200,PROV,".01;9999999.039","DGAR(")
+8 QUIT DGAR(.01)_U_DGAR(9999999.039)
+9 ;
ADMCLK() ; -- admitting clerk
+1 NEW X
+2 SET X=$PIECE($GET(^DGPM(DGFN,"USR")),U)
IF X=""
QUIT X
+3 QUIT $PIECE($GET(^VA(200,X,0)),U,2)
+4 ;
CODEROLD() ; -- coding clerk
+1 NEW DGX,DA,PROV,DGAR,ANS
+2 SET DGX=0
FOR
SET DGX=$ORDER(^AUPNVPRV("AD",DGVSDA,DGX))
IF 'DGX!($DATA(ANS))
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVPRV(DGX,0))
QUIT
IF $PIECE(^(0),U,4)="P"
QUIT
SET DA=+^(0)
+4 IF $PIECE(^DD(9000010.06,.01,0),U,2)["200"
SET PROV=DA
+5 IF '$TEST
SET PROV=$GET(^DIC(16,DA,"A3"))
IF PROV=""
QUIT
+6 KILL DGAR
DO ENP^XBDIQ1(200,PROV,"1;53.5","DGAR(","I")
+7 IF DGAR(53.5)=""
QUIT
+8 IF $$VAL^XBDIQ1(7,DGAR(53.5,"I"),9999999.01)'="88"
QUIT
+9 SET ANS="/"_DGAR(1)
End DoDot:1
+10 QUIT $GET(ANS)
+11 ;
CODER() ;-- coding clerk searhc/maw 4/17/98
+1 NEW DGCD,DGX,DGXIEN
+2 SET DGX=0
FOR
SET DGX=$ORDER(^APCDFORM("AB",DGVSDA,DGX))
IF DGX=""
QUIT
Begin DoDot:1
+3 SET DGXIEN=$ORDER(^APCDFORM("AB",DGVSDA,DGX,0))
+4 IF '$DATA(^APCDFORM(DGX,11,DGXIEN,0))
SET DGCD=""
QUIT DGCD
+5 SET DGCD=$PIECE(^APCDFORM(DGX,11,DGXIEN,0),U,2)
+6 SET DGCD=$PIECE(^VA(200,DGCD,0),U,2)
+7 SET DGCD="/"_DGCD
End DoDot:1
+8 ;IHS/DSD/ENM 02/19/99
QUIT $GET(DGCD)
+9 ;
