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

IBTRED.m

Go to the documentation of this file. 
  1. IBTRED	;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY ; 01-JUL-1993
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. %	;
  1. EN	; -- main entry point for IBT EXPAND/EDIT TRACKING
  1. 	I '$D(DT) D DT^DICRW
  1. 	K XQORS,VALMEVL,DFN,IBTRN,IBTRV,IBTRC,IBTRD
  1. 	I '$G(IBTRN) G EN^IBTRE Q  ; entry from programmer mode
  1. 	D EN^VALM("IBT EXPAND/EDIT TRACKING")
  1. 	K IBFASTXT
  1. 	Q
  1. 	;
  1. HDR	; -- header code
  1. 	D PID^VADPT
  1. 	S VALMHDR(1)="Expanded Claims Tracking Info for: "_$E($P($G(^DPT(DFN,0)),"^"),1,20)_" "_$E($G(^(0)),1)_VA("BID")_"   ROI: "_$$EXPAND^IBTRE(356,.31,$P(^IBT(356,IBTRN,0),"^",31))
  1. 	S VALMHDR(2)="                              For: "_$$ETYP(IBTRN)
  1. 	Q
  1. 	;
  1. INIT	; -- init variables and list array
  1. 	K VALMQUIT
  1. 	S VALMCNT=0,VALMBG=1
  1. 	D BLD,HDR
  1. 	Q
  1. 	;
  1. BLD	; -- list builder
  1. 	N IBTRND,IBTRND1,IBTRND2,IBETYP
  1. 	K ^TMP("IBTRED",$J)
  1. 	F I=1:1:30 D BLANK(.I)
  1. 	I '$G(IBTRPRF) S IBTRPRF=123
  1. 	I IBTRPRF<10 S X=$S(IBTRPRF=1:"IBTRED  HR MENU",IBTRPRF=2:"IBTRED  IR MENU",IBTRPRF=3:"IBTRED  BI MENU",1:"IBTRED  MENU") D PROT^IBTRPR(X)
  1. 	D KILL^VALM10()
  1. 	S IBTRND=$G(^IBT(356,IBTRN,0)),IBTRND1=$G(^(1))
  1. 	S IBETYP=$G(^IBE(356.6,+$P(IBTRND,"^",18),0))
  1. 	S VALMCNT=30
  1. 	D VISIT,^IBTRED0,^IBTRED01
  1. 	Q
  1. 	;
  1. VISIT	; -- Visit info Region
  1. 	N OFFSET,START,IBOE
  1. 	S START=1,OFFSET=2
  1. 	D SET^IBCNSP(START,OFFSET," Visit Information ",IORVON,IORVOFF)
  1. 	D SET^IBCNSP(START+1,OFFSET,"    Visit Type: "_$P(IBETYP,"^"))
  1. 	I '$D(IBETYP) N IBETYP S IBETYP=$G(^IBE(356.6,+$P(IBTRND,"^",18),0))
  1. 	S X=$P(IBETYP,"^",3) D @X
  1. 	Q
  1. 1	; -- visit region for admission or scheduled admission
  1. 	I $P($G(^DGPM(+$P(IBTRND,"^",5),0)),"^",17) S VAINDT=+$G(^DGPM(+$P(IBTRND,"^",5),0))
  1. 	I '$D(VAIN) S VA200="" D INP^VADPT
  1. 	I VAIN(7)="" S Y=$P(IBTRND,"^",6) D D^DIQ S $P(VAIN(7),"^",2)=Y
  1. 	D SET^IBCNSP(START+2,OFFSET,"Admission Date: "_$P(VAIN(7),"^",2))
  1. 	D SET^IBCNSP(START+3,OFFSET,"          Ward: "_$P(VAIN(4),"^",2))
  1. 	D SET^IBCNSP(START+4,OFFSET,"     Specialty: "_$P(VAIN(3),"^",2))
  1. 	Q
  1. 2	; -- visit region for  outpatient care
  1. 	S IBOE=$P(IBTRND,"^",4)
  1. 	D SET^IBCNSP(START+2,OFFSET,"    Visit Date: "_$$DAT1^IBOUTL($P(IBTRND,"^",6),"2P"))
  1. 	I +IBOE<1 D  Q
  1. 	.D SET^IBCNSP(START+3,OFFSET,"  No Outpatient Encounter Found") Q
  1. 	D SET^IBCNSP(START+3,OFFSET,"        Clinic: "_$P($G(^SC(+$P($G(^SCE(+IBOE,0)),"^",4),0)),"^"))
  1. 	D SET^IBCNSP(START+4,OFFSET,"  Appt. Status: "_$$EXPAND^IBTRE(409.68,.12,$P($G(^SCE(+IBOE,0)),"^",12)))
  1. 	D SET^IBCNSP(START+5,OFFSET,"    Appt. Type: "_$$EXPAND^IBTRE(409.68,.1,$P($G(^SCE(+IBOE,0)),"^",10)))
  1. 	D SET^IBCNSP(START+6,OFFSET,"  Special Cond: "_$$ENCL(IBOE))
  1. 	Q
  1. 	;
  1. 3	; -- visit region for rx refill
  1. 	N PSONTALK,PSOTMP
  1. 	S PSONTALK=1 ;PSORXN=+$P(IBTRND,"^",8),PSOFILL=+$P(IBTRND,"^",10)
  1. 	S X=+$P(IBTRND,"^",8)_"^"_+$P(IBTRND,"^",10) D EN^PSOCPVW
  1. 	D SET^IBCNSP(START+2,OFFSET,"Prescription #: "_$G(PSOTMP(52,+$P(IBTRND,"^",8),.01,"E")))
  1. 	D SET^IBCNSP(START+3,OFFSET,"   Refill Date: "_$G(PSOTMP(52.1,+$P(IBTRND,"^",10),.01,"E")))
  1. 	D SET^IBCNSP(START+4,OFFSET,"          Drug: "_$G(PSOTMP(52,+$P(IBTRND,"^",8),6,"E")))
  1. 	D SET^IBCNSP(START+5,OFFSET,"      Quantity: "_$J($G(PSOTMP(52,+$P(IBTRND,"^",8),7,"E")),8))
  1. 	D SET^IBCNSP(START+6,OFFSET,"   Days Supply: "_$J($G(PSOTMP(52,+$P(IBTRND,"^",8),8,"E")),8))
  1. 	D SET^IBCNSP(START+7,OFFSET,"          NDC#: "_$P($G(^PSDRUG(+$P($G(^PSRX(+$P(IBTRND,"^",8),0)),"^",6),2)),"^",4))
  1. 	D SET^IBCNSP(START+8,OFFSET,"     Physician: "_$G(PSOTMP(52,+$P(IBTRND,"^",8),4,"E")))
  1. 	Q
  1. 	;
  1. 4	; -- Visit region for prosthetics
  1. 	D 4^IBTRED01
  1. 	Q
  1. 	;
  1. HELP	; -- help code
  1. 	S X="?" D DISP^XQORM1 W !!
  1. 	Q
  1. 	;
  1. EXIT	; -- exit code
  1. 	K VALMQUIT,IBTRN
  1. 	D CLEAN^VALM10,FULL^VALM1
  1. 	Q
  1. 	;
  1. BLANK(LINE)	; -- Build blank line
  1. 	D SET^VALM10(.LINE,$J("",80))
  1. 	Q
  1. 	;
  1. ETYP(IBTRN)	; -- Expand type of epidose and date
  1. 	N IBY S IBY=""
  1. 	S IBTRND=$G(^IBT(356,+IBTRN,0)) I IBTRND="" G ETYPQ
  1. 	S IBETYPD=$G(^IBE(356.6,+$P(IBTRND,"^",18),0))
  1. 	I IBETYPD="" G ETYPQ
  1. 	S IBY=$P(IBETYPD,"^")_" on "_$$DAT1^IBOUTL($P(IBTRND,"^",6),"2P")
  1. ETYPQ	Q IBY
  1. 	;
  1. ENCL(IBOE)	; -- output format of classifications
  1. 	N I,X,IBCL,IBCL1 S IBCL=""
  1. 	I '$G(IBOE) G ENCLQ
  1. 	S IBCL1=$$ENCL^IBAMTS2(+IBOE)
  1. 	F I=1:1:4 S X=$P(IBCL1,"^",I) S:X IBCL=IBCL_$S(I=1:"AO",I=2:"SC",I=3:"IR",I=4:"EC",1:"")_"  "
  1. ENCLQ	Q IBCL