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

IBTRE4.m

Go to the documentation of this file. 
  1. IBTRE4	;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ; 1-SEP-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. %	G ^IBTRE
  1. 	;
  1. EN(IBTRN)	; -- entry point for protocols
  1. 	;    must do own rebuild actions
  1. 	; -- Input - point to 356
  1. 	;
  1. 	N IBETYP,IBTRND,IBXY,IBCNT,IBDGPM
  1. 	D FULL^VALM1
  1. 	S VALMBCK=""
  1. 	S IBTRND=$G(^IBT(356,IBTRN,0)),IBDGPM=$P(IBTRND,"^",5)
  1. 	;
  1. 	S IBETYP=$$TRTP^IBTRE1(IBTRN)
  1. 	I IBETYP>2 W !!,"Clinical Information comes from the parent package." D PAUSE^VALM1 G ENQ
  1. 	;
  1. 	; -- outpatient procedure
  1. 	I IBETYP=2 D  G ENQ
  1. 	.W !!,*7,"You must use the add/edit action on Check-out to add procedures to Outpatient Encounters.",!
  1. 	.S VALMBCK="R"
  1. 	;
  1. 	; -- Inpatient procedure
  1. 	Q:'IBDGPM
  1. 	I IBETYP=1 D PROC(IBTRN,IBETYP) S VALMBCK="R"
  1. 	;
  1. ENQ	;
  1. 	Q
  1. 	;
  1. PROC(IBTRN,IBETYP)	; -- add/edit procedure
  1. 	Q:'IBTRN
  1. 	I $G(IBETYP)'=1 Q
  1. 	N DA,DR,DIC,DIE
  1. 	;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
  1. 	I IBETYP'=1!('IBDGPM) W !!,"You can only enter a procedure for an admission",! D PAUSE^VALM1 G PROCQ
  1. 	;
  1. 	S X="IOINHI;IOINORM" D ENDR^%ZISS
  1. 	W !!,"--- ",IOINHI,"Procedure",IOINORM," --- "
  1. 	S IBSEL="Add"
  1. 	D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK(IBCNT,"A")
  1. 	I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G PROCQ
  1. 	I IBSEL="Add" D ADD(IBTRN)
  1. 	D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;")
  1. PROCQ	Q
  1. 	;
  1. ADD(IBTRN,TYPE)	; -- Add a new procedure
  1. 	;
  1. 	N DTOUT,DUTOU,X,Y,DIC
  1. 	S IBCNT=0
  1. 	I '$G(TYPE) S TYPE=""
  1. NXT	S DIC("A")=$S(IBCNT<1:"Select Procedure: ",1:"Next Procedure: ")
  1. 	S DIC("S")="I '$P(^(0),U,9)"
  1. 	S DIC="^ICD0(",DIC(0)="AEMQ",X=""
  1. 	W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
  1. 	I $D(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),+Y)) W !!,*7,$P(Y,"^",2)," is already a procedure.",!
  1. 	S IBCNT=IBCNT+1
  1. 	S IBADG=$$NEW(+Y,IBTRN,TYPE)
  1. 	I IBADG,TYPE'=3 D EDT(IBADG) G NXT
  1. ADDQ	Q
  1. 	;
  1. NEW(ICDI,IBTRN,TYPE)	; -- file new entry
  1. 	;
  1. 	N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
  1. 	S X=ICDI,(DIC,DIK)="^IBT(356.91,",DIC(0)="L",DLAYGO=356.91
  1. 	D FILE^DICN S IBADG=+Y
  1. 	I IBADG>0 L +^IBT(356.91,IBADG) S $P(^IBT(356.91,IBADG,0),"^",2,4)=$$DGPM^IBTRE3(IBTRN)_"^"_$P($P(^IBT(356,IBTRN,0),"^",6),"."),DA=IBADG D IX1^DIK L -^IBT(356.91,IBADG)
  1. NEWQ	Q IBADG
  1. 	;
  1. EDT(IBADG,IBDR)	; -- edit entry
  1. 	;
  1. 	N DR,DIE,DA
  1. 	S DR=$G(IBDR) I DR="" S DR=".03;"
  1. 	S DA=IBADG,DIE="^IBT(356.91,"
  1. 	L +^IBT(356.91,IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
  1. 	Q:'$G(^IBT(356.91,DA,0))
  1. 	L -^IBT(356.91,IBADG)
  1. 	D ^DIE
  1. EDTQ	Q
  1. 	;
  1. SET(IBTRN)	; -- set array
  1. 	N IBDGPM,IBICD
  1. 	S IBDGPM=$$DGPM^IBTRE3(IBTRN)
  1. 	S (IBICD,IBCNT)=0
  1. 	F  S IBICD=$O(^IBT(356.91,"ADGPM",IBDGPM,IBICD)) Q:'IBICD  S IBDA=$O(^(IBICD,0)) D
  1. 	.S IBCNT=IBCNT+1
  1. 	.S IBXY(IBCNT)=IBDA_"^"_IBICD
  1. SETQ	Q
  1. 	;
  1. LIST(IBXY)	;List Diagnosis Array
  1. 	; Input  -- IBXY     Diagnosis Array Subscripted by a Number
  1. 	; Output -- List Diagnosis Array
  1. 	N I,IBXD
  1. 	W !
  1. 	S I=0 F  S I=$O(IBXY(I)) Q:'I  S IBXD=$G(^ICD0(+$P(IBXY(I),"^",2),0)) D
  1. 	.S IBTNOD=$G(^IBT(356.91,+IBXY(I),0))
  1. 	.W !?2,I,"  ",$P(IBXD,"^"),?15,$E($P(IBXD,"^",4),1,43),?60,$$DAT1^IBOUTL($P($P(IBTNOD,"^",3),"."),2)
  1. 	Q
  1. 	;
  1. ASK(IBCNT,IBPAR,IBSELDF)	;Ask user to select from list
  1. 	; Input  -- SDCNT    Number of Entities
  1. 	;           SDPAR    Selection Parameters (A=Add)
  1. 	;           SDSELDF  Selection Default  [Optional]
  1. 	; Output -- Selection
  1. 	N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. REASK	S DIR("?")="Enter "_$S($G(IBSELDF)]"":"<RETURN> for '"_IBSELDF_"', ",1:"")_$S(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$S(IBPAR["A":", or 'A' to Add",1:"")
  1. 	S DIR("A")="Enter "_$S(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$S(IBPAR["A":", or 'A' to Add",1:"")_": "_$S($G(IBSELDF)]"":IBSELDF_"// ",1:"")
  1. 	S DIR(0)="FAO^1:30"
  1. 	D ^DIR I $D(DTOUT)!($D(DUOUT)) S Y="^" G ASKQ
  1. 	S Y=$$UPPER^VALM1(Y)
  1. 	I Y?.N,Y,Y'>IBCNT G ASKQ
  1. 	I IBPAR["A",$E(Y)="A" S Y="Add" G ASKQ
  1. 	I Y="" S Y=$S($G(IBSELDF)]"":IBSELDF,1:"Return") G ASKQ
  1. 	W !!?5,DIR("?"),".",! G REASK
  1. ASKQ	Q $G(Y)