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

ACHSEDOC.m

Go to the documentation of this file. 
  1. ACHSEDOC ; IHS/ITSC/PMF - PRINT EOBRS BY PATIENT ;   [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  W $G(IORVON),!,"THIS REPORT WILL ONLY INCLUDE PROCESSED DOCUMENTS.  ANY UNPROCESSED",!,"DOCUMENT WILL HAVE TO BE PRINTED USING ANOTHER OPTION.",!!,$G(IORVOFF),!
  1.  I '$D(ACHSFC) D ^ACHSVAR  ;CHECKS SOME FLAGS TO SEE IF PROCESSING GOING ON
  1.  D ^ACHSUD   ;SELECT DOCUMENT 
  1.  I '$D(ACHSDIEN)!($D(DUOUT))!($D(DTOUT)) D END Q   ;LEAVE 
  1.  ;
  1.  S ACHSDOC0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))   ;GET DOCUMENT 0 RECORD
  1.  ;
  1.  I $G(ACHSDOC0)="" W !!,*7,"Document ",ACHSDIEN," is not complete!" D
  1.  .W !!
  1.  .D RTRN^ACHS
  1.  Q:$G(ACHSQUIT)
  1.  ;
  1.  S ACHSPO="0"_$P(ACHSDOC0,U,14)_"-"_ACHSFC_"-"_$P(ACHSDOC0,U)
  1.  S (ACHSTIEN,ACHSX,ACHSPO1,ACHSY)=0
  1.  ;GET THE TRANSACTIONS FOR THE DOCUMENT
  1. DOC ;
  1.  F  S ACHSTIEN=$O(^ACHSF(DUZ(2),"EOBR",ACHSDIEN,ACHSTIEN)) Q:+ACHSTIEN=0  D
  1.  .S ACHSX=ACHSX+1,ACHSTIEN(ACHSX)=ACHSTIEN
  1.  D DOCSEL
  1.  Q
  1. DOCSEL ;
  1.  I ACHSX=0 D DOCNO Q   ;NO DOCUMENTS FOUND
  1.  ;
  1.  S ACHSY=1
  1.  ;
  1.  I ACHSX=1 D DOCPRT D END Q   ;IF ONLY ONE DOCUMENT DO IT
  1.  ;
  1.  ;
  1.  W !!,"ENTRY #",?10,"DOCUMENT #",?30,"PATIENT NAME",?60,"CHART #",?70,"TRANS TYPE",!,$$R("-",79)
  1.  S I=""
  1.  F  S I=$O(ACHSTIEN(I)) Q:I=""  D
  1.  .D DOCSEL1
  1.  .S ACHSY=ACHSY+1
  1.  .I ACHSY#10=0 W !!,"Press <RETURN> To Continue ",!! D READ^ACHSFU
  1. DIR ;
  1.  S ACHSY=$$DIR^XBDIR("L^1:"_ACHSX,"SELECT ENTRY #(S) TO PRINT")
  1.  G END:$D(DUOUT)!$D(DTOUT),DOCPRT
  1.  ;
  1. DOCSEL1 ;
  1.  Q:'$D(ACHSTIEN(I))
  1.  S ACHSTIEN=ACHSTIEN(I),ACHSTTYP=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,2)
  1.  S %=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,3)
  1.  I % S ACHSPAT=$P(^DPT(%,0),U,1),ACHSCHRT=$P(^AUPNPAT(%,41,DUZ(2),0),U,2)
  1.  E  S %=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,3),ACHSPAT=$S(%=1:"* BLANKET",%=2:"* SPECIAL TRANS",1:""),ACHSCHRT="<none>"
  1.  S ACHSPO=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,14)_"-"_ACHSFC_"-"_$P(^(0),U,1)
  1.  D DOCSELPR
  1.  Q
  1.  ;
  1. DOCSEL2 ;
  1.  Q:'$D(ACHSPO1(I))
  1.  S ACHSPO1=ACHSPO1(I),ACHSNON=ACHSPO1,ACHSPAT=$P(^ACHSEOBE(ACHSPO1,1),U,1),ACHSCHRT=$P(^AUPNPAT(ACHSPAT,41,DUZ(2),0),U,2),ACHSPAT=$P(^DPT(ACHSPAT,0),U,1),ACHSTTYP=$P(^ACHSEOBE(ACHSPO1,1),U,14)
  1.  D DOCSELPR
  1.  Q
  1.  ;
  1. DOCSELPR ;          
  1.  W !,I_".",?10,ACHSPO,?30,ACHSPAT,?60,ACHSCHRT,?70,ACHSTTYP,!
  1.  Q
  1.  ;
  1. DOCPRT ;
  1.  W !!
  1.  S %ZIS="P"
  1.  D ^%ZIS
  1.  I POP D END Q
  1.  S ACHSEOIO=IO
  1.  D BRPT^ACHSFU
  1.  G:ACHSY=0 DOCSEL
  1.  F I=1:1 S ACHSX1=$P(ACHSY,",",I) Q:ACHSX1=""  D:$D(ACHSTIEN(ACHSX1)) DOCPRT1 ;D:$D(ACHSPO1(ACHSX1)) DOCPRT2
  1.  D END
  1.  Q
  1.  ;
  1. DOCPRT1 ;
  1.  S ACHSTIEN=ACHSTIEN(ACHSX1)
  1.  D ^ACHSEOBA,^ACHSEOB2
  1.  Q
  1.  ;
  1. DOCPRT2 ;
  1.  ;S ACHSNON=ACHSPO1(ACHSX1)
  1.  ;D ^ACHSEOBE,^ACHSEOB2
  1.  ;Q
  1. DOCNO ;
  1.  W !!,"NO EOBRS FOR THIS DOCUMENT",!!
  1.  D END
  1.  Q
  1.  ;
  1. NON ;
  1.  S ACHSN=$$DIR^XBDIR("Y","DO YOU WISH TO PRINT NONPROCESSED EOBRS","","","","",2)
  1.  G END:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
  1.  Q
  1.  ;
  1. END ;
  1.  D ^%ZISC,EN^XBVK("ACHS"),^ACHSVAR
  1.  Q
  1.  ;
  1. R(X,Y) Q $$REPEAT^XLFSTR(X,Y)
  1.  ;