ADGPM1 ; IHS/ADC/PDW/ENM - VIEW ADMISSION HISTORY ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
W @IOF W !!?20,"VIEW A PATIENT'S ADMISSION HISTORY",!!
A ; -- main
D SP I Y<0 D Q Q
D HD1,CS,HD2,L1,Q Q
;
SP ; -- patient
S DIC="^DPT(",DIC(0)="AZQEM" D ^DIC I Y<0 Q
S DFN=+Y,DGDPTN0=Y(0) Q
;
HD1 ; -- heading 1
W @IOF,?11,"*****Confidential Patient Data Covered by Privacy Act*****"
W !,$P(DGDPTN0,U),?32,"DOB: ",$$DOB
W ?50,"Age: ",$$AGE,?60,"CHART #: ",$$HRCN^ADGF
S X="CURRENT STATUS" W !!?80-$L(X)/2,X S X="",$P(X,"=",80)="" W !,X
Q
;
HD2 ; -- heading 2
S X="ADMISSION HISTORY" W !!?80-$L(X)/2,X,! S X="",$P(X,"=",80)="" W X
W !!?8,"Admit Date",?25,"Ward",?32,"Service",?43,"Rm/Bed"
W ?51,"Discharge",?66,"Provider"
W !?3,"-----------------",?24,"------",?31,"---------",?43,"------"
W ?51,"-----------",?64,"--------------" Q
;
CS ; -- current status
D INP^DGRPD Q
;
L1 ; -- loop admissions
S DGDT=0 N X S X=0
F S DGDT=$O(^DGPM("APTT1",DFN,DGDT)) Q:'DGDT D
. S DGPMDA=0
. F S DGPMDA=$O(^DGPM("APTT1",DFN,DGDT,DGPMDA)) Q:'DGPMDA D
.. D PRNT
W ! Q
;
PRNT ; -- print admission data
Q:'$D(^DGPM(DGPMDA,0)) S DGPMN0=^(0),X=X+1
W !,"(",X,") ",$$ADT,?24,$$WD,?31,$$TS,?44,$$RM
W ?52,$$DS,?65,$$PR Q
;
Q ; -- cleanup
D PRTOPT^ADGVAR
K DGPMDA,DGPMN0,DFN,DGDPTN0,DGDT,DIC,X,Y,DA,DR,E Q
;
WD() ; -- ward
Q $E($P($G(^DIC(42,+$P(DGPMN0,U,6),0)),U),1,6)
;
RM() ; -- room
Q $P($G(^DG(405.4,+$P(DGPMN0,U,7),0)),U)
;
TS() ; -- treating specialty
N X S X=$O(^DGPM("APHY",DGPMDA,0)) Q:'X ""
S X=$P(^DGPM(X,0),U,9) Q:'X "" Q $E($P(^DIC(45.7,X,0),U),1,9)
;
PR() ; -- provider
N X S X=$O(^DGPM("APHY",DGPMDA,0)) Q:'X ""
S X=$P(^DGPM(X,0),U,8) Q:'X ""
Q $E($P($P($G(^VA(200,+X,0)),U),",",1),1,13)
;
DS() ; -- discharge
N X S X=$P(DGPMN0,U,17) Q:'X "" S X=+^DGPM(X,0) Q:'X ""
Q $E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
;
DOB() ; -- date of birth
N Y S Y=$P(DGDPTN0,U,3) Q:'Y "" X ^DD("DD") Q Y
;
ADT() ; -- admission date
N X S X=+DGPMN0 Q:'X ""
S Y=$P(X,".",2)_"000",Y=$E(Y,1,2)_":"_$E(Y,3,4)
Q $E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)_" ("_Y_")"
;
AGE() ; -- age
N X K ^UTILITY("DIQ1",$J) S DIC=2,DR=.033,DA=DFN D EN^DIQ1
S X=^UTILITY("DIQ1",$J,2,DFN,.033) K ^UTILITY("DIQ1",$J) Q X
ADGPM1 ; IHS/ADC/PDW/ENM - VIEW ADMISSION HISTORY ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 WRITE @IOF
WRITE !!?20,"VIEW A PATIENT'S ADMISSION HISTORY",!!
A ; -- main
+1 DO SP
IF Y<0
DO Q
QUIT
+2 DO HD1
DO CS
DO HD2
DO L1
DO Q
QUIT
+3 ;
SP ; -- patient
+1 SET DIC="^DPT("
SET DIC(0)="AZQEM"
DO ^DIC
IF Y<0
QUIT
+2 SET DFN=+Y
SET DGDPTN0=Y(0)
QUIT
+3 ;
HD1 ; -- heading 1
+1 WRITE @IOF,?11,"*****Confidential Patient Data Covered by Privacy Act*****"
+2 WRITE !,$PIECE(DGDPTN0,U),?32,"DOB: ",$$DOB
+3 WRITE ?50,"Age: ",$$AGE,?60,"CHART #: ",$$HRCN^ADGF
+4 SET X="CURRENT STATUS"
WRITE !!?80-$LENGTH(X)/2,X
SET X=""
SET $PIECE(X,"=",80)=""
WRITE !,X
+5 QUIT
+6 ;
HD2 ; -- heading 2
+1 SET X="ADMISSION HISTORY"
WRITE !!?80-$LENGTH(X)/2,X,!
SET X=""
SET $PIECE(X,"=",80)=""
WRITE X
+2 WRITE !!?8,"Admit Date",?25,"Ward",?32,"Service",?43,"Rm/Bed"
+3 WRITE ?51,"Discharge",?66,"Provider"
+4 WRITE !?3,"-----------------",?24,"------",?31,"---------",?43,"------"
+5 WRITE ?51,"-----------",?64,"--------------"
QUIT
+6 ;
CS ; -- current status
+1 DO INP^DGRPD
QUIT
+2 ;
L1 ; -- loop admissions
+1 SET DGDT=0
NEW X
SET X=0
+2 FOR
SET DGDT=$ORDER(^DGPM("APTT1",DFN,DGDT))
IF 'DGDT
QUIT
Begin DoDot:1
+3 SET DGPMDA=0
+4 FOR
SET DGPMDA=$ORDER(^DGPM("APTT1",DFN,DGDT,DGPMDA))
IF 'DGPMDA
QUIT
Begin DoDot:2
+5 DO PRNT
End DoDot:2
End DoDot:1
+6 WRITE !
QUIT
+7 ;
PRNT ; -- print admission data
+1 IF '$DATA(^DGPM(DGPMDA,0))
QUIT
SET DGPMN0=^(0)
SET X=X+1
+2 WRITE !,"(",X,") ",$$ADT,?24,$$WD,?31,$$TS,?44,$$RM
+3 WRITE ?52,$$DS,?65,$$PR
QUIT
+4 ;
Q ; -- cleanup
+1 DO PRTOPT^ADGVAR
+2 KILL DGPMDA,DGPMN0,DFN,DGDPTN0,DGDT,DIC,X,Y,DA,DR,E
QUIT
+3 ;
WD() ; -- ward
+1 QUIT $EXTRACT($PIECE($GET(^DIC(42,+$PIECE(DGPMN0,U,6),0)),U),1,6)
+2 ;
RM() ; -- room
+1 QUIT $PIECE($GET(^DG(405.4,+$PIECE(DGPMN0,U,7),0)),U)
+2 ;
TS() ; -- treating specialty
+1 NEW X
SET X=$ORDER(^DGPM("APHY",DGPMDA,0))
IF 'X
QUIT ""
+2 SET X=$PIECE(^DGPM(X,0),U,9)
IF 'X
QUIT ""
QUIT $EXTRACT($PIECE(^DIC(45.7,X,0),U),1,9)
+3 ;
PR() ; -- provider
+1 NEW X
SET X=$ORDER(^DGPM("APHY",DGPMDA,0))
IF 'X
QUIT ""
+2 SET X=$PIECE(^DGPM(X,0),U,8)
IF 'X
QUIT ""
+3 QUIT $EXTRACT($PIECE($PIECE($GET(^VA(200,+X,0)),U),",",1),1,13)
+4 ;
DS() ; -- discharge
+1 NEW X
SET X=$PIECE(DGPMN0,U,17)
IF 'X
QUIT ""
SET X=+^DGPM(X,0)
IF 'X
QUIT ""
+2 QUIT $EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
+3 ;
DOB() ; -- date of birth
+1 NEW Y
SET Y=$PIECE(DGDPTN0,U,3)
IF 'Y
QUIT ""
XECUTE ^DD("DD")
QUIT Y
+2 ;
ADT() ; -- admission date
+1 NEW X
SET X=+DGPMN0
IF 'X
QUIT ""
+2 SET Y=$PIECE(X,".",2)_"000"
SET Y=$EXTRACT(Y,1,2)_":"_$EXTRACT(Y,3,4)
+3 QUIT $EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)_" ("_Y_")"
+4 ;
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,DFN,.033)
KILL ^UTILITY("DIQ1",$JOB)
QUIT X
