- 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 ;
