ADGCRB1 ; IHS/ADC/PDW/ENM - A SHEET lines 1&2 ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
A ; -- driver
D INI,HDH,H1,L1,H2,L2,^ADGCRB2,^ADGCRB3,^ADGCRB4 Q
;
INI ; -- initialize variables
S (DGLIN,DGLIN1)="",$P(DGLIN,"=",80)="",$P(DGLIN1,"-",80)=""
S DGN=$S(DGDS:^ADGDS(DFN,"DS",+DGDS,0),1:^DGPM(DGFN,0))
S DGN0=^DPT(DFN,0),DGN11=$G(^AUPNPAT(DFN,11)) Q
;
HDH ; -- print heading
W $S(DGDS:"DAY SURGERY WORKSHEET",1:"CLINICAL RECORD BRIEF")
W " **Confidential Patient Data Covered by Privacy Act** "
W:'DGDS $$N1 W !,DGLIN Q
;
H1 ; -- sub heading 1
W !,"1 IHS Unit No.",?16,"2 Soc Sec No",?30,"10 Classif."
W ?44,"11 Facility",?60,"12 Facility Code",! Q
;
L1 ; -- data line 1
W ?3,$$HRCN^ADGF,?17,$$SSN,?33,$$CLS,?47,$$FACN,?63,$$FACC Q
;
H2 ; -- sub heading 2
W !,DGLIN1,!,"3 Last Name, First, Middle",?29,"13 Age"
I DGDS W ?37,"14 Religion",?53,"15 Hr Arrvd",?66,"16 Visit Type",! Q
W ?37,"14 Religion",?53,"15 Hr Admit",?66,"16 Admit Code",! Q
;
L2 ; -- data line 2
W ?2,$P(DGN0,U),?32,$$AGE,?40,$$REL,?58,$$TIM,?69,$$CDE Q
;
SSN() ; -- social security number
Q:$P(DGN0,U,9)="" "UNKNOWN"
Q $E($P(DGN0,U,9),1,3)_"-"_$E($P(DGN0,U,9),4,5)_"-"_$E($P(DGN0,U,9),6,9)
;
CLS() ; -- classification/beneficiary & classif code
Q $E($P($G(^AUTTBEN(+$P(DGN11,U,11),0)),U),1,3)_"-"_$P($G(^(0)),U,2)
;
FACN() ; -- facility
Q $P($G(^AUTTLOC(+DUZ(2),0)),U,2)
;
FACC() ; -- facility code
N X I '$D(DUZ(2))!('$D(^AUTTLOC(DUZ(2),0))) Q "UNKNOWN"
S X=$P(^AUTTLOC(DUZ(2),0),U,10) Q $E(X,1,2)_"-"_$E(X,3,4)_"-"_$E(X,5,6)
;
AGE() ; -- age
N X 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),DIC,DR,DA Q X
;
REL() ; -- religion
Q $E($P($G(^DIC(13,+$P(DGN0,U,8),0)),U),1,12)
;
TIM() ; -- admit time
Q $E(($P(+DGN,".",2)_"000"),1,4)
;
CDE() ; -- admission code
Q $S(DGDS:"DAY SURGERY",1:" "_$P(DGN,U,4))
;
N1() ; -- number of admissions
N X,Y S (X,Y)=0 F S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y S X=X+1
Q "#"_X
ADGCRB1 ; IHS/ADC/PDW/ENM - A SHEET lines 1&2 ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
A ; -- driver
+1 DO INI
DO HDH
DO H1
DO L1
DO H2
DO L2
DO ^ADGCRB2
DO ^ADGCRB3
DO ^ADGCRB4
QUIT
+2 ;
INI ; -- initialize variables
+1 SET (DGLIN,DGLIN1)=""
SET $PIECE(DGLIN,"=",80)=""
SET $PIECE(DGLIN1,"-",80)=""
+2 SET DGN=$SELECT(DGDS:^ADGDS(DFN,"DS",+DGDS,0),1:^DGPM(DGFN,0))
+3 SET DGN0=^DPT(DFN,0)
SET DGN11=$GET(^AUPNPAT(DFN,11))
QUIT
+4 ;
HDH ; -- print heading
+1 WRITE $SELECT(DGDS:"DAY SURGERY WORKSHEET",1:"CLINICAL RECORD BRIEF")
+2 WRITE " **Confidential Patient Data Covered by Privacy Act** "
+3 IF 'DGDS
WRITE $$N1
WRITE !,DGLIN
QUIT
+4 ;
H1 ; -- sub heading 1
+1 WRITE !,"1 IHS Unit No.",?16,"2 Soc Sec No",?30,"10 Classif."
+2 WRITE ?44,"11 Facility",?60,"12 Facility Code",!
QUIT
+3 ;
L1 ; -- data line 1
+1 WRITE ?3,$$HRCN^ADGF,?17,$$SSN,?33,$$CLS,?47,$$FACN,?63,$$FACC
QUIT
+2 ;
H2 ; -- sub heading 2
+1 WRITE !,DGLIN1,!,"3 Last Name, First, Middle",?29,"13 Age"
+2 IF DGDS
WRITE ?37,"14 Religion",?53,"15 Hr Arrvd",?66,"16 Visit Type",!
QUIT
+3 WRITE ?37,"14 Religion",?53,"15 Hr Admit",?66,"16 Admit Code",!
QUIT
+4 ;
L2 ; -- data line 2
+1 WRITE ?2,$PIECE(DGN0,U),?32,$$AGE,?40,$$REL,?58,$$TIM,?69,$$CDE
QUIT
+2 ;
SSN() ; -- social security number
+1 IF $PIECE(DGN0,U,9)=""
QUIT "UNKNOWN"
+2 QUIT $EXTRACT($PIECE(DGN0,U,9),1,3)_"-"_$EXTRACT($PIECE(DGN0,U,9),4,5)_"-"_$EXTRACT($PIECE(DGN0,U,9),6,9)
+3 ;
CLS() ; -- classification/beneficiary & classif code
+1 QUIT $EXTRACT($PIECE($GET(^AUTTBEN(+$PIECE(DGN11,U,11),0)),U),1,3)_"-"_$PIECE($GET(^(0)),U,2)
+2 ;
FACN() ; -- facility
+1 QUIT $PIECE($GET(^AUTTLOC(+DUZ(2),0)),U,2)
+2 ;
FACC() ; -- facility code
+1 NEW X
IF '$DATA(DUZ(2))!('$DATA(^AUTTLOC(DUZ(2),0)))
QUIT "UNKNOWN"
+2 SET X=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
QUIT $EXTRACT(X,1,2)_"-"_$EXTRACT(X,3,4)_"-"_$EXTRACT(X,5,6)
+3 ;
AGE() ; -- age
+1 NEW X
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),DIC,DR,DA
QUIT X
+3 ;
REL() ; -- religion
+1 QUIT $EXTRACT($PIECE($GET(^DIC(13,+$PIECE(DGN0,U,8),0)),U),1,12)
+2 ;
TIM() ; -- admit time
+1 QUIT $EXTRACT(($PIECE(+DGN,".",2)_"000"),1,4)
+2 ;
CDE() ; -- admission code
+1 QUIT $SELECT(DGDS:"DAY SURGERY",1:" "_$PIECE(DGN,U,4))
+2 ;
N1() ; -- number of admissions
+1 NEW X,Y
SET (X,Y)=0
FOR
SET Y=$ORDER(^DGPM("APTT1",DFN,Y))
IF 'Y
QUIT
SET X=X+1
+2 QUIT "#"_X
