IBTRH6 ;ALB/FA - HCSR Send 278 Short Worklist ;11-NOV-2014
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;;
;
EN ; Main entry point for the IBT HCSR SEND 278 SHORT worklist
; Displays the selected 278 short form for sending 278 requests
; Input: IBTRIEN - IEN of the selected entry to send a request for
N FROMDATA,IBTRENT,INPAT,NODE2,NODE7,NODE19,VADM,WHICH
;;12/9/14 JWS - prevent entry if status is PENDING a response
I $$STATUS^IBTRH2(IBTRIEN)="07" D STATMSG^IBTRH2A(4) Q
S VALMBCK="R"
S FROMDATA=0
S INPAT=$S($P(NODE0,U,4)="I":1,1:0) ; 1 if inpatient, 0 if outpatient
S WHICH=$$SELSHORT(INPAT) ; type of request
I WHICH'="" D EN^VALM("IBT HCSR SEND 278 SHORT")
I $D(IBFASTXT) S VALMBCK="Q"
Q
;
SELSHORT(INPAT) ; User selection of which 278 request to send
; Input: INPAT=1 if inpatient, 0 otherwise
; Returns: Selected Input Type or "" if none selected
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y
D FULL^VALM1
I INPAT S XX="1:Admission (initial);2:Mental Health Inpatient (initial)"
I 'INPAT S XX="1:Appointment (initial);2:Mental Health Outpatient (initial)"
S XX=XX_";3:Prescription (initial)"
S DIR(0)="S^"_XX,DIR("A")="Select Input Type"
D ^DIR
Q:$D(DIRUT) "" ; User Pressed ^ or timed out
I Y'=1 D S Y=""
. W !,"Mental Health and Prescription options are not currently available."
. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
. S DIR(0)="EA"
. S DIR("A",1)=" "
. S DIR("A")="Press RETURN to continue " D ^DIR
Q Y
;
HDR ;EP
; Protocol action to display Worklist Patient header information
; Input: IBTRIEN - IEN of the selected entry to send a request for
; Output: Header information for the patient of the selected entry is set
;
N Z
S Z=$E(VADM(1),1,28),Z=Z_$J("",35-$L(Z))_$P(VADM(2),U,2)_" DOB: "_$P(VADM(3),U,2)_" AGE: "_VADM(4)
S VALMHDR(1)=Z
S VALMSG="*/Required"
Q
;
INIT ;EP
;
K ^TMP("IBTRH6",$J)
S VALMBG=1
D DEM^VADPT ; get patient demographics
S NODE0=$G(^IBT(356.22,IBTRIEN,0))
S NODE2=$G(^IBT(356.22,IBTRIEN,2))
S NODE7=$G(^IBT(356.22,IBTRIEN,7))
S NODE19=$G(^IBT(356.22,IBTRIEN,19))
D WRTFLDS D:'FROMDATA WRTCNUM ; auto populate fields
; re-read nodes to get auto-populated values
S NODE0=$G(^IBT(356.22,IBTRIEN,0))
S NODE2=$G(^IBT(356.22,IBTRIEN,2))
S NODE7=$G(^IBT(356.22,IBTRIEN,7))
S NODE19=$G(^IBT(356.22,IBTRIEN,19))
D BLD
I WHICH=1 S VALM("TITLE")="HCSR 278 "_$S(INPAT:"Admission",1:"Appointment")_" - Brief"
I WHICH=2 S VALM("TITLE")="HCSR 278 Mental - Brief"
I WHICH=3 S VALM("TITLE")="HCSR 278 Prescription - Brief"
Q
;
BLD ; Creates the body of the worklist
;
N ELINEL,ELINER,SLINE
S SLINE=1
D BLDUMO(SLINE,.ELINEL) ; Build UMO Field section
D BLDSUB(ELINEL,.ELINEL) ; Build Subscriber Field section
D BLDREQ(SLINE,.ELINER) ; Build Requester Field section
S SLINE=$S(ELINEL>ELINER:ELINEL,1:ELINER)
D BLDDEP(SLINE,.ELINEL) ; Build Dependent Field section
D BLDDIAG(SLINE,.ELINER) ; Build Diagnoses Field section
S SLINE=$S(ELINEL>ELINER:ELINEL,1:ELINER)
D BLDHCSR(SLINE,.ELINEL) ; Build Health Care Services Field section
D BLDPROV(SLINE,.ELINER) ; Build Provider Field section
S SLINE=$S(ELINEL>ELINER:ELINEL,1:ELINER)
D BLDSVC(SLINE,.ELINEL) ; Build Service Line Field section
D BLDAPI(SLINE,.ELINER) ; Build API Line Field section
S SLINE=$S(ELINEL>ELINER:ELINEL,1:ELINER)
D BLDCOM(SLINE,.ELINEL) ; Build Comment Field section
S VALMCNT=ELINEL-1
Q
;
BLDUMO(SLINE,ELINE) ; Build the UMO Field Section
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N PAYER,PAYID
S ELINE=$$SET("",$J("",40),SLINE,1) ; Spacing Blank Line
S ELINE=$$SETN("UM Organization",ELINE,1,1)
S ELINE=$$SET("Name*: ",$$GET1^DIQ(36,IEN36_",",.01),ELINE,1)
S PAYER=+$$GET1^DIQ(36,IEN36_",",3.1,"I") ; file 365.12 ien
S PAYID="" I PAYER>0 S PAYID=$P($G(^IBE(365.12,PAYER,0)),U,2) ; VA national id
S ELINE=$$SET("National Payer ID: ",PAYID,ELINE,1)
S ELINE=$$SET("HPID: ",$$HPD^IBCNHUT1(IEN36),ELINE,1)
Q
;
BLDSUB(SLINE,ELINE) ; Build the Subscriber Fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N INSNODE3,ZIP
S INSNODE3=$G(^DPT(DFN,.312,IEN312,3))
S ELINE=$$SET("",$J("",40),SLINE,1) ; Spacing Blank Line
S ELINE=$$SETN("Subscriber",ELINE,1,1)
S ELINE=$$SET("Name*: ",$P(INSNODE0,U,17),ELINE,1)
S ELINE=$$SET("Primary ID*: ",$P(INSNODE0,U,2),ELINE,1)
S ELINE=$$SET("Address Line 1: ",$P(INSNODE3,U,6),ELINE,1)
S ELINE=$$SET("Address Line 2: ",$P(INSNODE3,U,7),ELINE,1)
S ELINE=$$SET("City: ",$P(INSNODE3,U,8),ELINE,1)
S ELINE=$$SET("State: ",$$GET1^DIQ(5,$P(INSNODE3,U,9)_",",1),ELINE,1)
S ZIP=$P(INSNODE3,U,10) I $L(ZIP)>5,$E(ZIP,6)'="-" S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,99)
S ELINE=$$SET("Zip Code: ",ZIP,ELINE,1)
Q
;
BLDREQ(SLINE,ELINE) ; Build the Requester fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N CNARY,REQIEN,REQSTR,REQDATA,ZIP
S REQIEN=$P($$SITE^VASITE(),U),REQSTR=$$PRVDATA^IBTRHLO2(REQIEN,4)
D GETCNUM(.CNARY)
S ELINE=$$SET("",$J("",40),SLINE,41) ; Spacing Blank Line
S ELINE=$$SETN("Requester",ELINE,41,1)
S ELINE=$$SET("Name*: ",$P(REQSTR,U),ELINE,41)
S ELINE=$$SET("NPI*: ",$P(REQSTR,U,7),ELINE,41)
S ELINE=$$SET("Taxonomy Code: ",$P($$TAXORG^XUSTAX(REQIEN),U),ELINE,41)
S ELINE=$$SET("Address Line 1*: ",$P(REQSTR,U,2),ELINE,41)
S ELINE=$$SET("Address Line 2: ",$P(REQSTR,U,3),ELINE,41)
S ELINE=$$SET("City*: ",$P(REQSTR,U,4),ELINE,41)
S ELINE=$$SET("State*: ",$$GET1^DIQ(5,$P(REQSTR,U,5)_",",1),ELINE,41)
S ZIP=$P(REQSTR,U,6) I $L(ZIP)>5,$E(ZIP,6)'="-" S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,99)
S ELINE=$$SET("Zip Code*: ",ZIP,ELINE,41)
S ELINE=$$SET("Contact Name*: ",$$EXTERNAL^DILFD(356.22,.11,,$P(NODE0,U,11)),ELINE,41)
S ELINE=$$SET("Contact Phone: ",$G(CNARY("TE")),ELINE,41)
S ELINE=$$SET("Contact Phone Ext.: ",$G(CNARY("EX")),ELINE,41)
S ELINE=$$SET("Contact Fax: ",$G(CNARY("FX")),ELINE,41)
Q
;
BLDDEP(SLINE,ELINE) ; Build the Dependent fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N INSNODE4
S INSNODE4=$G(^DPT(DFN,.312,IEN312,4))
I $P(INSNODE4,U,3)="18" Q ; pat. relationship is "self"
S ELINE=$$SET("",$J("",40),SLINE,1)
S ELINE=$$SETN("Dependent",ELINE,1,1)
S ELINE=$$SET("Name*: ",VADM(1),ELINE,1)
Q
;
BLDDIAG(SLINE,ELINE) ; Build the Diagnosis fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N DATA,DPTR,QPTR,Z
S ELINE=$$SET("",$J("",40),ELINE,41)
S ELINE=$$SETN("Diagnoses",ELINE,41,1)
S Z=0 F S Z=$O(^IBT(356.22,IBTRIEN,3,Z)) Q:'Z!(Z?1.A) D
.S DATA=$G(^IBT(356.22,IBTRIEN,3,Z,0)) I DATA'="" D
..S QPTR=+$P(DATA,U),DPTR=$P(DATA,U,2)
..S ELINE=$$SET("Qualifier: ",$$GET1^DIQ(356.006,QPTR_",",.02),ELINE,41)
..S ELINE=$$SET("Diagnosis: ",$$EXTERNAL^DILFD(356.223,.02,,DPTR),ELINE,41)
..Q
.Q
Q
;
BLDHCSR(SLINE,ELINE) ; Build the Health Care Service Review Fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N Z
S ELINE=$$SET("",$J("",40),SLINE,1)
S ELINE=$$SETN("Health Care Service Review",ELINE,1,1)
S ELINE=$$SET("Category*: ",$$GET1^DIQ(356.001,+$P(NODE2,U)_",",.02),ELINE,1)
S ELINE=$$SET("Certification Type*: ",$$GET1^DIQ(356.002,+$P(NODE2,U,2)_",",.02),ELINE,1)
S ELINE=$$SET("Service Type*: ",$$GET1^DIQ(365.013,+$P(NODE2,U,3)_",",.02),ELINE,1)
I 'INPAT S ELINE=$$SET("Facility Type*: ",$$GET1^DIQ(353.1,+$P(NODE2,U,5)_",",.02),ELINE,1)
I INPAT D
.S Z=$P(NODE2,U,6)_$P(NODE2,U,7)
.I Z="11" S ELINE=$$SET("Bill Type*: ","HOSPITAL/INPATIENT",ELINE,1)
.S ELINE=$$SET("Adm Type: ",$$EXTERNAL^DILFD(356.22,7.01,,$P(NODE7,U)),ELINE,1)
.Q
Q
;
BLDPROV(SLINE,ELINE) ; Build the Provider Information Fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N DATA,PRVDATA,PRVPTR,Z
S ELINE=$$SET("",$J("",40),ELINE,41)
S ELINE=$$SETN("Provider Information",ELINE,41,1)
S Z=0 F S Z=$O(^IBT(356.22,IBTRIEN,13,Z)) Q:'Z!(Z?1.A) D
.S DATA=$G(^IBT(356.22,IBTRIEN,13,Z,0)) I DATA'="" D
..S PRVPTR=$P(DATA,U,3),PRVDATA=$$PRVDATA^IBTRHLO2(+$P(PRVPTR,";"),$P($P(PRVPTR,"(",2),","))
..S ELINE=$$SET("Provider Type: ",$$GET1^DIQ(365.022,$P(DATA,U)_",",.02),ELINE,41)
..S ELINE=$$SET("Provider Name: ",$P(PRVDATA,U),ELINE,41)
..S ELINE=$$SET("Provider NPI: ",$P(PRVDATA,U,7),ELINE,41)
..Q
.Q
Q
;
BLDSVC(SLINE,ELINE) ; Build the Service Line Fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N CNT,PRCODE,PRTYPE,SNODE0,SNODE1,SNODE12,Z
S ELINE=$$SET("",$J("",40),SLINE,1)
S ELINE=$$SETN("Service Lines",ELINE,1,1)
S (CNT,Z)=0 F S Z=$O(^IBT(356.22,IBTRIEN,16,Z)) Q:'Z!(Z?1.A) D
.S SNODE0=$G(^IBT(356.22,IBTRIEN,16,Z,0)),SNODE1=$G(^IBT(356.22,IBTRIEN,16,Z,1)),CNT=CNT+1
.S SNODE12=$G(^IBT(356.22,IBTRIEN,16,Z,12))
.S ELINE=$$SET("Service Line #: ",CNT,ELINE,1)
.S ELINE=$$SET("Date of Service: ",$$FMTE^XLFDT($P(SNODE0,U,11),5),ELINE,1)
.S PRTYPE=$P(SNODE1,U)
.S PRCODE=$S(PRTYPE="N4":$P(SNODE12,U),1:$$EXTERNAL^DILFD(356.2216,1.02,,$P(SNODE1,U,2)))
.S ELINE=$$SET("Procedure Code*: ",PRCODE,ELINE,1)
.Q
Q
;
BLDAPI(SLINE,ELINE) ; Build the Additional Patient Information Fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N ANODE0,Z
S ELINE=$$SET("",$J("",40),SLINE,41)
S ELINE=$$SETN("Paperwork Attachments",ELINE,41,1)
S Z=0 F S Z=$O(^IBT(356.22,IBTRIEN,11,Z)) Q:'Z!(Z?1.A) D
.S ANODE0=$G(^IBT(356.22,IBTRIEN,11,Z,0))
.S ELINE=$$SET("Report Type: ",$$GET1^DIQ(356.018,+$P(ANODE0,U)_",",.02),ELINE,41)
.S ELINE=$$SET("Transmission Method: ",$$EXTERNAL^DILFD(356.2211,.02,,$P(ANODE0,U,2)),ELINE,41)
.S ELINE=$$SET("Attachment Control Number: ",$P(ANODE0,U,3),ELINE,41)
.Q
Q
;
BLDCOM(SLINE,ELINE) ; Build the Comment Fields
; Input:
; SLINE - Starting Section Line Number
; ELINE - Current Ending Section Line Number
; Output: ELINE - Updated Ending Section Line Number
;
N XX
S ELINE=$$SET("",$J("",40),SLINE,1)
S ELINE=$$SETN("Request Comments",ELINE,1,1)
K ^UTILITY($J,"W")
D FORMAT^IBDFU6("^IBT(356.22,IBTRIEN,12)",80,"Message: ")
S XX=0 F S XX=$O(^UTILITY($J,"W",1,XX)) Q:XX="" S ELINE=$$SET("",$G(^UTILITY($J,"W",1,XX,0)),ELINE,1)
K ^UTILITY($J,"W")
Q
;
SET(LABEL,DATA,LINE,COL) ; Sets text into the body of the worklist
; Input: LABEL - Label text to set into the line
; DATA - Field Data to set into the line
; LINE - Line to set LABEL and DATA into
; COL - Starting column position in LINE to insert
; LABEL_DATA text
; Returns: LINE - Updated Line by 1
;
N IBY
S IBY=LABEL_DATA
D SET1(IBY,LINE,COL,$L(IBY))
S LINE=LINE+1
Q LINE
;
SETN(TITLE,LINE,COL,RV) ; Sets a field Section title into the body of the worklist
; Input: TITLE - Text to be used for the field Section Title
; LINE - Line number in the body to insert the field section title
; COL - Starting Column position to set Section Title into
; RV - 1 - Set Reverse Video, 0 or null don't use Reverse Video
; Optional, defaults to ""
; Returns: LINE - Line number increased by 1
;
N IBY
S IBY=" "_TITLE_" "
D SET1(IBY,LINE,COL,$L(IBY),$G(RV))
S LINE=LINE+1
Q LINE
;
SET1(TEXT,LINE,COL,WIDTH,RV) ; Sets the TMP array with body data
; Input: TEXT - Text to be set into the specified line
; LINE - Line to set TEXT into
; COL - Column of LINE to set TEXT into
; WIDTH - Width of the TEXT being set into line
; RV - 1 - Set Reverse Video, 0 or null don't use
; Reverse Video
; Optional, defaults to ""
; ^TMP("IBTRH6",$J) - Current ^TMP array
; Output: ^TMP("IBTRH6",$J) - Updated ^TMP array
;
N IBX
S IBX=$G(^TMP("IBTRH6",$J,LINE,0))
S IBX=$$SETSTR^VALM1(TEXT,IBX,COL,WIDTH)
D SET^VALM10(LINE,IBX)
D:$G(RV)'="" CNTRL^VALM10(LINE,COL,WIDTH,IORVON,IORVOFF)
Q
;
DATA ;EP
; Protocol action to add/edit fields for the brief 278 request fields
N DA,DIE,DR,DTOUT,IBPSTAT,IBUPOUT,X,Y
S VALMBCK="R"
S FROMDATA=1
D FULL^VALM1
I $$STATUS^IBTRH2(IBTRIEN)="0" D PRMARK1^IBTRH1(IBTRIEN,"01") ; Set 'in-progress mark'
; Set Initial Values
S IBPSTAT=$P(NODE0,U,4) ; Patient Status of the entry
;
S DA=IBTRIEN,DIE=356.22,DR="[IB CREATE 278 REQUEST SHORT]",IBUPOUT=0
D ^DIE
I +$G(IBUPOUT)!$D(Y) I "^01^03^"[(U_$$STATUS^IBTRH2(IBTRIEN)_U) D:$$CLRASK^IBTRH5K() CLRENTRY^IBTRH5K(IBTRIEN)
D CLEAN^VALM10,INIT^IBTRH6
Q
;
SEND278 ;EP
; Protocol action to send the completed brief 278 request
N IBRESP
S IBTRENT=1
S VALMBCK="R"
D SEND278^IBTRH2
Q
;
HELP ;EP
; Protocol Action to display help information
S X="?"
D DISP^XQORM1
W !!
Q
;
EXIT ;EP
; Protocol action to exit the worklist
K ^TMP("IBTRH6",$J)
D CLEAR^VALM1
Q
;
WRTFLDS ; auto populate some fields in 356.22
N DA,DIE,DR,DTOUT,DUOUT,DIRUT,RIEN,X,Y
S RIEN=+$P(NODE0,U,11) I 'RIEN S RIEN=DUZ D CLRCNUM(IBTRIEN)
S DIE=356.22,DA=IBTRIEN,DR="",DR=".11////"_RIEN
I $P(NODE2,U)="" D
.I INPAT,WHICH<3 S DR=DR_";2.01///AR" Q
.S DR=DR_";2.01///HS"
.Q
I $P(NODE2,U,3)="" S DR=DR_";2.03///"_$S(WHICH=1:"1",WHICH=2:"MH",1:"88")
I 'INPAT S DR=DR_";2.04////B" S:$P(NODE2,U,5)="" DR=DR_";2.05///22;2.06///@;2.07///@"
I INPAT S DR=DR_";2.04////A" S:$P(NODE2,U,6)="" DR=DR_";2.05///@;2.06////1;2.07////1"
I $P(NODE2,U,2)="" S DR=DR_";2.02///I"
I $P(NODE7,U)="" S DR=DR_";7.01///Urgent"
D ^DIE
Q
;
CLRCNUM(IBTRIEN) ; clear contact numbers in file 356.22
N FDA,FLD,IENS
S IENS=IBTRIEN_","
F FLD=19.01,19.02,19.03,20,21,22 S FDA(356.22,IENS,FLD)="@"
D FILE^DIE("ET","FDA")
Q
;
WRTCNUM ; auto populate contact numbers in file 356.22
N CNARY,FDA,FLD,IENS,IENS200,QUAL,RDATA,RIEN,STOPFLG,VALUE,Z
S RIEN=+$P($G(^IBT(356.22,IBTRIEN,0)),U,11) I 'RIEN Q
S IENS200=RIEN_"," D GETS^DIQ(200,IENS200,".131;.132;.135;.136",,"RDATA"),GETCNUM(.CNARY)
; loop through contact #s in file 200
S IENS=IBTRIEN_",",STOPFLG=0 F FLD=.135,.132,.136,.131 D Q:STOPFLG
.I '$D(CNARY("EMPTY")) S STOPFLG=1 Q ; no more empty comm. # fields in 356.22
.S VALUE=$$NOPUNCT^IBCEF($G(RDATA(200,IENS200,FLD)),1) I VALUE=""!($L(VALUE)>10) Q ; no value to file or value is too long
.S QUAL=$S(FLD=.136:"FX",1:"TE")
.I $G(CNARY(QUAL))'="" Q ; this type of comm # already exists in 356.22
.S Z=$O(CNARY("EMPTY",""))
.K FDA S FDA(356.22,IENS,$P(Z,U))=QUAL D FILE^DIE("E","FDA")
.K FDA S FDA(356.22,IENS,$P(Z,U,3))=VALUE D FILE^DIE("E","FDA")
.K CNARY("EMPTY",Z) S CNARY(QUAL)=VALUE
.Q
Q
;
GETCNUM(CNARY) ; get contact numbers from file 356.22
; CNARY - array of results, passed by reference
;
N QUAL,VALUE,Z
S CNARY=0 F Z="19.01^2^20","19.02^3^21","19.03^4^22" D
.S QUAL=$$EXTERNAL^DILFD(356.22,$P(Z,U),,$P(NODE19,U,$P(Z,U,2)))
.S VALUE=$G(^IBT(356.22,IBTRIEN,$P(Z,U,3)))
.I QUAL'="",VALUE'="" S CNARY(QUAL)=VALUE Q
.S CNARY("EMPTY",Z)=""
.Q
Q
;
NEWSL(IBTRIEN) ; create new entry in service line multiple (356.2216) if no entries are there
; IBTRIEN - ien of the entry in file 356.22
;
N DA,DD,DIC,DO,DINUM,DLAYGO,DTOUT,DUOUT,RES,X,Y
S RES=0 I '+$G(IBTRIEN) G NEWSLX
S RES=1 I '$D(^IBT(356.22,IBTRIEN,16,1)) D
.S DA(1)=IBTRIEN,DLAYGO=356.2216,DIC(0)="L",DIC="^IBT(356.22,"_DA(1)_",1,",X=1
.D FILE^DICN S RES=+Y K DD,DO
.Q
NEWSLX ;
Q RES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRH6 16934 printed Sep 23, 2025@20:04:40 Page 2
IBTRH6 ;ALB/FA - HCSR Send 278 Short Worklist ;11-NOV-2014
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;
+4 ;
EN ; Main entry point for the IBT HCSR SEND 278 SHORT worklist
+1 ; Displays the selected 278 short form for sending 278 requests
+2 ; Input: IBTRIEN - IEN of the selected entry to send a request for
+3 NEW FROMDATA,IBTRENT,INPAT,NODE2,NODE7,NODE19,VADM,WHICH
+4 ;;12/9/14 JWS - prevent entry if status is PENDING a response
+5 IF $$STATUS^IBTRH2(IBTRIEN)="07"
DO STATMSG^IBTRH2A(4)
QUIT
+6 SET VALMBCK="R"
+7 SET FROMDATA=0
+8 ; 1 if inpatient, 0 if outpatient
SET INPAT=$SELECT($PIECE(NODE0,U,4)="I":1,1:0)
+9 ; type of request
SET WHICH=$$SELSHORT(INPAT)
+10 IF WHICH'=""
DO EN^VALM("IBT HCSR SEND 278 SHORT")
+11 IF $DATA(IBFASTXT)
SET VALMBCK="Q"
+12 QUIT
+13 ;
SELSHORT(INPAT) ; User selection of which 278 request to send
+1 ; Input: INPAT=1 if inpatient, 0 otherwise
+2 ; Returns: Selected Input Type or "" if none selected
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XX,Y
+4 DO FULL^VALM1
+5 IF INPAT
SET XX="1:Admission (initial);2:Mental Health Inpatient (initial)"
+6 IF 'INPAT
SET XX="1:Appointment (initial);2:Mental Health Outpatient (initial)"
+7 SET XX=XX_";3:Prescription (initial)"
+8 SET DIR(0)="S^"_XX
SET DIR("A")="Select Input Type"
+9 DO ^DIR
+10 ; User Pressed ^ or timed out
if $DATA(DIRUT)
QUIT ""
+11 IF Y'=1
Begin DoDot:1
+12 WRITE !,"Mental Health and Prescription options are not currently available."
+13 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+14 SET DIR(0)="EA"
+15 SET DIR("A",1)=" "
+16 SET DIR("A")="Press RETURN to continue "
DO ^DIR
End DoDot:1
SET Y=""
+17 QUIT Y
+18 ;
HDR ;EP
+1 ; Protocol action to display Worklist Patient header information
+2 ; Input: IBTRIEN - IEN of the selected entry to send a request for
+3 ; Output: Header information for the patient of the selected entry is set
+4 ;
+5 NEW Z
+6 SET Z=$EXTRACT(VADM(1),1,28)
SET Z=Z_$JUSTIFY("",35-$LENGTH(Z))_$PIECE(VADM(2),U,2)_" DOB: "_$PIECE(VADM(3),U,2)_" AGE: "_VADM(4)
+7 SET VALMHDR(1)=Z
+8 SET VALMSG="*/Required"
+9 QUIT
+10 ;
INIT ;EP
+1 ;
+2 KILL ^TMP("IBTRH6",$JOB)
+3 SET VALMBG=1
+4 ; get patient demographics
DO DEM^VADPT
+5 SET NODE0=$GET(^IBT(356.22,IBTRIEN,0))
+6 SET NODE2=$GET(^IBT(356.22,IBTRIEN,2))
+7 SET NODE7=$GET(^IBT(356.22,IBTRIEN,7))
+8 SET NODE19=$GET(^IBT(356.22,IBTRIEN,19))
+9 ; auto populate fields
DO WRTFLDS
if 'FROMDATA
DO WRTCNUM
+10 ; re-read nodes to get auto-populated values
+11 SET NODE0=$GET(^IBT(356.22,IBTRIEN,0))
+12 SET NODE2=$GET(^IBT(356.22,IBTRIEN,2))
+13 SET NODE7=$GET(^IBT(356.22,IBTRIEN,7))
+14 SET NODE19=$GET(^IBT(356.22,IBTRIEN,19))
+15 DO BLD
+16 IF WHICH=1
SET VALM("TITLE")="HCSR 278 "_$SELECT(INPAT:"Admission",1:"Appointment")_" - Brief"
+17 IF WHICH=2
SET VALM("TITLE")="HCSR 278 Mental - Brief"
+18 IF WHICH=3
SET VALM("TITLE")="HCSR 278 Prescription - Brief"
+19 QUIT
+20 ;
BLD ; Creates the body of the worklist
+1 ;
+2 NEW ELINEL,ELINER,SLINE
+3 SET SLINE=1
+4 ; Build UMO Field section
DO BLDUMO(SLINE,.ELINEL)
+5 ; Build Subscriber Field section
DO BLDSUB(ELINEL,.ELINEL)
+6 ; Build Requester Field section
DO BLDREQ(SLINE,.ELINER)
+7 SET SLINE=$SELECT(ELINEL>ELINER:ELINEL,1:ELINER)
+8 ; Build Dependent Field section
DO BLDDEP(SLINE,.ELINEL)
+9 ; Build Diagnoses Field section
DO BLDDIAG(SLINE,.ELINER)
+10 SET SLINE=$SELECT(ELINEL>ELINER:ELINEL,1:ELINER)
+11 ; Build Health Care Services Field section
DO BLDHCSR(SLINE,.ELINEL)
+12 ; Build Provider Field section
DO BLDPROV(SLINE,.ELINER)
+13 SET SLINE=$SELECT(ELINEL>ELINER:ELINEL,1:ELINER)
+14 ; Build Service Line Field section
DO BLDSVC(SLINE,.ELINEL)
+15 ; Build API Line Field section
DO BLDAPI(SLINE,.ELINER)
+16 SET SLINE=$SELECT(ELINEL>ELINER:ELINEL,1:ELINER)
+17 ; Build Comment Field section
DO BLDCOM(SLINE,.ELINEL)
+18 SET VALMCNT=ELINEL-1
+19 QUIT
+20 ;
BLDUMO(SLINE,ELINE) ; Build the UMO Field Section
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW PAYER,PAYID
+7 ; Spacing Blank Line
SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,1)
+8 SET ELINE=$$SETN("UM Organization",ELINE,1,1)
+9 SET ELINE=$$SET("Name*: ",$$GET1^DIQ(36,IEN36_",",.01),ELINE,1)
+10 ; file 365.12 ien
SET PAYER=+$$GET1^DIQ(36,IEN36_",",3.1,"I")
+11 ; VA national id
SET PAYID=""
IF PAYER>0
SET PAYID=$PIECE($GET(^IBE(365.12,PAYER,0)),U,2)
+12 SET ELINE=$$SET("National Payer ID: ",PAYID,ELINE,1)
+13 SET ELINE=$$SET("HPID: ",$$HPD^IBCNHUT1(IEN36),ELINE,1)
+14 QUIT
+15 ;
BLDSUB(SLINE,ELINE) ; Build the Subscriber Fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW INSNODE3,ZIP
+7 SET INSNODE3=$GET(^DPT(DFN,.312,IEN312,3))
+8 ; Spacing Blank Line
SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,1)
+9 SET ELINE=$$SETN("Subscriber",ELINE,1,1)
+10 SET ELINE=$$SET("Name*: ",$PIECE(INSNODE0,U,17),ELINE,1)
+11 SET ELINE=$$SET("Primary ID*: ",$PIECE(INSNODE0,U,2),ELINE,1)
+12 SET ELINE=$$SET("Address Line 1: ",$PIECE(INSNODE3,U,6),ELINE,1)
+13 SET ELINE=$$SET("Address Line 2: ",$PIECE(INSNODE3,U,7),ELINE,1)
+14 SET ELINE=$$SET("City: ",$PIECE(INSNODE3,U,8),ELINE,1)
+15 SET ELINE=$$SET("State: ",$$GET1^DIQ(5,$PIECE(INSNODE3,U,9)_",",1),ELINE,1)
+16 SET ZIP=$PIECE(INSNODE3,U,10)
IF $LENGTH(ZIP)>5
IF $EXTRACT(ZIP,6)'="-"
SET ZIP=$EXTRACT(ZIP,1,5)_"-"_$EXTRACT(ZIP,6,99)
+17 SET ELINE=$$SET("Zip Code: ",ZIP,ELINE,1)
+18 QUIT
+19 ;
BLDREQ(SLINE,ELINE) ; Build the Requester fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW CNARY,REQIEN,REQSTR,REQDATA,ZIP
+7 SET REQIEN=$PIECE($$SITE^VASITE(),U)
SET REQSTR=$$PRVDATA^IBTRHLO2(REQIEN,4)
+8 DO GETCNUM(.CNARY)
+9 ; Spacing Blank Line
SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,41)
+10 SET ELINE=$$SETN("Requester",ELINE,41,1)
+11 SET ELINE=$$SET("Name*: ",$PIECE(REQSTR,U),ELINE,41)
+12 SET ELINE=$$SET("NPI*: ",$PIECE(REQSTR,U,7),ELINE,41)
+13 SET ELINE=$$SET("Taxonomy Code: ",$PIECE($$TAXORG^XUSTAX(REQIEN),U),ELINE,41)
+14 SET ELINE=$$SET("Address Line 1*: ",$PIECE(REQSTR,U,2),ELINE,41)
+15 SET ELINE=$$SET("Address Line 2: ",$PIECE(REQSTR,U,3),ELINE,41)
+16 SET ELINE=$$SET("City*: ",$PIECE(REQSTR,U,4),ELINE,41)
+17 SET ELINE=$$SET("State*: ",$$GET1^DIQ(5,$PIECE(REQSTR,U,5)_",",1),ELINE,41)
+18 SET ZIP=$PIECE(REQSTR,U,6)
IF $LENGTH(ZIP)>5
IF $EXTRACT(ZIP,6)'="-"
SET ZIP=$EXTRACT(ZIP,1,5)_"-"_$EXTRACT(ZIP,6,99)
+19 SET ELINE=$$SET("Zip Code*: ",ZIP,ELINE,41)
+20 SET ELINE=$$SET("Contact Name*: ",$$EXTERNAL^DILFD(356.22,.11,,$PIECE(NODE0,U,11)),ELINE,41)
+21 SET ELINE=$$SET("Contact Phone: ",$GET(CNARY("TE")),ELINE,41)
+22 SET ELINE=$$SET("Contact Phone Ext.: ",$GET(CNARY("EX")),ELINE,41)
+23 SET ELINE=$$SET("Contact Fax: ",$GET(CNARY("FX")),ELINE,41)
+24 QUIT
+25 ;
BLDDEP(SLINE,ELINE) ; Build the Dependent fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW INSNODE4
+7 SET INSNODE4=$GET(^DPT(DFN,.312,IEN312,4))
+8 ; pat. relationship is "self"
IF $PIECE(INSNODE4,U,3)="18"
QUIT
+9 SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,1)
+10 SET ELINE=$$SETN("Dependent",ELINE,1,1)
+11 SET ELINE=$$SET("Name*: ",VADM(1),ELINE,1)
+12 QUIT
+13 ;
BLDDIAG(SLINE,ELINE) ; Build the Diagnosis fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW DATA,DPTR,QPTR,Z
+7 SET ELINE=$$SET("",$JUSTIFY("",40),ELINE,41)
+8 SET ELINE=$$SETN("Diagnoses",ELINE,41,1)
+9 SET Z=0
FOR
SET Z=$ORDER(^IBT(356.22,IBTRIEN,3,Z))
if 'Z!(Z?1.A)
QUIT
Begin DoDot:1
+10 SET DATA=$GET(^IBT(356.22,IBTRIEN,3,Z,0))
IF DATA'=""
Begin DoDot:2
+11 SET QPTR=+$PIECE(DATA,U)
SET DPTR=$PIECE(DATA,U,2)
+12 SET ELINE=$$SET("Qualifier: ",$$GET1^DIQ(356.006,QPTR_",",.02),ELINE,41)
+13 SET ELINE=$$SET("Diagnosis: ",$$EXTERNAL^DILFD(356.223,.02,,DPTR),ELINE,41)
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
BLDHCSR(SLINE,ELINE) ; Build the Health Care Service Review Fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW Z
+7 SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,1)
+8 SET ELINE=$$SETN("Health Care Service Review",ELINE,1,1)
+9 SET ELINE=$$SET("Category*: ",$$GET1^DIQ(356.001,+$PIECE(NODE2,U)_",",.02),ELINE,1)
+10 SET ELINE=$$SET("Certification Type*: ",$$GET1^DIQ(356.002,+$PIECE(NODE2,U,2)_",",.02),ELINE,1)
+11 SET ELINE=$$SET("Service Type*: ",$$GET1^DIQ(365.013,+$PIECE(NODE2,U,3)_",",.02),ELINE,1)
+12 IF 'INPAT
SET ELINE=$$SET("Facility Type*: ",$$GET1^DIQ(353.1,+$PIECE(NODE2,U,5)_",",.02),ELINE,1)
+13 IF INPAT
Begin DoDot:1
+14 SET Z=$PIECE(NODE2,U,6)_$PIECE(NODE2,U,7)
+15 IF Z="11"
SET ELINE=$$SET("Bill Type*: ","HOSPITAL/INPATIENT",ELINE,1)
+16 SET ELINE=$$SET("Adm Type: ",$$EXTERNAL^DILFD(356.22,7.01,,$PIECE(NODE7,U)),ELINE,1)
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
BLDPROV(SLINE,ELINE) ; Build the Provider Information Fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW DATA,PRVDATA,PRVPTR,Z
+7 SET ELINE=$$SET("",$JUSTIFY("",40),ELINE,41)
+8 SET ELINE=$$SETN("Provider Information",ELINE,41,1)
+9 SET Z=0
FOR
SET Z=$ORDER(^IBT(356.22,IBTRIEN,13,Z))
if 'Z!(Z?1.A)
QUIT
Begin DoDot:1
+10 SET DATA=$GET(^IBT(356.22,IBTRIEN,13,Z,0))
IF DATA'=""
Begin DoDot:2
+11 SET PRVPTR=$PIECE(DATA,U,3)
SET PRVDATA=$$PRVDATA^IBTRHLO2(+$PIECE(PRVPTR,";"),$PIECE($PIECE(PRVPTR,"(",2),","))
+12 SET ELINE=$$SET("Provider Type: ",$$GET1^DIQ(365.022,$PIECE(DATA,U)_",",.02),ELINE,41)
+13 SET ELINE=$$SET("Provider Name: ",$PIECE(PRVDATA,U),ELINE,41)
+14 SET ELINE=$$SET("Provider NPI: ",$PIECE(PRVDATA,U,7),ELINE,41)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
BLDSVC(SLINE,ELINE) ; Build the Service Line Fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW CNT,PRCODE,PRTYPE,SNODE0,SNODE1,SNODE12,Z
+7 SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,1)
+8 SET ELINE=$$SETN("Service Lines",ELINE,1,1)
+9 SET (CNT,Z)=0
FOR
SET Z=$ORDER(^IBT(356.22,IBTRIEN,16,Z))
if 'Z!(Z?1.A)
QUIT
Begin DoDot:1
+10 SET SNODE0=$GET(^IBT(356.22,IBTRIEN,16,Z,0))
SET SNODE1=$GET(^IBT(356.22,IBTRIEN,16,Z,1))
SET CNT=CNT+1
+11 SET SNODE12=$GET(^IBT(356.22,IBTRIEN,16,Z,12))
+12 SET ELINE=$$SET("Service Line #: ",CNT,ELINE,1)
+13 SET ELINE=$$SET("Date of Service: ",$$FMTE^XLFDT($PIECE(SNODE0,U,11),5),ELINE,1)
+14 SET PRTYPE=$PIECE(SNODE1,U)
+15 SET PRCODE=$SELECT(PRTYPE="N4":$PIECE(SNODE12,U),1:$$EXTERNAL^DILFD(356.2216,1.02,,$PIECE(SNODE1,U,2)))
+16 SET ELINE=$$SET("Procedure Code*: ",PRCODE,ELINE,1)
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
BLDAPI(SLINE,ELINE) ; Build the Additional Patient Information Fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW ANODE0,Z
+7 SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,41)
+8 SET ELINE=$$SETN("Paperwork Attachments",ELINE,41,1)
+9 SET Z=0
FOR
SET Z=$ORDER(^IBT(356.22,IBTRIEN,11,Z))
if 'Z!(Z?1.A)
QUIT
Begin DoDot:1
+10 SET ANODE0=$GET(^IBT(356.22,IBTRIEN,11,Z,0))
+11 SET ELINE=$$SET("Report Type: ",$$GET1^DIQ(356.018,+$PIECE(ANODE0,U)_",",.02),ELINE,41)
+12 SET ELINE=$$SET("Transmission Method: ",$$EXTERNAL^DILFD(356.2211,.02,,$PIECE(ANODE0,U,2)),ELINE,41)
+13 SET ELINE=$$SET("Attachment Control Number: ",$PIECE(ANODE0,U,3),ELINE,41)
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
BLDCOM(SLINE,ELINE) ; Build the Comment Fields
+1 ; Input:
+2 ; SLINE - Starting Section Line Number
+3 ; ELINE - Current Ending Section Line Number
+4 ; Output: ELINE - Updated Ending Section Line Number
+5 ;
+6 NEW XX
+7 SET ELINE=$$SET("",$JUSTIFY("",40),SLINE,1)
+8 SET ELINE=$$SETN("Request Comments",ELINE,1,1)
+9 KILL ^UTILITY($JOB,"W")
+10 DO FORMAT^IBDFU6("^IBT(356.22,IBTRIEN,12)",80,"Message: ")
+11 SET XX=0
FOR
SET XX=$ORDER(^UTILITY($JOB,"W",1,XX))
if XX=""
QUIT
SET ELINE=$$SET("",$GET(^UTILITY($JOB,"W",1,XX,0)),ELINE,1)
+12 KILL ^UTILITY($JOB,"W")
+13 QUIT
+14 ;
SET(LABEL,DATA,LINE,COL) ; Sets text into the body of the worklist
+1 ; Input: LABEL - Label text to set into the line
+2 ; DATA - Field Data to set into the line
+3 ; LINE - Line to set LABEL and DATA into
+4 ; COL - Starting column position in LINE to insert
+5 ; LABEL_DATA text
+6 ; Returns: LINE - Updated Line by 1
+7 ;
+8 NEW IBY
+9 SET IBY=LABEL_DATA
+10 DO SET1(IBY,LINE,COL,$LENGTH(IBY))
+11 SET LINE=LINE+1
+12 QUIT LINE
+13 ;
SETN(TITLE,LINE,COL,RV) ; Sets a field Section title into the body of the worklist
+1 ; Input: TITLE - Text to be used for the field Section Title
+2 ; LINE - Line number in the body to insert the field section title
+3 ; COL - Starting Column position to set Section Title into
+4 ; RV - 1 - Set Reverse Video, 0 or null don't use Reverse Video
+5 ; Optional, defaults to ""
+6 ; Returns: LINE - Line number increased by 1
+7 ;
+8 NEW IBY
+9 SET IBY=" "_TITLE_" "
+10 DO SET1(IBY,LINE,COL,$LENGTH(IBY),$GET(RV))
+11 SET LINE=LINE+1
+12 QUIT LINE
+13 ;
SET1(TEXT,LINE,COL,WIDTH,RV) ; Sets the TMP array with body data
+1 ; Input: TEXT - Text to be set into the specified line
+2 ; LINE - Line to set TEXT into
+3 ; COL - Column of LINE to set TEXT into
+4 ; WIDTH - Width of the TEXT being set into line
+5 ; RV - 1 - Set Reverse Video, 0 or null don't use
+6 ; Reverse Video
+7 ; Optional, defaults to ""
+8 ; ^TMP("IBTRH6",$J) - Current ^TMP array
+9 ; Output: ^TMP("IBTRH6",$J) - Updated ^TMP array
+10 ;
+11 NEW IBX
+12 SET IBX=$GET(^TMP("IBTRH6",$JOB,LINE,0))
+13 SET IBX=$$SETSTR^VALM1(TEXT,IBX,COL,WIDTH)
+14 DO SET^VALM10(LINE,IBX)
+15 if $GET(RV)'=""
DO CNTRL^VALM10(LINE,COL,WIDTH,IORVON,IORVOFF)
+16 QUIT
+17 ;
DATA ;EP
+1 ; Protocol action to add/edit fields for the brief 278 request fields
+2 NEW DA,DIE,DR,DTOUT,IBPSTAT,IBUPOUT,X,Y
+3 SET VALMBCK="R"
+4 SET FROMDATA=1
+5 DO FULL^VALM1
+6 ; Set 'in-progress mark'
IF $$STATUS^IBTRH2(IBTRIEN)="0"
DO PRMARK1^IBTRH1(IBTRIEN,"01")
+7 ; Set Initial Values
+8 ; Patient Status of the entry
SET IBPSTAT=$PIECE(NODE0,U,4)
+9 ;
+10 SET DA=IBTRIEN
SET DIE=356.22
SET DR="[IB CREATE 278 REQUEST SHORT]"
SET IBUPOUT=0
+11 DO ^DIE
+12 IF +$GET(IBUPOUT)!$DATA(Y)
IF "^01^03^"[(U_$$STATUS^IBTRH2(IBTRIEN)_U)
if $$CLRASK^IBTRH5K()
DO CLRENTRY^IBTRH5K(IBTRIEN)
+13 DO CLEAN^VALM10
DO INIT^IBTRH6
+14 QUIT
+15 ;
SEND278 ;EP
+1 ; Protocol action to send the completed brief 278 request
+2 NEW IBRESP
+3 SET IBTRENT=1
+4 SET VALMBCK="R"
+5 DO SEND278^IBTRH2
+6 QUIT
+7 ;
HELP ;EP
+1 ; Protocol Action to display help information
+2 SET X="?"
+3 DO DISP^XQORM1
+4 WRITE !!
+5 QUIT
+6 ;
EXIT ;EP
+1 ; Protocol action to exit the worklist
+2 KILL ^TMP("IBTRH6",$JOB)
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
WRTFLDS ; auto populate some fields in 356.22
+1 NEW DA,DIE,DR,DTOUT,DUOUT,DIRUT,RIEN,X,Y
+2 SET RIEN=+$PIECE(NODE0,U,11)
IF 'RIEN
SET RIEN=DUZ
DO CLRCNUM(IBTRIEN)
+3 SET DIE=356.22
SET DA=IBTRIEN
SET DR=""
SET DR=".11////"_RIEN
+4 IF $PIECE(NODE2,U)=""
Begin DoDot:1
+5 IF INPAT
IF WHICH<3
SET DR=DR_";2.01///AR"
QUIT
+6 SET DR=DR_";2.01///HS"
+7 QUIT
End DoDot:1
+8 IF $PIECE(NODE2,U,3)=""
SET DR=DR_";2.03///"_$SELECT(WHICH=1:"1",WHICH=2:"MH",1:"88")
+9 IF 'INPAT
SET DR=DR_";2.04////B"
if $PIECE(NODE2,U,5)=""
SET DR=DR_";2.05///22;2.06///@;2.07///@"
+10 IF INPAT
SET DR=DR_";2.04////A"
if $PIECE(NODE2,U,6)=""
SET DR=DR_";2.05///@;2.06////1;2.07////1"
+11 IF $PIECE(NODE2,U,2)=""
SET DR=DR_";2.02///I"
+12 IF $PIECE(NODE7,U)=""
SET DR=DR_";7.01///Urgent"
+13 DO ^DIE
+14 QUIT
+15 ;
CLRCNUM(IBTRIEN) ; clear contact numbers in file 356.22
+1 NEW FDA,FLD,IENS
+2 SET IENS=IBTRIEN_","
+3 FOR FLD=19.01,19.02,19.03,20,21,22
SET FDA(356.22,IENS,FLD)="@"
+4 DO FILE^DIE("ET","FDA")
+5 QUIT
+6 ;
WRTCNUM ; auto populate contact numbers in file 356.22
+1 NEW CNARY,FDA,FLD,IENS,IENS200,QUAL,RDATA,RIEN,STOPFLG,VALUE,Z
+2 SET RIEN=+$PIECE($GET(^IBT(356.22,IBTRIEN,0)),U,11)
IF 'RIEN
QUIT
+3 SET IENS200=RIEN_","
DO GETS^DIQ(200,IENS200,".131;.132;.135;.136",,"RDATA")
DO GETCNUM(.CNARY)
+4 ; loop through contact #s in file 200
+5 SET IENS=IBTRIEN_","
SET STOPFLG=0
FOR FLD=.135,.132,.136,.131
Begin DoDot:1
+6 ; no more empty comm. # fields in 356.22
IF '$DATA(CNARY("EMPTY"))
SET STOPFLG=1
QUIT
+7 ; no value to file or value is too long
SET VALUE=$$NOPUNCT^IBCEF($GET(RDATA(200,IENS200,FLD)),1)
IF VALUE=""!($LENGTH(VALUE)>10)
QUIT
+8 SET QUAL=$SELECT(FLD=.136:"FX",1:"TE")
+9 ; this type of comm # already exists in 356.22
IF $GET(CNARY(QUAL))'=""
QUIT
+10 SET Z=$ORDER(CNARY("EMPTY",""))
+11 KILL FDA
SET FDA(356.22,IENS,$PIECE(Z,U))=QUAL
DO FILE^DIE("E","FDA")
+12 KILL FDA
SET FDA(356.22,IENS,$PIECE(Z,U,3))=VALUE
DO FILE^DIE("E","FDA")
+13 KILL CNARY("EMPTY",Z)
SET CNARY(QUAL)=VALUE
+14 QUIT
End DoDot:1
if STOPFLG
QUIT
+15 QUIT
+16 ;
GETCNUM(CNARY) ; get contact numbers from file 356.22
+1 ; CNARY - array of results, passed by reference
+2 ;
+3 NEW QUAL,VALUE,Z
+4 SET CNARY=0
FOR Z="19.01^2^20","19.02^3^21","19.03^4^22"
Begin DoDot:1
+5 SET QUAL=$$EXTERNAL^DILFD(356.22,$PIECE(Z,U),,$PIECE(NODE19,U,$PIECE(Z,U,2)))
+6 SET VALUE=$GET(^IBT(356.22,IBTRIEN,$PIECE(Z,U,3)))
+7 IF QUAL'=""
IF VALUE'=""
SET CNARY(QUAL)=VALUE
QUIT
+8 SET CNARY("EMPTY",Z)=""
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
NEWSL(IBTRIEN) ; create new entry in service line multiple (356.2216) if no entries are there
+1 ; IBTRIEN - ien of the entry in file 356.22
+2 ;
+3 NEW DA,DD,DIC,DO,DINUM,DLAYGO,DTOUT,DUOUT,RES,X,Y
+4 SET RES=0
IF '+$GET(IBTRIEN)
GOTO NEWSLX
+5 SET RES=1
IF '$DATA(^IBT(356.22,IBTRIEN,16,1))
Begin DoDot:1
+6 SET DA(1)=IBTRIEN
SET DLAYGO=356.2216
SET DIC(0)="L"
SET DIC="^IBT(356.22,"_DA(1)_",1,"
SET X=1
+7 DO FILE^DICN
SET RES=+Y
KILL DD,DO
+8 QUIT
End DoDot:1
NEWSLX ;
+1 QUIT RES
