Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCPAH

APCPAH.m

Go to the documentation of this file.
  1. 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
  1. I APCPV("CHART")=999999 S APCPE("ERROR")="E603" D COUNT^APCPDR2 Q
  1. I APCPV("LOC DFN")'=DUZ(2) S APCPE("ERROR")="E335" D COUNT^APCPDR2,EOJ Q
  1. D ^APCPDRPP
  1. I $D(APCPE) D COUNT^APCPDR2,EOJ Q
  1. D ^APCPHOSP
  1. I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
  1. D SETVARS
  1. I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
  1. D ^APCPHPRV
  1. I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
  1. D ^APCPHPOV
  1. I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
  1. D ^APCPHOP
  1. I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q
  1. D ^APCPHTX
  1. EOJ ;
  1. K I
  1. K APCPHDX1,APCPHDX2,APCPHDX3,APCPHDX4,APCPHDX5,APCPHDX6,APCPHHA1,APCPHHA2,APCPHHA3,APCPHHA4,APCPHHA5,APCPHHA6,APCPODX1,APCPODX2,APCPODX3,APCPOIN1,APCPOIN2,APCPOIN3,APCPHOP1,APCPHOP2,APCPHOP3,APCPH,APCPT
  1. Q
  1. SETVARS ; set standard variables for record
  1. S APCPH("ADM DATE")=$E(APCPV("V DATE"),4,5)_$E(APCPV("V DATE"),6,7)_$E(APCPV("V DATE"),2,3)
  1. S APCPH("DIS DATE")=$E(APCPV("DISCHARGE DATE"),4,5)_$E(APCPV("DISCHARGE DATE"),6,7)_$E(APCPV("DISCHARGE DATE"),2,3)
  1. S APCPH("SSN")=$P(^DPT(AUPNPAT,0),U,9)
  1. S APCPH("DOB")=$E(AUPNDOB,4,5)_$E(AUPNDOB,6,7)_$E(AUPNDOB,2,3)
  1. S APCPH("SEX")=$S(AUPNSEX="F":2,AUPNSEX="M":1,1:"")
  1. BEN ;
  1. S X=$P(^AUPNPAT(AUPNPAT,11),U,11) I X="" S APCPE("ERROR")="E613" Q
  1. I '$D(^AUTTBEN(X,0)) S APCPE("ERROR")="E614" Q
  1. S APCPH("BEN")=$P(^AUTTBEN(X,0),U,2)
  1. ADMTYPE ; Admission Type-CP 51
  1. S X=$P(^AUPNVINP(APCPH("VINP PTR"),0),U,7) I X="" S APCPE("ERROR")="E031" Q
  1. I $P(^DD(9000010.02,.07,0),U,2)[42.1 S APCPH("ADM TYPE")=$$VAL^XBDIQ1(42.1,X,9999999.01)
  1. I $P(^DD(9000010.02,.07,0),U,2)[405.1 S APCPH("ADM TYPE")=$$VAL^XBDIQ1(405.1,X,9999999.1)
  1. I APCPH("ADM TYPE")="" S APCPE("ERROR")="E031" Q
  1. DISP ; Disposition Type-CP 60
  1. S X=$P(^AUPNVINP(APCPH("VINP PTR"),0),U,6) I X="" S APCPE("ERROR")="E034" Q
  1. I $P(^DD(9000010.02,.06,0),U,2)[42.2 S APCPH("DISP")=$$VAL^XBDIQ1(42.2,X,9999999.01)
  1. I $P(^DD(9000010.02,.06,0),U,2)[405.1 S APCPH("DISP")=$$VAL^XBDIQ1(405.1,X,9999999.1)
  1. I $L(APCPH("DISP"))'=1 S APCPE("ERROR")="E037" Q
  1. ;
  1. CONSULTS ;
  1. S APCPH("CON")=$P(^AUPNVINP(APCPH("VINP PTR"),0),U,8) I APCPH("CON")="" S APCPH("CON")="00" G DAY
  1. S:$L(APCPH("CON"))=1 APCPH("CON")=0_APCPH("CON")
  1. DAY S APCPH("DAYS")=""
  1. S X1=APCPV("DISCHARGE DATE"),X2=APCPV("V DATE") D ^%DTC S APCPH("DAYS")=X S:APCPH("DAYS")=0 APCPH("DAYS")=1
  1. UCAUS ;
  1. ;CHANGED APCPH(ICD TO APCPT(ICD BELOW PATCH APCP*1.51*1
  1. I APCPH("DISP")<4 S APCPH("CAUSE")=" " Q
  1. I '$D(^AUPNPAT(AUPNPAT,11)) S APCPE("ERROR")="E602" Q
  1. S APCPT("ICD PTR")=$P(^AUPNPAT(AUPNPAT,11),U,14) I APCPT("ICD PTR")="" S APCPE("ERROR")="E030" Q
  1. S APCPH("LC")="",APCPT("ICD")=$P(^ICD9(APCPT("ICD PTR"),0),U)
  1. I $E(APCPT("ICD"))="." S APCPT("ICD")=$E(APCPT("ICD"),2,99)
  1. D ^APCPCICD
  1. Q:$D(APCPE("ERROR"))
  1. 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")_" "
  1. S APCPH("CAUSE")=APCPT("ICD")
  1. Q