- ADGPCAC1 ; IHS/ADC/PDW/ENM - ADT/PCC DATA ENTRY ; [ 03/25/1999 11:48 AM ]
- ;;5.3;ADMISSION/DISCHARGE/TRANSFER;**1008**;MAR 25, 1999
- ;
- ;cmi/anch/maw 12/7/2007 patch 1008 add code set versioning ADX
- ;
- A ; -- main
- D 1,Q Q:$D(DIRUT)
- D ^ADGPCAC2 Q
- ;
- 1 ; -- admission
- N IFN,N,DN0,VN0
- S IFN=$O(^AUPNVINP("AD",DGVI,0)),N=$G(^AUPNVINP(IFN,0))
- S DN0=^DPT(DFN,0) S VN0=^AUPNVSIT(DGVI,0),APCDDATE=+VN0
- W @IOF,!," NAME: ",$E($P(DN0,U),1,25)
- W ?35,"HRCN: ",$$HRCN^ADGF,?58,"SSN: ",$P(DN0,U,9)
- W !?36,"DOB: ",$$DOB,?52,"COMMUNITY: ",$$COM
- ; -- section 1 data
- W !!," (1) Admission Date: ",$$ADT,!?7,"Discharge Date: ",$$DDT
- W !?4,"Admitting Service: ",$$ATS,?45,"Disch Service: ",$$DTS
- W !?7,"Admission Type: ",$$ATY,?44,"Discharge Type: ",$$DTY
- W !?6,"No. of Consults: ",$P(N,U,8),?27,"Adm Dx: ",$$ADX
- W:+$P(N,U,9) ?44,"Transferred To: ",$$TFC
- Q
- ;
- Q ; -- cleanup
- K DIR W ! S DIR(0)="E" D ^DIR K DIR,X W @IOF Q
- ;
- DOB() ; -- date of birth
- N X S X=$P(DN0,U,3) Q:'X "" Q $E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
- ;
- COM() ; -- community
- Q $E($P($G(^AUPNPAT(+DFN,11)),U,18),1,15)
- ;
- ADT() ; -- admission date
- N Y S Y=+VN0 X ^DD("DD") Q Y
- ;
- DDT() ; -- discharge date
- N Y S Y=+N X ^DD("DD") Q Y
- ;
- ATS() ; -- admitting service
- Q $P($G(^DIC(45.7,+$P(N,U,4),0)),U)
- ;
- DTS() ; -- discharge service
- Q $P($G(^DIC(45.7,+$P(N,U,5),0)),U)
- ;
- TFC() ; -- transfer facility
- N Y,C S Y=$P(N,U,9),C=$P(^DD(9000010.02,.09,0),U,2) D Y^DIQ Q Y
- ;
- ADX() ; -- admitting dx
- ;Q $P($G(^ICD9(+$P(N,U,12),0)),U)_" "_$P($G(^(0)),U,3)
- Q $P($$ICDDX^ICDCODE(+$P(N,U,12)),U,2)_" "_$P($$ICDDX^ICDCODE(+$P(N,U,12)),U,4)
- ;
- ATY() ; -- admitting type
- N Y,C S Y=$P(N,U,7),C=$P(^DD(9000010.02,.07,0),U,2) D Y^DIQ Q Y
- ;
- DTY() ; -- discharge type
- N Y,C S Y=$P(N,U,6),C=$P(^DD(9000010.02,.06,0),U,2) D Y^DIQ Q Y
- ADGPCAC1 ; IHS/ADC/PDW/ENM - ADT/PCC DATA ENTRY ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.3;ADMISSION/DISCHARGE/TRANSFER;**1008**;MAR 25, 1999
- +2 ;
- +3 ;cmi/anch/maw 12/7/2007 patch 1008 add code set versioning ADX
- +4 ;
- A ; -- main
- +1 DO 1
- DO Q
- IF $DATA(DIRUT)
- QUIT
- +2 DO ^ADGPCAC2
- QUIT
- +3 ;
- 1 ; -- admission
- +1 NEW IFN,N,DN0,VN0
- +2 SET IFN=$ORDER(^AUPNVINP("AD",DGVI,0))
- SET N=$GET(^AUPNVINP(IFN,0))
- +3 SET DN0=^DPT(DFN,0)
- SET VN0=^AUPNVSIT(DGVI,0)
- SET APCDDATE=+VN0
- +4 WRITE @IOF,!," NAME: ",$EXTRACT($PIECE(DN0,U),1,25)
- +5 WRITE ?35,"HRCN: ",$$HRCN^ADGF,?58,"SSN: ",$PIECE(DN0,U,9)
- +6 WRITE !?36,"DOB: ",$$DOB,?52,"COMMUNITY: ",$$COM
- +7 ; -- section 1 data
- +8 WRITE !!," (1) Admission Date: ",$$ADT,!?7,"Discharge Date: ",$$DDT
- +9 WRITE !?4,"Admitting Service: ",$$ATS,?45,"Disch Service: ",$$DTS
- +10 WRITE !?7,"Admission Type: ",$$ATY,?44,"Discharge Type: ",$$DTY
- +11 WRITE !?6,"No. of Consults: ",$PIECE(N,U,8),?27,"Adm Dx: ",$$ADX
- +12 IF +$PIECE(N,U,9)
- WRITE ?44,"Transferred To: ",$$TFC
- +13 QUIT
- +14 ;
- Q ; -- cleanup
- +1 KILL DIR
- WRITE !
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR,X
- WRITE @IOF
- QUIT
- +2 ;
- DOB() ; -- date of birth
- +1 NEW X
- SET X=$PIECE(DN0,U,3)
- IF 'X
- QUIT ""
- QUIT $EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
- +2 ;
- COM() ; -- community
- +1 QUIT $EXTRACT($PIECE($GET(^AUPNPAT(+DFN,11)),U,18),1,15)
- +2 ;
- ADT() ; -- admission date
- +1 NEW Y
- SET Y=+VN0
- XECUTE ^DD("DD")
- QUIT Y
- +2 ;
- DDT() ; -- discharge date
- +1 NEW Y
- SET Y=+N
- XECUTE ^DD("DD")
- QUIT Y
- +2 ;
- ATS() ; -- admitting service
- +1 QUIT $PIECE($GET(^DIC(45.7,+$PIECE(N,U,4),0)),U)
- +2 ;
- DTS() ; -- discharge service
- +1 QUIT $PIECE($GET(^DIC(45.7,+$PIECE(N,U,5),0)),U)
- +2 ;
- TFC() ; -- transfer facility
- +1 NEW Y,C
- SET Y=$PIECE(N,U,9)
- SET C=$PIECE(^DD(9000010.02,.09,0),U,2)
- DO Y^DIQ
- QUIT Y
- +2 ;
- ADX() ; -- admitting dx
- +1 ;Q $P($G(^ICD9(+$P(N,U,12),0)),U)_" "_$P($G(^(0)),U,3)
- +2 QUIT $PIECE($$ICDDX^ICDCODE(+$PIECE(N,U,12)),U,2)_" "_$PIECE($$ICDDX^ICDCODE(+$PIECE(N,U,12)),U,4)
- +3 ;
- ATY() ; -- admitting type
- +1 NEW Y,C
- SET Y=$PIECE(N,U,7)
- SET C=$PIECE(^DD(9000010.02,.07,0),U,2)
- DO Y^DIQ
- QUIT Y
- +2 ;
- DTY() ; -- discharge type
- +1 NEW Y,C
- SET Y=$PIECE(N,U,6)
- SET C=$PIECE(^DD(9000010.02,.06,0),U,2)
- DO Y^DIQ
- QUIT Y
