- 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
