APCPAH.m

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