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

IBTRH6.m

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