- ADGLOC1 ; IHS/ADC/PDW/ENM - LOCATOR CARD - print ; [ 03/25/1999 11:48 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- A ; -- patient demographic
- N N0,N11,N21,N
- Q:'$D(DFN) S N0=$G(^DPT(DFN,0)),N11=$G(^AUPNPAT(DFN,11))
- U IO W !!!?8,"***Confidential Patient Data***",!
- W ?5,$E($P(N0,U),1,25),?29,"Chart #: ",$$HRCN^ADGF
- W !!?5,"SSN: ",$$SSN,?29,"Classif: ",$$CLS
- W !?5,"Age: ",$$AGE,?23,"Date of Birth: ",$$DOB
- W !?5,"Sex: ",$P(N0,U,2),?28,"Religion: ",$$REL
- ; -- mailing address
- I $D(^DPT(DFN,.11)) S N11=^(.11) D
- . W !!?5,"Patient's Address: ",!
- . W ?5,$P(N11,U)," ",$P(N11,U,4),", ",$$STM," ",$P(N11,U,6)
- ; -- next of kin
- I $D(^DPT(DFN,.21)) S N21=^(.21) D
- . W !?5,"Next of Kin:",!?5,$P(N21,U),?37,$$NOKR,!?5,$P(N21,U,3)," "
- . W $P(N21,U,6),", ",$$STN," ",$P(N21,U,8),!?26,"Phone: ",$P(N21,U,9)
- ; -- admission info
- Q:'$D(IFN) S N=$G(^DGPM(IFN,0))
- W !!?5,"Admission Date: ",?20,$$ADT," ",$$TIM,!!?5,$P(N0,U)
- W:$D(^DPT(DFN,.1)) ?36,$E(^(.1),1,3) W ?41,$$TS,@IOF Q
- ;
- NOKR() ; -- nok relationship
- Q $P($G(^AUPNPAT(DFN,28)),U,2)
- ;
- DOB() ; -- date of birth
- Q $E($P(N0,U,3),4,5)_"/"_$E($P(N0,U,3),6,7)_"/"_$E($P(N0,U,3),2,3)
- ;
- TS() ; -- treating specialty
- Q $E($P($G(^DIC(45.7,+$G(^DPT(DFN,.103)),0)),U),1,3)
- ;
- ADT() ; -- admission date
- N Y S Y=$P(+N,".") X ^DD("DD") Q Y
- ;
- TIM() ; -- admission time
- N Y S Y=+N X ^DD("DD") Q $P(Y,"@",2)
- ;
- SSN() ; -- social security number
- Q $E($P(N0,U,9),1,3)_"-"_$E($P(N0,U,9),4,5)_"-"_$E($P(N0,U,9),6,9)
- ;
- CLS() ; -- classification/beneficiary & classif code
- Q $E($P($G(^AUTTBEN(+$P(N11,U,11),0)),U),1,3)_"-"_$P($G(^(0)),U,2)
- ;
- REL() ; -- religion
- Q $P($G(^DIC(13,+$P(N0,U,8),0)),U)
- ;
- STM() ; -- state, mailing
- Q $P($G(^DIC(5,+$P(N11,U,5),0)),U,2)
- ;
- STN() ; -- state, nok
- Q $P($G(^DIC(5,+$P(N21,U,7),0)),U,2)
- ;
- AGE() ; -- age
- N X,DIC,DR,DA K ^UTILITY("DIQ1",$J) S DIC=2,DR=.033,DA=DFN D EN^DIQ1
- S X=^UTILITY("DIQ1",$J,2,DA,.033) K ^UTILITY("DIQ1",$J) Q X
- ADGLOC1 ; IHS/ADC/PDW/ENM - LOCATOR CARD - print ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- A ; -- patient demographic
- +1 NEW N0,N11,N21,N
- +2 IF '$DATA(DFN)
- QUIT
- SET N0=$GET(^DPT(DFN,0))
- SET N11=$GET(^AUPNPAT(DFN,11))
- +3 USE IO
- WRITE !!!?8,"***Confidential Patient Data***",!
- +4 WRITE ?5,$EXTRACT($PIECE(N0,U),1,25),?29,"Chart #: ",$$HRCN^ADGF
- +5 WRITE !!?5,"SSN: ",$$SSN,?29,"Classif: ",$$CLS
- +6 WRITE !?5,"Age: ",$$AGE,?23,"Date of Birth: ",$$DOB
- +7 WRITE !?5,"Sex: ",$PIECE(N0,U,2),?28,"Religion: ",$$REL
- +8 ; -- mailing address
- +9 IF $DATA(^DPT(DFN,.11))
- SET N11=^(.11)
- Begin DoDot:1
- +10 WRITE !!?5,"Patient's Address: ",!
- +11 WRITE ?5,$PIECE(N11,U)," ",$PIECE(N11,U,4),", ",$$STM," ",$PIECE(N11,U,6)
- End DoDot:1
- +12 ; -- next of kin
- +13 IF $DATA(^DPT(DFN,.21))
- SET N21=^(.21)
- Begin DoDot:1
- +14 WRITE !?5,"Next of Kin:",!?5,$PIECE(N21,U),?37,$$NOKR,!?5,$PIECE(N21,U,3)," "
- +15 WRITE $PIECE(N21,U,6),", ",$$STN," ",$PIECE(N21,U,8),!?26,"Phone: ",$PIECE(N21,U,9)
- End DoDot:1
- +16 ; -- admission info
- +17 IF '$DATA(IFN)
- QUIT
- SET N=$GET(^DGPM(IFN,0))
- +18 WRITE !!?5,"Admission Date: ",?20,$$ADT," ",$$TIM,!!?5,$PIECE(N0,U)
- +19 IF $DATA(^DPT(DFN,.1))
- WRITE ?36,$EXTRACT(^(.1),1,3)
- WRITE ?41,$$TS,@IOF
- QUIT
- +20 ;
- NOKR() ; -- nok relationship
- +1 QUIT $PIECE($GET(^AUPNPAT(DFN,28)),U,2)
- +2 ;
- DOB() ; -- date of birth
- +1 QUIT $EXTRACT($PIECE(N0,U,3),4,5)_"/"_$EXTRACT($PIECE(N0,U,3),6,7)_"/"_$EXTRACT($PIECE(N0,U,3),2,3)
- +2 ;
- TS() ; -- treating specialty
- +1 QUIT $EXTRACT($PIECE($GET(^DIC(45.7,+$GET(^DPT(DFN,.103)),0)),U),1,3)
- +2 ;
- ADT() ; -- admission date
- +1 NEW Y
- SET Y=$PIECE(+N,".")
- XECUTE ^DD("DD")
- QUIT Y
- +2 ;
- TIM() ; -- admission time
- +1 NEW Y
- SET Y=+N
- XECUTE ^DD("DD")
- QUIT $PIECE(Y,"@",2)
- +2 ;
- SSN() ; -- social security number
- +1 QUIT $EXTRACT($PIECE(N0,U,9),1,3)_"-"_$EXTRACT($PIECE(N0,U,9),4,5)_"-"_$EXTRACT($PIECE(N0,U,9),6,9)
- +2 ;
- CLS() ; -- classification/beneficiary & classif code
- +1 QUIT $EXTRACT($PIECE($GET(^AUTTBEN(+$PIECE(N11,U,11),0)),U),1,3)_"-"_$PIECE($GET(^(0)),U,2)
- +2 ;
- REL() ; -- religion
- +1 QUIT $PIECE($GET(^DIC(13,+$PIECE(N0,U,8),0)),U)
- +2 ;
- STM() ; -- state, mailing
- +1 QUIT $PIECE($GET(^DIC(5,+$PIECE(N11,U,5),0)),U,2)
- +2 ;
- STN() ; -- state, nok
- +1 QUIT $PIECE($GET(^DIC(5,+$PIECE(N21,U,7),0)),U,2)
- +2 ;
- AGE() ; -- age
- +1 NEW X,DIC,DR,DA
- KILL ^UTILITY("DIQ1",$JOB)
- SET DIC=2
- SET DR=.033
- SET DA=DFN
- DO EN^DIQ1
- +2 SET X=^UTILITY("DIQ1",$JOB,2,DA,.033)
- KILL ^UTILITY("DIQ1",$JOB)
- QUIT X
