- ADGCRB2 ; IHS/ADC/PDW/ENM - A SHEET lines 3&4 ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- A ; -- driver
- D H3,L3,H4,L4 Q
- ;
- H3 ; -- sub heading 3
- W !,DGLIN1,!,"4 Birthdate",?18,"5 Sex",?26,"6 Tribe"
- I DGDS W ?36,"17&18 Service & Code",?62,"19 Surgery Date",! Q
- W ?36,"17&18 Admit Srvc & Code",?62,"19 Admit Date",! Q
- ;
- L3 ; -- data line 3
- W ?2,$$DOB,?21,$P(DGN0,U,2),?28,$$TRB,?44,$$SRV,?65,$$ADT Q
- ;
- H4 ; -- sub heading 4
- W !,DGLIN1,!,"8 Community, County, State Code",?36,"Ward"
- I DGDS W ?43,"Provider",?62,"20 Release Date",! Q
- W ?43,"Provider",?62,"20 Discharge Date",! Q
- ;
- L4 ; -- data line 4
- W ?6,$$COM,?37,$$WRD,?43,$$PRV,?65,$$DDT Q
- ;
- DOB() ; -- date of birth
- N Y S Y=$P(DGN0,U,3) X ^DD("DD") Q Y
- ;
- TRB() ; -- tribe
- Q $E($P($G(^AUTTTRI(+$P(DGN11,U,8),0)),U),1,3)_$P($G(^(0)),U,2)
- ;
- ADT() ; -- admission date
- N Y S Y=$P(+DGN,".") X ^DD("DD") Q Y
- ;
- COM() ; -- community
- N X
- S X=$S(+$P(DGN11,U,17):$P(DGN11,U,17),1:$O(^AUTTCOM("B",$P(DGN11,U,18),0)))
- S X=$P($G(^AUTTCOM(+X,0)),U,8) Q:X="" ""
- Q $E(X,5,7)_"-"_$E(X,3,4)_"-"_$E(X,1,2)
- ;
- WRD() ; -- ward
- Q $E($P($G(^DIC(42,+$S(DGDS:$P(DGN,U,3),1:$P(DGN,U,6)),0)),U),1,3)
- ;
- DDT() ; -- discharge date
- I DGDS N Y S Y=$P($G(^ADGDS(DFN,"DS",+DGDS,2)),U) X ^DD("DD") Q $P(Y,"@")
- N Y S Y=$P($G(^DGPM(+$P(DGN,U,17),0)),".") X ^DD("DD") Q $P(Y,"@")
- ;
- PRV() ; -- provider
- Q:DGDS $E($P($G(^VA(200,+$P(DGN,U,6),0)),U),1,14)
- Q $E($P($G(^VA(200,+$P($G(^DGPM(+$O(^DGPM("APHY",DGFN,0)),0)),U,8),0)),U),1,14)
- ;
- SRV() ; -- treating specialty & code
- Q:DGDS $E($P($G(^DIC(45.7,+$P(DGN,U,5),0)),U),1,3)_" "_$P($G(^(9999999)),U)
- Q $E($P($G(^DIC(45.7,+$P($G(^DGPM(+$O(^DGPM("APHY",DGFN,0)),0)),U,9),0)),U),1,3)_" "_$P($G(^(9999999)),U)
- ADGCRB2 ; IHS/ADC/PDW/ENM - A SHEET lines 3&4 ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- A ; -- driver
- +1 DO H3
- DO L3
- DO H4
- DO L4
- QUIT
- +2 ;
- H3 ; -- sub heading 3
- +1 WRITE !,DGLIN1,!,"4 Birthdate",?18,"5 Sex",?26,"6 Tribe"
- +2 IF DGDS
- WRITE ?36,"17&18 Service & Code",?62,"19 Surgery Date",!
- QUIT
- +3 WRITE ?36,"17&18 Admit Srvc & Code",?62,"19 Admit Date",!
- QUIT
- +4 ;
- L3 ; -- data line 3
- +1 WRITE ?2,$$DOB,?21,$PIECE(DGN0,U,2),?28,$$TRB,?44,$$SRV,?65,$$ADT
- QUIT
- +2 ;
- H4 ; -- sub heading 4
- +1 WRITE !,DGLIN1,!,"8 Community, County, State Code",?36,"Ward"
- +2 IF DGDS
- WRITE ?43,"Provider",?62,"20 Release Date",!
- QUIT
- +3 WRITE ?43,"Provider",?62,"20 Discharge Date",!
- QUIT
- +4 ;
- L4 ; -- data line 4
- +1 WRITE ?6,$$COM,?37,$$WRD,?43,$$PRV,?65,$$DDT
- QUIT
- +2 ;
- DOB() ; -- date of birth
- +1 NEW Y
- SET Y=$PIECE(DGN0,U,3)
- XECUTE ^DD("DD")
- QUIT Y
- +2 ;
- TRB() ; -- tribe
- +1 QUIT $EXTRACT($PIECE($GET(^AUTTTRI(+$PIECE(DGN11,U,8),0)),U),1,3)_$PIECE($GET(^(0)),U,2)
- +2 ;
- ADT() ; -- admission date
- +1 NEW Y
- SET Y=$PIECE(+DGN,".")
- XECUTE ^DD("DD")
- QUIT Y
- +2 ;
- COM() ; -- community
- +1 NEW X
- +2 SET X=$SELECT(+$PIECE(DGN11,U,17):$PIECE(DGN11,U,17),1:$ORDER(^AUTTCOM("B",$PIECE(DGN11,U,18),0)))
- +3 SET X=$PIECE($GET(^AUTTCOM(+X,0)),U,8)
- IF X=""
- QUIT ""
- +4 QUIT $EXTRACT(X,5,7)_"-"_$EXTRACT(X,3,4)_"-"_$EXTRACT(X,1,2)
- +5 ;
- WRD() ; -- ward
- +1 QUIT $EXTRACT($PIECE($GET(^DIC(42,+$SELECT(DGDS:$PIECE(DGN,U,3),1:$PIECE(DGN,U,6)),0)),U),1,3)
- +2 ;
- DDT() ; -- discharge date
- +1 IF DGDS
- NEW Y
- SET Y=$PIECE($GET(^ADGDS(DFN,"DS",+DGDS,2)),U)
- XECUTE ^DD("DD")
- QUIT $PIECE(Y,"@")
- +2 NEW Y
- SET Y=$PIECE($GET(^DGPM(+$PIECE(DGN,U,17),0)),".")
- XECUTE ^DD("DD")
- QUIT $PIECE(Y,"@")
- +3 ;
- PRV() ; -- provider
- +1 IF DGDS
- QUIT $EXTRACT($PIECE($GET(^VA(200,+$PIECE(DGN,U,6),0)),U),1,14)
- +2 QUIT $EXTRACT($PIECE($GET(^VA(200,+$PIECE($GET(^DGPM(+$ORDER(^DGPM("APHY",DGFN,0)),0)),U,8),0)),U),1,14)
- +3 ;
- SRV() ; -- treating specialty & code
- +1 IF DGDS
- QUIT $EXTRACT($PIECE($GET(^DIC(45.7,+$PIECE(DGN,U,5),0)),U),1,3)_" "_$PIECE($GET(^(9999999)),U)
- +2 QUIT $EXTRACT($PIECE($GET(^DIC(45.7,+$PIECE($GET(^DGPM(+$ORDER(^DGPM("APHY",DGFN,0)),0)),U,9),0)),U),1,3)_" "_$PIECE($GET(^(9999999)),U)
