- APCPAH ; IHS/TUCSON/LAB - create INPATIENT SYSTEM record AUGUST 14, 1992 ; [ 04/04/02 8:35 PM ]
- ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**6**;APR 03, 1998
- I APCPV("CHART")=999999 S APCPE("ERROR")="E603" D COUNT^APCPDR2 Q
- I APCPV("LOC DFN")'=DUZ(2) S APCPE("ERROR")="E335" D COUNT^APCPDR2,EOJ Q
- D ^APCPDRPP
- I $D(APCPE) D COUNT^APCPDR2,EOJ Q
- D ^APCPHOSP
- I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
- D SETVARS
- I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
- D ^APCPHPRV
- I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
- D ^APCPHPOV
- I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
- D ^APCPHOP
- I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
- D ^APCPHTX
- EOJ ;
- K I
- K APCPHDX1,APCPHDX2,APCPHDX3,APCPHDX4,APCPHDX5,APCPHDX6,APCPHHA1,APCPHHA2,APCPHHA3,APCPHHA4,APCPHHA5,APCPHHA6,APCPODX1,APCPODX2,APCPODX3,APCPOIN1,APCPOIN2,APCPOIN3,APCPHOP1,APCPHOP2,APCPHOP3,APCPH,APCPT
- Q
- SETVARS ; set standard variables for record
- S APCPH("ADM DATE")=$E(APCPV("V DATE"),4,5)_$E(APCPV("V DATE"),6,7)_$E(APCPV("V DATE"),2,3)
- S APCPH("DIS DATE")=$E(APCPV("DISCHARGE DATE"),4,5)_$E(APCPV("DISCHARGE DATE"),6,7)_$E(APCPV("DISCHARGE DATE"),2,3)
- S APCPH("SSN")=$P(^DPT(AUPNPAT,0),U,9)
- S APCPH("DOB")=$E(AUPNDOB,4,5)_$E(AUPNDOB,6,7)_$E(AUPNDOB,2,3)
- S APCPH("SEX")=$S(AUPNSEX="F":2,AUPNSEX="M":1,1:"")
- BEN ;
- S X=$P(^AUPNPAT(AUPNPAT,11),U,11) I X="" S APCPE("ERROR")="E613" Q
- I '$D(^AUTTBEN(X,0)) S APCPE("ERROR")="E614" Q
- S APCPH("BEN")=$P(^AUTTBEN(X,0),U,2)
- ADMTYPE ; Admission Type-CP 51
- S X=$P(^AUPNVINP(APCPH("VINP PTR"),0),U,7) I X="" S APCPE("ERROR")="E031" Q
- I $P(^DD(9000010.02,.07,0),U,2)[42.1 S APCPH("ADM TYPE")=$$VAL^XBDIQ1(42.1,X,9999999.01)
- I $P(^DD(9000010.02,.07,0),U,2)[405.1 S APCPH("ADM TYPE")=$$VAL^XBDIQ1(405.1,X,9999999.1)
- I APCPH("ADM TYPE")="" S APCPE("ERROR")="E031" Q
- DISP ; Disposition Type-CP 60
- S X=$P(^AUPNVINP(APCPH("VINP PTR"),0),U,6) I X="" S APCPE("ERROR")="E034" Q
- I $P(^DD(9000010.02,.06,0),U,2)[42.2 S APCPH("DISP")=$$VAL^XBDIQ1(42.2,X,9999999.01)
- I $P(^DD(9000010.02,.06,0),U,2)[405.1 S APCPH("DISP")=$$VAL^XBDIQ1(405.1,X,9999999.1)
- I $L(APCPH("DISP"))'=1 S APCPE("ERROR")="E037" Q
- ;
- CONSULTS ;
- S APCPH("CON")=$P(^AUPNVINP(APCPH("VINP PTR"),0),U,8) I APCPH("CON")="" S APCPH("CON")="00" G DAY
- S:$L(APCPH("CON"))=1 APCPH("CON")=0_APCPH("CON")
- DAY S APCPH("DAYS")=""
- S X1=APCPV("DISCHARGE DATE"),X2=APCPV("V DATE") D ^%DTC S APCPH("DAYS")=X S:APCPH("DAYS")=0 APCPH("DAYS")=1
- UCAUS ;
- ;CHANGED APCPH(ICD TO APCPT(ICD BELOW PATCH APCP*1.51*1
- I APCPH("DISP")<4 S APCPH("CAUSE")=" " Q
- I '$D(^AUPNPAT(AUPNPAT,11)) S APCPE("ERROR")="E602" Q
- S APCPT("ICD PTR")=$P(^AUPNPAT(AUPNPAT,11),U,14) I APCPT("ICD PTR")="" S APCPE("ERROR")="E030" Q
- S APCPH("LC")="",APCPT("ICD")=$P(^ICD9(APCPT("ICD PTR"),0),U)
- I $E(APCPT("ICD"))="." S APCPT("ICD")=$E(APCPT("ICD"),2,99)
- D ^APCPCICD
- Q:$D(APCPE("ERROR"))
- S APCPT("ICD")=$P(APCPT("ICD"),".")_$P(APCPT("ICD"),".",2),APCPH("L")=$L(APCPT("ICD"))+1 F I=APCPH("L"):1:5 S APCPT("ICD")=APCPT("ICD")_" "
- S APCPH("CAUSE")=APCPT("ICD")
- Q
- APCPAH ; IHS/TUCSON/LAB - create INPATIENT SYSTEM record AUGUST 14, 1992 ; [ 04/04/02 8:35 PM ]
- +1 ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**6**;APR 03, 1998
- +2 IF APCPV("CHART")=999999
- SET APCPE("ERROR")="E603"
- DO COUNT^APCPDR2
- QUIT
- +3 IF APCPV("LOC DFN")'=DUZ(2)
- SET APCPE("ERROR")="E335"
- DO COUNT^APCPDR2
- DO EOJ
- QUIT
- +4 DO ^APCPDRPP
- +5 IF $DATA(APCPE)
- DO COUNT^APCPDR2
- DO EOJ
- QUIT
- +6 DO ^APCPHOSP
- +7 IF $DATA(APCPE("ERROR"))
- DO COUNT^APCPDR2
- DO EOJ
- QUIT
- +8 DO SETVARS
- +9 IF $DATA(APCPE("ERROR"))
- DO COUNT^APCPDR2
- DO EOJ
- QUIT
- +10 DO ^APCPHPRV
- +11 IF $DATA(APCPE("ERROR"))
- DO COUNT^APCPDR2
- DO EOJ
- QUIT
- +12 DO ^APCPHPOV
- +13 IF $DATA(APCPE("ERROR"))
- DO COUNT^APCPDR2
- DO EOJ
- QUIT
- +14 DO ^APCPHOP
- +15 IF $DATA(APCPE("ERROR"))
- DO COUNT^APCPDR2
- DO EOJ
- QUIT
- +16 DO ^APCPHTX
- EOJ ;
- +1 KILL I
- +2 KILL APCPHDX1,APCPHDX2,APCPHDX3,APCPHDX4,APCPHDX5,APCPHDX6,APCPHHA1,APCPHHA2,APCPHHA3,APCPHHA4,APCPHHA5,APCPHHA6,APCPODX1,APCPODX2,APCPODX3,APCPOIN1,APCPOIN2,APCPOIN3,APCPHOP1,APCPHOP2,APCPHOP3,APCPH,APCPT
- +3 QUIT
- SETVARS ; set standard variables for record
- +1 SET APCPH("ADM DATE")=$EXTRACT(APCPV("V DATE"),4,5)_$EXTRACT(APCPV("V DATE"),6,7)_$EXTRACT(APCPV("V DATE"),2,3)
- +2 SET APCPH("DIS DATE")=$EXTRACT(APCPV("DISCHARGE DATE"),4,5)_$EXTRACT(APCPV("DISCHARGE DATE"),6,7)_$EXTRACT(APCPV("DISCHARGE DATE"),2,3)
- +3 SET APCPH("SSN")=$PIECE(^DPT(AUPNPAT,0),U,9)
- +4 SET APCPH("DOB")=$EXTRACT(AUPNDOB,4,5)_$EXTRACT(AUPNDOB,6,7)_$EXTRACT(AUPNDOB,2,3)
- +5 SET APCPH("SEX")=$SELECT(AUPNSEX="F":2,AUPNSEX="M":1,1:"")
- BEN ;
- +1 SET X=$PIECE(^AUPNPAT(AUPNPAT,11),U,11)
- IF X=""
- SET APCPE("ERROR")="E613"
- QUIT
- +2 IF '$DATA(^AUTTBEN(X,0))
- SET APCPE("ERROR")="E614"
- QUIT
- +3 SET APCPH("BEN")=$PIECE(^AUTTBEN(X,0),U,2)
- ADMTYPE ; Admission Type-CP 51
- +1 SET X=$PIECE(^AUPNVINP(APCPH("VINP PTR"),0),U,7)
- IF X=""
- SET APCPE("ERROR")="E031"
- QUIT
- +2 IF $PIECE(^DD(9000010.02,.07,0),U,2)[42.1
- SET APCPH("ADM TYPE")=$$VAL^XBDIQ1(42.1,X,9999999.01)
- +3 IF $PIECE(^DD(9000010.02,.07,0),U,2)[405.1
- SET APCPH("ADM TYPE")=$$VAL^XBDIQ1(405.1,X,9999999.1)
- +4 IF APCPH("ADM TYPE")=""
- SET APCPE("ERROR")="E031"
- QUIT
- DISP ; Disposition Type-CP 60
- +1 SET X=$PIECE(^AUPNVINP(APCPH("VINP PTR"),0),U,6)
- IF X=""
- SET APCPE("ERROR")="E034"
- QUIT
- +2 IF $PIECE(^DD(9000010.02,.06,0),U,2)[42.2
- SET APCPH("DISP")=$$VAL^XBDIQ1(42.2,X,9999999.01)
- +3 IF $PIECE(^DD(9000010.02,.06,0),U,2)[405.1
- SET APCPH("DISP")=$$VAL^XBDIQ1(405.1,X,9999999.1)
- +4 IF $LENGTH(APCPH("DISP"))'=1
- SET APCPE("ERROR")="E037"
- QUIT
- +5 ;
- CONSULTS ;
- +1 SET APCPH("CON")=$PIECE(^AUPNVINP(APCPH("VINP PTR"),0),U,8)
- IF APCPH("CON")=""
- SET APCPH("CON")="00"
- GOTO DAY
- +2 IF $LENGTH(APCPH("CON"))=1
- SET APCPH("CON")=0_APCPH("CON")
- DAY SET APCPH("DAYS")=""
- +1 SET X1=APCPV("DISCHARGE DATE")
- SET X2=APCPV("V DATE")
- DO ^%DTC
- SET APCPH("DAYS")=X
- IF APCPH("DAYS")=0
- SET APCPH("DAYS")=1
- UCAUS ;
- +1 ;CHANGED APCPH(ICD TO APCPT(ICD BELOW PATCH APCP*1.51*1
- +2 IF APCPH("DISP")<4
- SET APCPH("CAUSE")=" "
- QUIT
- +3 IF '$DATA(^AUPNPAT(AUPNPAT,11))
- SET APCPE("ERROR")="E602"
- QUIT
- +4 SET APCPT("ICD PTR")=$PIECE(^AUPNPAT(AUPNPAT,11),U,14)
- IF APCPT("ICD PTR")=""
- SET APCPE("ERROR")="E030"
- QUIT
- +5 SET APCPH("LC")=""
- SET APCPT("ICD")=$PIECE(^ICD9(APCPT("ICD PTR"),0),U)
- +6 IF $EXTRACT(APCPT("ICD"))="."
- SET APCPT("ICD")=$EXTRACT(APCPT("ICD"),2,99)
- +7 DO ^APCPCICD
- +8 IF $DATA(APCPE("ERROR"))
- QUIT
- +9 SET APCPT("ICD")=$PIECE(APCPT("ICD"),".")_$PIECE(APCPT("ICD"),".",2)
- SET APCPH("L")=$LENGTH(APCPT("ICD"))+1
- FOR I=APCPH("L"):1:5
- SET APCPT("ICD")=APCPT("ICD")_" "
- +10 SET APCPH("CAUSE")=APCPT("ICD")
- +11 QUIT