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

ACHSPAM.m

Go to the documentation of this file. 
  1. ACHSPAM ; IHS/ITSC/PMF - DOCUMENT PAYMENT - ENTER/EDIT MEDICAL DATA ; JUL 10, 2008
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7,14,17,23**;JUN 11,2001;Build 43
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Remove code that deleted Dental info.
  1.  ;IHS/SET/JVK ACHS*3.1*7 10/15/2003 - FIX THE CALL DUZ(2) FOR VERSION 22
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
  1. EDIT ;EP - From Option. Edit EOBR Medical data.
  1.  D SEL
  1.  I ($D(DUOUT))!($D(DTOUT))!'$D(ACHSDIEN) D END Q
  1.  ;
  1.  ;
  1. ENTER ;EP - After document paid.
  1.  I $E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)=18 D ^ACHSZCK1   ;ACHS*3.1*17 ADDED FOR BEMJ SITES RECORD CHECK# AND COMMENTS
  1.  ;IF THIS IS 'BLANKET ORDER' 
  1.  I $$DOC^ACHS(0,3) W !,"UNABLE TO PROCESS MEDICAL DATA FOR BLANKET ORDER." D RTRN^ACHS D END Q
  1.  S DA=ACHSDIEN
  1.  ;IHS/SET/JVK *3.1*7 10/10/03 MAKE CHANGES BELOW FOR FILEMAN 22 CHANGES
  1.  ;S DA(2)=DUZ(2) ; Must be set for x-ref to be set correctly.
  1.  I $G(^DD("VERSION"))>21 S DA(1)=DUZ(2) ; Must be set for x-ref to be set correctly.
  1.  I $G(^DD("VERSION"))<22 S DA(2)=DUZ(2) ; Must be set for x-ref to be set correctly.
  1.  ;END CHANGES IHS/SET/JVK *3.1*7
  1.  S DIE="^ACHSF("_DUZ(2)_",""D"","
  1.  S DLAYGO=9002080
  1.  ;ACHS*3.1*17 ADDED PRINT CHECK DATE FOR BEMJ TRIBAL SITES SITES
  1.  ;S DR=$S(ACHSTYP=1:"90;91;92;94//1;",1:"")_"95;96;97"_$S($$PARM^ACHS(0,8)="Y":";51",1:"")
  1.  S DR=$S(ACHSTYP=1:"90;91;92;94//1;",1:"")_"95;96;97"_$S($$PARM^ACHS(0,8)="Y":";51",1:"")_$S($E($P(^AUTTLOC(DUZ(2),0),U,10),1,2)=18:";52",1:"")
  1.  S DR(2,9002080.195)=".01"
  1.  S DR(2,9002080.196)=".01:1"
  1.  S DR(2,9002080.197)=".01:6;"_$S(ACHSTYP=2:"7;8",1:"")_";9"
  1.  D ^DIE
  1.  ;
  1.  ;IF 'POST EOBR TO PAT CARE CMPNT' AND LINK TO PCC IS ON
  1.  I $$PARM^ACHS(2,22)="Y",$$LINK^ACHSPAP1 S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) D ^ACHSPAP   ;LINK TO PCC 1/2
  1.  ;
  1.  ;IF 'REFERRAL' PTR
  1.  I $$DOC^ACHS(2,7) D
  1.  .D DX^ACHSBMC        ;TRANSFER DX INFO TO RCIS
  1.  .D PX^ACHSBMC        ;TRANSFER PX INFO TO RCIS
  1.  ;
  1.  ;  This makes sure that a bug in FileMan doesn't leave extraneous
  1.  ;  nodes in the ^ACHSF( global.   WHAT BUG??????? NEEDS TESTING
  1.  ;F ACHS=1:1:50 I $D(^ACHSF(ACHS,"D",ACHSDIEN,11)),$D(^ACHSF(ACHS,"D",ACHSDIEN))=10 D;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ;. K ^ACHSF(ACHS,"D",ACHSDIEN,11);IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ;. S DA(2)=DUZ(2),DA(1)=ACHSDIEN,DA=0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ;. F  S DA=$O(^ACHSF(DA(2),"D",DA(1),11,DA)) Q:'DA  S X=$P(^(DA,0),U) X ^DD(9002080.197,.01,1,1,1);IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ;.Q;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ;
  1.  D END
  1.  Q
  1.  ;
  1. SEL ;EP - Select document, display data.
  1.  D ^ACHSUD                                  ;SELECT DOCUMENT
  1.  I $D(DUOUT)!$D(DTOUT)!'$D(ACHSDIEN) D END Q
  1.  S ACHSTIEN=1
  1.  K ACHSSIG
  1.  D INIT^ACHSRP2      ;INITIALIZE DOCUMENT/TRANSACTION VARIABLES
  1.  D ^ACHSAV           ;DOCUMENT DISPLAY; THIS RTN ALSO DOES INIT^ACHSRP2
  1.  S ACHSADJ=""
  1.  ;
  1.  D A0A^ACHSUSC       ;DISPLAY DOCUMENT CANCEL/SUPPLEMENTAL INFO. THIS
  1.  ;                    CALL BYPASSES THE INIT^ACHSRP2 IN ACHSUSC
  1.  ;
  1.  K ACHSADJ
  1.  I $D(ACHSDIEN),'$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") W !,"LOCK FAILED AT SEL+9^ACHSPAM" K ACHSDIEN
  1.  Q
  1.  ;
  1. REF ;EP - From option. Enter/Edit Referral medical data.
  1.  D SEL
  1.  I $D(DTOUT)!$D(DTOUT)!'$D(ACHSDIEN) D END Q
  1.  ;
  1.  I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3)!($P(^(0),U,4)=2) W *7,!,"NO ENTRY OF REFERRAL DATA TO THIS TYPE DOCUMENT ALLOWED.",! D RTRN^ACHS G END
  1.  S DIE="^ACHSF("_DUZ(2)_",""D"",",DA=ACHSDIEN,DR="80:83;84:87"
  1.  D ^DIE
  1.  W !
  1.  S ACHS("DX")=4,ACHS("PX")=6
  1.  ;
  1.  D CDRG        ;Compute and set DRG or Referral
  1.  ;              DRG & Referral Estimated cost.
  1.  ;
  1. END ; Unlock, kill vars, quit.
  1.  I $D(ACHSDIEN),'$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")
  1.  K ACHSPROV,ACHSCONP,ACHSCAN,ACHSDRG,ACHSSCC,ACHSCOPT,ACHSDOCR,ACHSESDA,ACHSESDO,ACHSFDT,ACHSODT
  1.  K ACHSTDT,ACHSHON,ACHSORDN,ACHSBLKF,ACHSIPA,ACHSSIG,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSPCCL
  1.  K DIC,DIE,DLAYGO,DR,D0,D1,DIADD,LAYGO  ;*3.1*23 added DIADD AND LAYGO
  1.  Q
  1.  ;
  1. CDRG ;EP - Compute and set DRG or Referral DRG & Referral Estimated cost.
  1.  Q  ;BYPASS CALCULATING DRG UNTIL FURTHER DEVELOPMENT
  1.  S X="ACHSGRP"
  1.  X ^%ZOSF("TEST")
  1.  E  Q:ACHS("DX")=9  S DIE="^ACHSF("_DUZ(2)_",""D"",",DA=ACHSDIEN,DR="78:79" D ^DIE W ! Q
  1.  S DFN=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,22)    ;PATIENT PTR
  1.  Q:'$D(^DPT(DFN,0))
  1.  D KILLS^ACHSGRP
  1.  S (ACHSOR,ACHSSD)="",ACHSSD1=1,ACHS=0,ACHSSEX=$P($G(^DPT(DFN,0)),U,2),AGE=(DT-$P($G(^DPT(DFN,0)),U,3))\365.25
  1.  F ACHSICDI=1:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("DX"),ACHS)) Q:'ACHS  S ACHSICDX(ACHSICDI)=$P($G(^(ACHS,0)),U),ACHSICDX(ACHSICDI,0)=$G(^ICD9(ACHSICDX(ACHSICDI),0))
  1.  S ACHSICDT=ACHSICDI-1,ACHS=0
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
  1.  ;F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS  I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($G(ICD0(D1,0)),U,2) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0  D
  1.  ;ACHS*3.1*23
  1.  ;F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS  I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($$ICDOP^ICDCODE(D1),U,3) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0  D
  1.  F ACHSNOR=0:1 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,ACHS("PX"),ACHS)) Q:'ACHS  I +^(ACHS,0)>0 S D1=+^(0),ACHSOR=ACHSOR_$P($$ICDOP^ICDEX((D1),,,"I"),U,3) F ACHSORG=0:0 S ACHSORG=$O(^ICD0(D1,"DR",ACHSORG)) Q:ACHSORG'>0  D
  1.  .S ACHSORG($P(^ICD(ACHSORG,0),U,5),ACHSORG)=""
  1.  .Q
  1.  F ACHSNSD=1:1:ACHSICDT S ACHS=ACHSICDX(ACHSNSD,0),SD=SD_$P(ACHS,U,2) S:$P(ACHS,U,2)'["g" SD1=0
  1.  F ACHSICDJ=1:1:ACHSICDT D ARR^ACHSGRP
  1.  I ACHS("DX")=9 G KGRP:'$D(ACHSICDE) S X=+$E($P(ACHSICDE($O(ACHSICDE(""))),U),4,99) G KGRP:'X S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,8),U)=X G KGRP
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,3)=""
  1.  I $D(ACHSICDE) S X=+$E($P(ACHSICDE($O(ACHSICDE(""))),U),4,99) I X S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,3)=X D CRECT
  1. KGRP ;
  1.  D KILLS^ACHSGRP
  1.  Q
  1.  ;
  1. CRECT ; Compute Referral Estimated cost.
  1.  S ACHSDRGW=+^ICD(X,9999999),(ACHS,ACHSRECT)=0
  1.  F ACHSI=0:1 S ACHS=$O(^AMER(2.1,ACHS)) Q:'ACHS  S X=$G(^AMER(2.1,ACHS,0)),ACHSX=(ACHSDRGW*$P(X,U,2))+$P(X,U,3),ACHSX=+$J(ACHSX,1,2),ACHSRECT=ACHSRECT+ACHSX
  1.  I ACHSI S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U,4)=+$J(ACHSRECT/ACHSI,1,2)
  1.  K ACHSDRGW,ACHSI,ACHSRECT,ACHSX
  1.  Q
  1.  ;
  1. CHKDT ;EP - Compare discharge date (X) and admission date (ACHSXXXZ).
  1.  Q:'$D(ACHSXXXZ)
  1.  I X<ACHSXXXZ W !!,*7,"Discharge Date CANNOT be BEFORE Admission Date!!",!! K X
  1.  Q
  1.  ;