- APCDR02 ; IHS/CMI/LAB - V HOSPITALIZATION REVIEW ;
- ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
- S APCDEREC=^AUPNVINP(APCDEDFN,0)
- ADMTYPE ; Admission Type
- I $P(APCDEREC,U,7)="" S APCDE="E031" D ERR G DISP
- I $P(^DD(9000010.02,.07,0),U,2)[42.1 S X=$$VAL^XBDIQ1(42.1,$P(APCDEREC,U,7),9999999.01)
- I $P(^DD(9000010.02,.07,0),U,2)[405.1 S X=$$VAL^XBDIQ1(405.1,$P(APCDEREC,U,7),9999999.1)
- I X="" S APCDE="E031" D ERR
- DISP ; Disposition Type-CP 60
- S APCDDISP=""
- I $P(APCDEREC,U,6)="" S APCDE="E034" D ERR G UCAUS
- I $P(^DD(9000010.02,.06,0),U,2)[42.2 S APCDDISP=$$VAL^XBDIQ1(42.2,$P(APCDEREC,U,6),9999999.01)
- I $P(^DD(9000010.02,.06,0),U,2)[405.1 S APCDDISP=$$VAL^XBDIQ1(405.1,$P(APCDEREC,U,6),9999999.1)
- I $L(APCDDISP)'=1 S APCDE="E039" D ERR
- ;
- ;
- UCAUS ; Underlying cause of death-CP 76-80.
- I APCDDISP<4 G XIT
- I '$D(^AUPNPAT(AUPNPAT,11)) S APCDE="E602" D ERR G XIT
- S APCDICDP=$P(^AUPNPAT(AUPNPAT,11),U,14) I APCDICDP="" S APCDE="E030" D ERR G XIT
- S APCDICD=$$CODEC^ICDEX(80,APCDICDP)
- K APCDE,APCDAGEE
- D ^APCDRICD
- I $D(APCDE) D ERR
- ;
- ;
- XIT ; Clean up and exit
- K APCDDISP,APCDICDP,APCDICD,APCDAGEE,APCDEREC,APCDE
- Q
- ERR ;
- S APCDE("FILE")=9000010.02,APCDE("ENTRY")=APCDEDFN
- D ERR^APCDRV
- Q
- APCDR02 ; IHS/CMI/LAB - V HOSPITALIZATION REVIEW ;
- +1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
- +2 SET APCDEREC=^AUPNVINP(APCDEDFN,0)
- ADMTYPE ; Admission Type
- +1 IF $PIECE(APCDEREC,U,7)=""
- SET APCDE="E031"
- DO ERR
- GOTO DISP
- +2 IF $PIECE(^DD(9000010.02,.07,0),U,2)[42.1
- SET X=$$VAL^XBDIQ1(42.1,$PIECE(APCDEREC,U,7),9999999.01)
- +3 IF $PIECE(^DD(9000010.02,.07,0),U,2)[405.1
- SET X=$$VAL^XBDIQ1(405.1,$PIECE(APCDEREC,U,7),9999999.1)
- +4 IF X=""
- SET APCDE="E031"
- DO ERR
- DISP ; Disposition Type-CP 60
- +1 SET APCDDISP=""
- +2 IF $PIECE(APCDEREC,U,6)=""
- SET APCDE="E034"
- DO ERR
- GOTO UCAUS
- +3 IF $PIECE(^DD(9000010.02,.06,0),U,2)[42.2
- SET APCDDISP=$$VAL^XBDIQ1(42.2,$PIECE(APCDEREC,U,6),9999999.01)
- +4 IF $PIECE(^DD(9000010.02,.06,0),U,2)[405.1
- SET APCDDISP=$$VAL^XBDIQ1(405.1,$PIECE(APCDEREC,U,6),9999999.1)
- +5 IF $LENGTH(APCDDISP)'=1
- SET APCDE="E039"
- DO ERR
- +6 ;
- +7 ;
- UCAUS ; Underlying cause of death-CP 76-80.
- +1 IF APCDDISP<4
- GOTO XIT
- +2 IF '$DATA(^AUPNPAT(AUPNPAT,11))
- SET APCDE="E602"
- DO ERR
- GOTO XIT
- +3 SET APCDICDP=$PIECE(^AUPNPAT(AUPNPAT,11),U,14)
- IF APCDICDP=""
- SET APCDE="E030"
- DO ERR
- GOTO XIT
- +4 SET APCDICD=$$CODEC^ICDEX(80,APCDICDP)
- +5 KILL APCDE,APCDAGEE
- +6 DO ^APCDRICD
- +7 IF $DATA(APCDE)
- DO ERR
- +8 ;
- +9 ;
- XIT ; Clean up and exit
- +1 KILL APCDDISP,APCDICDP,APCDICD,APCDAGEE,APCDEREC,APCDE
- +2 QUIT
- ERR ;
- +1 SET APCDE("FILE")=9000010.02
- SET APCDE("ENTRY")=APCDEDFN
- +2 DO ERR^APCDRV
- +3 QUIT
