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

ABMDVSTH.m

Go to the documentation of this file. 
  1. ABMDVSTH ; IHS/ASDST/DMJ - PCC Visit Stuff - PART 5 (HOSPITALIZATION) CONTD ;  
  1.  ;;2.6;IHS Third Party Billing System;**2,4**;NOV 12, 2009
  1.  ; IHS/SD/SDR - v2.5 p10 - IM20022 - Use AOB/ROI multiples
  1.  ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to call ABMFEAPI
  1.  ; IHS/SD/SDR - abm*2.6*4 - HEAT15806 - admit date/time not showing due to ABMFEAPI quit; moved up or made conditional
  1.  ;
  1.  ;This is a continuation of ABMDVST4
  1.  Q   ;Not to be called from the top
  1. CPT(SUB,LVL) ;EP - rtn CPT code
  1.  K X,ABMSRC
  1.  N N,L
  1.  S:'$D(LVL) LVL="LOW"
  1.  S (L,N)=""
  1.  F  S N=$O(AUPNCPT(N)) Q:N=""  D  Q:$D(X)
  1.  .F  S L=$O(ABMCPTTB("HOS",SUB,L)) Q:L=""  D  Q:$D(X)
  1.  ..Q:(+AUPNCPT(N))'=ABMCPTTB("HOS",SUB,L)
  1.  ..S X=+AUPNCPT(N)
  1.  ..S ABMSRC=$P($P(AUPNCPT(N),U,4),".",2)_"|"_$P(AUPNCPT(N),U,5)_"|CPT"
  1.  I '$D(X) D
  1.  .S X=ABMCPTTB("HOS",SUB,LVL)
  1.  .S ABMSRC="02|"_$S($D(ABMDA):ABMDA,1:"DEF")_"|CPT"
  1.  Q X
  1.  ;
  1.  ; the following code to be executed when SERVCAT=I or D
  1. MIDDAY ;EP - The following is for the middle days of care
  1.  N ABMCOVD,ABMEDIT,QUIT
  1.  S X1=ABMCHVDT
  1.  S X2=ABMP("HDATE")
  1.  D ^%DTC
  1.  S ABMCOVD=X
  1.  I ABMCOVD<1 D  Q:$G(QUIT)
  1.  .I $D(ABMP("COVD",ABMCHVDT)) S QUIT=1 Q
  1.  .S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),27,"C",ABMCHVDT,""))
  1.  .I DA S ABMEDIT=1
  1.  E  I ABMCOVD>1 D MAKEDY
  1.  S ABMP("COVD",ABMCHVDT)=""
  1.  I ABMCHVDT>ABMP("HDATE") S ABMP("HDATE")=ABMCHVDT
  1.  Q:ABMCOVD>1
  1.  S ABMD=ABMCHVDT
  1. MIDDAY2 S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,",DIC(0)="LE"
  1.  S X=$$CPT("SUB")
  1.  ;Q:($P($G(^ABMDFEE(ABMP("FEE"),19,X,0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A
  1.  ;Q:($P($$ONE^ABMFEAPI(ABMP("FEE"),19,X,ABMP("VDT")),U)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 HEAT15806
  1.  I (($P($$ONE^ABMFEAPI(ABMP("FEE"),19,X,ABMP("VDT")),U)=0)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y")) Q  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 HEAT15806
  1.  ;S DIC("DR")=".03////1;.04////"_$P($G(^ABMDFEE(ABMP("FEE"),19,X,0)),U,2)  ;abm*2.6*2 3PMS10003A
  1.  S DIC("DR")=".03////1;.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),19,X,ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A
  1.  ;Next line set correspond diagnosis if only 1 POV
  1.  I $D(ABMP("CORRSDIAG")) S DIC("DR")=DIC("DR")_";.06////1"
  1.  S DIC("DR")=DIC("DR")_";.07////"_ABMD
  1.  S DIC("DR")=DIC("DR")_";.17////"_ABMSRC
  1.  I $G(ABMEDIT) D  Q
  1.  .S DIE=DIC
  1.  .S DR=DIC("DR")
  1.  .K DIC(0)
  1.  .D ^DIE
  1.  .K ABMI
  1.  K DD,DO D FILE^DICN
  1.  K ABMI
  1.  Q
  1.  ;
  1. MAKEDY ;Put in each day separately
  1.  F ABM=1:1:ABMCOVD D
  1.  .S X1=ABMP("HDATE")
  1.  .S X2=ABM
  1.  .D C^%DTC
  1.  .S ABMD=X
  1.  .Q:$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),27,"C",ABMD,""))
  1.  .D MIDDAY2
  1.  Q
  1.  ;
  1. DISCHRG ;EP - The following is for discharge care
  1.  N DISNOTCV,COVD
  1.  S Y=$P(ABML(ABMP("PRI"),ABMP("INS")),U,4,5)
  1.  S X1=$S($P(Y,U,2):$P(Y,U,2),1:ABMP("DDT"))
  1.  I X1<ABMP("DDT") S DISNOTCV=1
  1.  S X2=$S(+Y>ABMP("HDATE"):+Y,1:ABMP("HDATE"))
  1.  D ^%DTC
  1.  ;If discharge date not covered just do middle days if they exist
  1.  I $D(DISNOTCV) D  Q
  1.  .I X>0 D
  1.  ..S ABMCOVD=X
  1.  ..I ABMCOVD>1 D MAKEDY Q
  1.  ..S ABMD=ABMCHVDT
  1.  ..D MIDDAY2
  1.  E  I X>1 D
  1.  .S ABMCOVD=X-1
  1.  .I ABMCOVD>1 D MAKEDY Q
  1.  .S X1=ABMCHVDT
  1.  .S X2=-1
  1.  .D C^%DTC
  1.  .S ABMD=X
  1.  .D MIDDAY2
  1.  S ABMP("HDATE")=ABMCHVDT
  1.  S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",27,",DIC(0)="LE"
  1.  S X=$$CPT("DIS","LT ")
  1.  ;Q:($P($G(^ABMDFEE(ABMP("FEE"),19,X,0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A
  1.  ;Q:($P($$ONE^ABMFEAPI(ABMP("FEE"),19,X,ABMP("VDT")),U)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 HEAT15806
  1.  I (($P($$ONE^ABMFEAPI(ABMP("FEE"),19,X,ABMP("VDT")),U)=0)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y")) Q  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 HEAT15806
  1.  ;S DIC("DR")=".03////1;.04////"_$P($G(^ABMDFEE(ABMP("FEE"),19,X,0)),U,2)  ;abm*2.6*2 3PMS10003A
  1.  S DIC("DR")=".03////1;.04////"_$P($$ONE^ABMFEAPI(ABMP("FEE"),19,X,ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A
  1.  ;Next line set correspond diagnosis if only 1 POV
  1.  I $D(ABMP("CORRSDIAG")) S DIC("DR")=DIC("DR")_";.06////1"
  1.  S DIC("DR")=DIC("DR")_";.07////"_ABMCHVDT
  1.  S DIC("DR")=DIC("DR")_";.17///"_ABMSRC
  1.  K DD,DO D FILE^DICN
  1.  K ABMI
  1.  Q
  1.  ;
  1. REL ;EP - RELEASE OF INFORMATION
  1.  K DIE S DIE="^ABMDCLM(DUZ(2),",DA=ABMP("CDFN")
  1.  S DR=".74////N"
  1.  I ($D(^AUPNPAT(ABMP("PDFN"),36,0)))>10,($O(^AUPNPAT(ABMP("PDFN"),36,"B",9999999),-1)<ABMP("VDT")) S DR=".74////Y;.711////"_$O(^AUPNPAT(ABMP("PDFN"),36,"B",9999999),-1)
  1.  D ^DIE K DR
  1.  Q
  1.  ;
  1. BENE ;EP - ASSIGNMENT OF BENEFITS
  1.  S DR=".75////N"
  1.  I ($D(^AUPNPAT(ABMP("PDFN"),71,0)))>10,($O(^AUPNPAT(ABMP("PDFN"),71,"B",9999999),-1)<ABMP("VDT")) S DR=".75////Y;.712////"_$O(^AUPNPAT(ABMP("PDFN"),71,"B",9999999),-1)
  1.  D ^DIE K DR
  1.  Q