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
