IBTRH5C ;ALB/FA - HCSR Create 278 Request ;12-AUG-2014
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;;
; Contains Entry points and functions used in creating a 278 request from a
; selected entry in the HCSR Response worklist
;
; -------------------------- Entry Points --------------------------------
; AMBTI - Called from within the input template to see if any of the
; Ambulance Transport Information fields have a value
; Fields: 18.01, 18.02, 18.03, 18.04, 18.05, 18.06, 18.09, 18.1
; ATTPHY - Returns the Attending Physician of the entry
; CERTCD - Dictionary Screen function for Certification Type Code (2.02)
; CONTPH - Input Validation method for fields 20, 21, 22
; CRTENTRY - Creates a new worklist entry from a specified worklist entry.
; Copies all the request data from the specified entry into the
; new entry
; OXYET - Called from within the input template to determine if one of
; Oxygen Equipment Type fields = 'D' or 'E'. Fields 8.01, 8.02
; 8.03
; REQCAT - Dictionary Screen function for Request Category Field 2.01
; and field 356.2216/.15
; SLDXDUP - Dictionary Screen function for Service Line Diagnosis fields
; Checks to insure the diagnosis is NOT a duplicate entry AND
; points to a valid diagnosis multiple.
; Fields: 2216,2.01, 2216,2.02, 2216,2.03, 2216,2.04
; TOOTHSP - Called from within the Input Template to check if subsequent
; Tooth Surfaces have values
;-----------------------------------------------------------------------------
;
CONTPH(FIELD) ;EP
; Input validation method for Requester Contact Numbers 1,2 and 3 (fields 20,
; 21 and 22)
; Input: FIELD - Requester Contact Number field being validated
; DA - IEN of the 356.22 entry being edited
; X - Internal Value of the user response
; Output: None
; Returns: 1 - Answer is valid, 0 - Otherwise
N RETURN,TYPE,XX
S XX=$S(FIELD=20:19.01,FIELD=21:19.02,FIELD=22:19.03,1:0)
Q:XX=0 0 ; Invalid FIELD
S RETURN=1 ; Assume valid
S TYPE=$$GET1^DIQ(356.22,DA_",",XX,"I") ; Requester Contact Qualifier
S TYPE=$$GET1^DIQ(365.021,TYPE_",",.01) ; Requester Contact Qualifier Code
;
I (TYPE="ED")!(TYPE="EM")!(TYPE="UR")!(TYPE="EX") D Q RETURN
. S RETURN=$S($L(X)'>250:1,1:0)
S XX=$TR(X,"-","") ; Remove dashes
I XX'?10N S RETURN=0
Q RETURN
;
CRTENTRY(IBTRIEN,RIEN,IEN312,REQBY,DELCCDE,DELAY,NOOUTPUT,TTYPE) ;EP
; Creates a new entry in 356.22 by copying fields from an existing entry. Used
; to create a request from a Response by copying the request entry pointed to
; from the response entry
; Input: IBTRIEN - IEN of the entry to be copied
; RIEN - IEN of the response entry
; IEN312 - IEN of the insurance multiple to set into field .03
; Optional, if not passed, this field is copied from the
; existing entry
; REQBY - DUZ of the Requested By user to set into field .11
; Optional, if not passed, this field is copied from the
; existing entry
; DELCCDE - 1 to clear the value for Certification Type (field 2.02)
; Optional, if not passed, defaults to 0
; DELAY - 'D' or a future date to set a next review date and status
; to '08'
; Optional, if not passed, defaults to ""
; NOOUTPUT - suppress error message output, if not passed, defaults to 0 (false)
; TTYPE - UM02 value for 278x215 if cancel
;
; Output: New entry created in 356.22
; Returns: 0 - Copy was NOT successful and error messages were displayed
; Otherwise, IEN of the new entry in 356.22 is returned
N ERROR,FLDS,IENARRY,IENS,NEWENTRY,NIENS,NIENS16,OLDENTRY,STOPFLG,XX,Z,Z1,XX1
S:'$D(NOOUTPUT) NOOUTPUT=0
S:'$D(IEN312) IEN312=""
S:'$D(REQBY) REQBY=""
S:'$D(DELCCDE) DELCCDE=0
S:'$D(DELAY) DELAY=""
S IENS=IBTRIEN_","
S FLDS=".02;.03:.07;.11;.16;2.01:2.25;3*;4.01:4.14;5.01:5.18;6.01:6.18"
S FLDS=FLDS_";7.01:7.13;8.01:8.08;9.01:9.08;10.01:10.13;11*;12;14*;15*;18.01:18.1;19.01:19.03;20:22"
D GETS^DIQ(356.22,IENS,FLDS,"NI","OLDENTRY","ERROR")
I $D(ERROR) D COPYERR(0,.ERROR) Q 0 ; Unsuccessful read of initial entry
;
; Copy internal data from the specified entry to a new array
M NEWENTRY(356.22,"+1,")=OLDENTRY(356.22,IENS)
D COPYINT(.NEWENTRY)
;
; Set the Event Date to 'NOW'
S NEWENTRY(356.22,"+1,",.01)=$$NOW^XLFDT()
S:IEN312'="" NEWENTRY(356.22,"+1,",.03)=IEN312 ; Set Insurance Multiple IEN
S NEWENTRY(356.22,"+1,",.08)=$S(DELAY'="":"08",1:0) ; Initialize status to 0
S:REQBY'="" NEWENTRY(356.22,"+1,",.11)=REQBY
I DELCCDE D
. S NEWENTRY(356.22,"+1,",2.02)="" ; Clear Certification Type field
. S NEWENTRY(356.22,"+1,",.18)=1 ; Flag creation from Response
I $G(TTYPE)="C" S NEWENTRY(356.22,"+1,",2.02)=3
S:DELAY'="" NEWENTRY(356.22,"+1,",.17)=DELAY ; Delayed until DELAY
S XX=$$GET1^DIQ(356.22,RIEN_",",103.02) ; Auth. or Ref. number from response
S XX1=$$GET1^DIQ(356.22,RIEN_",",103.01) ; CERT ACT CODE
I $F(",A1,A2,A6,",","_XX1_",") S NEWENTRY(356.22,"+1,",17.01)=XX
I $F(",A3,A4,C,CT,NA,",","_XX1_",") D
. I XX="" S XX=$$GET1^DIQ(356.22,RIEN_",",17.02)
. S NEWENTRY(356.22,"+1,",17.02)=XX
K IENARRY
D UPDATE^DIE(,"NEWENTRY","IENARRY","ERROR") ; File the initial data
I $D(ERROR) D COPYERR(1,.ERROR) Q 0 ; Unsuccessful copy of initial data
; update field .27 of response message
I DELCCDE D I $D(ERROR) D COPYERR(1,.ERROR) Q 0
. N UPDRSP
. S UPDRSP(356.22,RIEN_",",.27)=1
. D FILE^DIE("I","UPDRSP","ERROR")
. Q
;
; Next copy multiples IENs of the new entry in 356.22 (top level)
S NIENS=IENARRY(1)_","
;
; File Diagnosis multiples (356.223)
I '$$MLTCPY(356.223,NIENS) Q 0
;
; File Attachment multiples (356.2211)
I '$$MLTCPY(356.2211,NIENS) Q 0
;
; File Patient Event Transport multiples (356.2214)
I '$$MLTCPY(356.2214,NIENS) Q 0
;
; File Other UMO multiples (356.2215)
I '$$MLTCPY(356.2215,NIENS) Q 0
;
; File Provider multiples (356.2213)
; NOTE: not all fields are being copied, each entry needs to be handled separately
S Z=0,STOPFLG=0
F D Q:'Z!STOPFLG
. S Z=$O(^IBT(356.22,IBTRIEN,13,Z))
. Q:'Z
. S IENS=Z_","_IBTRIEN_","
. K NEWENTRY,OLDENTRY
. D GETS^DIQ(356.2213,IENS,".01:.03","NI","OLDENTRY","ERROR")
. I $D(ERROR) D COPYERR(0,.ERROR) S STOPFLG=1 Q
. M NEWENTRY(356.2213,"+1,"_NIENS)=OLDENTRY(356.2213,IENS)
. D COPYINT(.NEWENTRY)
. D UPDATE^DIE(,"NEWENTRY",,"ERROR")
. I $D(ERROR) D COPYERR(1,.ERROR) S STOPFLG=1
Q:STOPFLG 0
;
; File Service Line multiples (356.2216)
; NOTE: not all fields are being copied, each entry needs to be handled separately
S Z=0,STOPFLG=0
F D Q:'Z!STOPFLG
. S Z=$O(^IBT(356.22,IBTRIEN,16,Z))
. Q:'Z
. S IENS=Z_","_IBTRIEN_","
. K OLDENTRY
. S FLDS=".01:.14;1.01:1.12;2.01:2.09;3.01:3.07;4*;5.01:5.08;6*;7"
. D GETS^DIQ(356.2216,IENS,FLDS,"NI","OLDENTRY","ERROR")
. I $D(ERROR) D COPYERR(0,.ERROR) S STOPFLG=1 Q
. K NEWENTRY
. M NEWENTRY(356.2216,"+1,"_NIENS)=OLDENTRY(356.2216,IENS)
. D COPYINT(.NEWENTRY)
. K IENARRY
. D UPDATE^DIE(,"NEWENTRY","IENARRY","ERROR")
. I $D(ERROR) D COPYERR(1,.ERROR) S STOPFLG=1
. S NIENS16=IENARRY(1)_","_NIENS ; IENs of the new Service Line in 356.2216
. ;
. ; File Service Line Tooth Information multiples (356.22164)
. I '$$MLTCPY(356.22164,NIENS16) S STOPFLG=1 Q
. ;
. ; File Service Line Attachment multiple (356.22166)
. I '$$MLTCPY(356.22166,NIENS16) S STOPFLG=1 Q
. ;
. ; File Service Line Provider Data multiples (356.22168)
. ; NOTE - not all fields are being copied, each entry needs to be handled separately
. S Z1=0
. F D Q:'Z1!STOPFLG
. . S Z1=$O(^IBT(356.22,IBTRIEN,16,Z,8,Z1))
. . Q:'Z1
. . S IENS=Z1_","_Z_","_IBTRIEN_","
. . K NEWENTRY,OLDENTRY
. . D GETS^DIQ(356.22168,IENS,".01:.03","NI","OLDENTRY","ERROR")
. . I $D(ERROR) D COPYERR(0,.ERROR) S STOPFLG=1 Q
. . M NEWENTRY(356.22168,"+1,"_NIENS16)=OLDENTRY(356.22168,IENS)
. . D COPYINT(.NEWENTRY)
. . D UPDATE^DIE(,"NEWENTRY",,"ERROR")
. . I $D(ERROR) D COPYERR(1,.ERROR) S STOPFLG=1
I STOPFLG Q 0
Q $P(NIENS,",",1)
;
COPYERR(TYPE,ERROR) ; Displays any errors encountered while copying a request
; Input: TYPE - 0 - Error while reading data
; - 1 - Error while filing data
; ERROR - Array used for FM error reporting
; Output: Error(s) are displayed
I '$G(NOOUTPUT) Q ;IF NOT TO DISPLAY OUTPUT, for background job
N STR,Z,Z1
Q:'$D(ERROR)
W !,"Unable to copy - the following error was encountered while "
W $S(TYPE:"filing",1:"retrieving")," the data:"
S Z=0
F D Q:'Z
. S Z=$O(ERROR("DIERR",Z))
. Q:'Z
. S STR=$G(ERROR("DIERR",Z))
. W:STR'="" !,"Error code: "_STR
. S STR=$G(ERROR("DIERR",Z,"PARAM","FILE"))
. W:STR'="" !,"File number: "_STR
. S STR=$G(ERROR("DIERR",Z,"PARAM","FIELD"))
. W:STR'="" !,"Field number: "_STR
. W !,"Error text:"
. S Z1=0
. F D Q:'Z1
. . S Z1=$O(ERROR("DIERR",1,"TEXT",Z1))
. . Q:'Z1
. . W !,ERROR("DIERR",1,"TEXT",Z1)
Q
;
MLTCPY(SFNUM,NEWIENS) ; Copies the specified multiple
; Input: SFNUM - Sub-file number of the multiple to copy
; NIENS - IENs of the new entry (copied to)
; OLDENTRY - FDA array to get data from (defined in the calling tag)
; Returns: 1 on successful copy, 0 on failure
;
N ERROR,NEWENTRY,RES,STOPFLG,Z
S RES=1,STOPFLG=0
S Z=0
F D Q:'Z!STOPFLG
. S Z=$O(OLDENTRY(SFNUM,Z))
. Q:'Z
. K NEWENTRY
. M NEWENTRY(SFNUM,"+1,"_NEWIENS)=OLDENTRY(SFNUM,Z)
. D COPYINT(.NEWENTRY)
. D UPDATE^DIE(,"NEWENTRY",,"ERROR")
. I $D(ERROR) D COPYERR(1) S STOPFLG=1,RES=0
Q RES
;
COPYINT(NEW) ; Copies an array of internal values to a new array
; Input: NEW - Current Array of internal values
; Retrieved using D GETS^DIQ(356.22,IENS,FLDS,"NI","OLD","ERROR")
; e.g. NEW(356.223,"+1,19,",.02,"I")=7209320
; Output: NEW - Updated array of internal values, stripping off the "I" subscript
; e.g. NEW(356.223,"+1,19,",.02)=7209320
N ARRAY,NEW2,YY
S ARRAY="NEW("""")"
F D Q:ARRAY=""
. S ARRAY=$Q(@ARRAY)
. Q:ARRAY=""
. I ARRAY[",""I"")" D Q
. . S YY=$P(ARRAY,",""I"")",1)_")"
. . S YY="NEW2("_$P(YY,"(",2)
. . S @YY=@ARRAY
. S YY="NEW2("_$P(ARRAY,"(",2)
. S @YY=@ARRAY
K NEW
M NEW=NEW2
Q
;
OXYET(IBTRIEN) ;EP
; Called from within the input template
; Checks to see if any of the currently filed Oxygen Equipment
; Types have a value of 'D' or 'E'
; Input: IBTRIEN - IEN of the Patient Event
; Returns: 1 - at least one of the Oxygen Equipment Types is 'D' or 'E'
; 0 Otherwise
N NDE
S NDE=$G(^IBT(356.22,IBTRIEN,8))
I ($P(NDE,"^",1)=4)!($P(NDE,"^",1)=5) Q 1
I ($P(NDE,"^",2)=4)!($P(NDE,"^",2)=5) Q 1
I ($P(NDE,"^",3)=4)!($P(NDE,"^",3)=5) Q 1
Q 0
;
ATTPHY(IBTRIEN) ;EP
; Returns the Attending Physician for the admission of the
; specified Inpatient event
; Input: IBTRIEN - IEN of the Inpatient Event
; Returns: IEN in file 200 of the Attending Physician or ""
N ADATE,DA,DFN,DT,EVENT,FOUND,IADATE
S EVENT=$G(^IBT(356.22,IBTRIEN,0))
S DFN=$P(EVENT,"^",2) ; DFN of the patient
S ADATE=$P($P(EVENT,"^",7),"-",1) ; Internal Admit date
S IADATE=9999999.9999999-ADATE
S DA=$O(^DGPM("ATID1",DFN,IADATE,"")) ; DBIA419
Q:DA="" "" ; No Patient Movement admission record
Q $$GET1^DIQ(405,DA_",",.19,"I")
;
REQCAT(FIELD) ;EP
; Dictionary Screen for Request Category (2.01)
; Checks the Request Category (2.01 OR 356.2216/.15) to make sure the answer
; is valid for the event type
; Input: FIELD - Only passed when called from 356.2216/.15
; DA - IEN of the 356.22 entry being edited
; Y - Internal Value of the user response
; Output: None
; Returns: 1 - Answer is valid, 0 - Otherwise
N RETURN,STAT
I $D(FIELD) D Q RETURN
. S RETURN=1
. I Y'=2,Y'=4 S RETURN=0
;
S STAT=$P($G(^IBT(356.22,DA,0)),"^",4)
I STAT="I",Y'=1 Q 0
I STAT="O",Y=1 Q 0
Q 1
;
CERTCD() ;EP
; Dictionary screen for field Certification Type Code 2.02
; Checks the code to make sure the answer is valid for the event type
; Input: DA - IEN of the 356.22 entry being edited
; Y - Internal Value of the user response
; Output: None
; Returns: 1 - Answer is valid, 0 - Otherwise
N FREP
I '$F(",3,5,",","_Y_",") Q 0
S FREP=$P($G(^IBT(356.22,DA,0)),"^",18)
I FREP=1,Y=5 Q 0
Q 1
;
AMBTI(IBTRIEN) ;EP
; Called from Input Template IB CREATE 278 REQUEST to check if any of the
; Ambulance Transport Information fields has a value. Used to potentially
; skip to potentially skip the Patient Event Transport Information questions
; Input: IBTRIEN - IEN of the 356.22 entry being edited
; Returns: 1 - At least one field has a value, 0 otherwise
N NDE
S NDE=$G(^IBT(356.22,IBTRIEN,18))
I $P(NDE,"^",1)'="" Q 1
I $P(NDE,"^",2)'="" Q 1
I $P(NDE,"^",3)'="" Q 1
I $P(NDE,"^",4)'="" Q 1
I $P(NDE,"^",5)'="" Q 1
I $P(NDE,"^",6)'="" Q 1
I $P(NDE,"^",9)'="" Q 1
I $P(NDE,"^",10)'="" Q 1
Q 0
;
SLDXDUP(FIELD) ;EP
; Dictionary Screen Function
; Checks to see if the specified Service Line Diagnosis is a duplicate entry
; AND points to valid Diagnosis multiple.
; Fields: 2216,2.01, 2216,2.02, 2216,2.03, 2216,2.04
; Input: FIELD - Field number of the field being checked
; DA(1) - IEN of the 356.22 entry being edited
; DA - IEN of the service line multiple
; Y - Internal Value of the user response
; Output: None
; Returns: 1 - Answer is valid, 0 - Otherwise
N NDE,RETURN
S RETURN=1 ; Assume Valid Input
Q:Y="" 1 ; No value entered
;
; Not a valid service line multiple
I '$D(^IBT(356.22,DA(1),3,Y,0)) Q 0
;
; Check for duplicates
S NDE=$G(^IBT(356.22,DA(1),16,DA,2))
I FIELD="2.01" D Q RETURN
. I $P(NDE,"^",2)=Y S RETURN=0 Q
. I $P(NDE,"^",3)=Y S RETURN=0 Q
. I $P(NDE,"^",4)=Y S RETURN=0 Q
I FIELD="2.02" D Q RETURN
. I $P(NDE,"^",1)=Y S RETURN=0 Q
. I $P(NDE,"^",3)=Y S RETURN=0 Q
. I $P(NDE,"^",4)=Y S RETURN=0 Q
I FIELD="2.03" D Q RETURN
. I $P(NDE,"^",1)=Y S RETURN=0 Q
. I $P(NDE,"^",2)=Y S RETURN=0 Q
. I $P(NDE,"^",4)=Y S RETURN=0 Q
I FIELD="2.04" D Q RETURN
. I $P(NDE,"^",1)=Y S RETURN=0 Q
. I $P(NDE,"^",2)=Y S RETURN=0 Q
. I $P(NDE,"^",3)=Y S RETURN=0 Q
Q 1
;
TOOTHSP(FIELD) ;EP
; Called from Input Template IB CREATE 278 REQUEST for Service Line Tooth
; Surface fields. Checks to see if subsequent Tooth Surfaces have values.
; Input: FIELD - Field # of the field being checked
; DA - IEN of the Tooth multiple being edited
; DA(1) - IEN of the Service Line Multiple being edited
; DA(2) - IEN of the 356.22 entry being edited
; Returns: 1 - Subsequent entries have values, 0 otherwise
N NDE,RETURN
S NDE=$G(^IBT(356.22,DA(2),16,DA(1),4,DA,0))
I FIELD=.02 D Q RETURN
. I $P(NDE,"^",2)'="" S RETURN=1 Q
. I $P(NDE,"^",3)'="" S RETURN=1 Q
. I $P(NDE,"^",4)'="" S RETURN=1 Q
. I $P(NDE,"^",5)'="" S RETURN=1 Q
. I $P(NDE,"^",6)'="" S RETURN=1 Q
. S RETURN=0
I FIELD=.03 D Q RETURN
. I $P(NDE,"^",4)'="" S RETURN=1 Q
. I $P(NDE,"^",5)'="" S RETURN=1 Q
. I $P(NDE,"^",6)'="" S RETURN=1 Q
. S RETURN=0
I FIELD=.04 D Q RETURN
. I $P(NDE,"^",5)'="" S RETURN=1 Q
. I $P(NDE,"^",6)'="" S RETURN=1 Q
. S RETURN=0
I FIELD=.05,$P(NDE,"^",6)'="" Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRH5C 16328 printed Sep 23, 2025@20:04:31 Page 2
IBTRH5C ;ALB/FA - HCSR Create 278 Request ;12-AUG-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 ; Contains Entry points and functions used in creating a 278 request from a
+5 ; selected entry in the HCSR Response worklist
+6 ;
+7 ; -------------------------- Entry Points --------------------------------
+8 ; AMBTI - Called from within the input template to see if any of the
+9 ; Ambulance Transport Information fields have a value
+10 ; Fields: 18.01, 18.02, 18.03, 18.04, 18.05, 18.06, 18.09, 18.1
+11 ; ATTPHY - Returns the Attending Physician of the entry
+12 ; CERTCD - Dictionary Screen function for Certification Type Code (2.02)
+13 ; CONTPH - Input Validation method for fields 20, 21, 22
+14 ; CRTENTRY - Creates a new worklist entry from a specified worklist entry.
+15 ; Copies all the request data from the specified entry into the
+16 ; new entry
+17 ; OXYET - Called from within the input template to determine if one of
+18 ; Oxygen Equipment Type fields = 'D' or 'E'. Fields 8.01, 8.02
+19 ; 8.03
+20 ; REQCAT - Dictionary Screen function for Request Category Field 2.01
+21 ; and field 356.2216/.15
+22 ; SLDXDUP - Dictionary Screen function for Service Line Diagnosis fields
+23 ; Checks to insure the diagnosis is NOT a duplicate entry AND
+24 ; points to a valid diagnosis multiple.
+25 ; Fields: 2216,2.01, 2216,2.02, 2216,2.03, 2216,2.04
+26 ; TOOTHSP - Called from within the Input Template to check if subsequent
+27 ; Tooth Surfaces have values
+28 ;-----------------------------------------------------------------------------
+29 ;
CONTPH(FIELD) ;EP
+1 ; Input validation method for Requester Contact Numbers 1,2 and 3 (fields 20,
+2 ; 21 and 22)
+3 ; Input: FIELD - Requester Contact Number field being validated
+4 ; DA - IEN of the 356.22 entry being edited
+5 ; X - Internal Value of the user response
+6 ; Output: None
+7 ; Returns: 1 - Answer is valid, 0 - Otherwise
+8 NEW RETURN,TYPE,XX
+9 SET XX=$SELECT(FIELD=20:19.01,FIELD=21:19.02,FIELD=22:19.03,1:0)
+10 ; Invalid FIELD
if XX=0
QUIT 0
+11 ; Assume valid
SET RETURN=1
+12 ; Requester Contact Qualifier
SET TYPE=$$GET1^DIQ(356.22,DA_",",XX,"I")
+13 ; Requester Contact Qualifier Code
SET TYPE=$$GET1^DIQ(365.021,TYPE_",",.01)
+14 ;
+15 IF (TYPE="ED")!(TYPE="EM")!(TYPE="UR")!(TYPE="EX")
Begin DoDot:1
+16 SET RETURN=$SELECT($LENGTH(X)'>250:1,1:0)
End DoDot:1
QUIT RETURN
+17 ; Remove dashes
SET XX=$TRANSLATE(X,"-","")
+18 IF XX'?10N
SET RETURN=0
+19 QUIT RETURN
+20 ;
CRTENTRY(IBTRIEN,RIEN,IEN312,REQBY,DELCCDE,DELAY,NOOUTPUT,TTYPE) ;EP
+1 ; Creates a new entry in 356.22 by copying fields from an existing entry. Used
+2 ; to create a request from a Response by copying the request entry pointed to
+3 ; from the response entry
+4 ; Input: IBTRIEN - IEN of the entry to be copied
+5 ; RIEN - IEN of the response entry
+6 ; IEN312 - IEN of the insurance multiple to set into field .03
+7 ; Optional, if not passed, this field is copied from the
+8 ; existing entry
+9 ; REQBY - DUZ of the Requested By user to set into field .11
+10 ; Optional, if not passed, this field is copied from the
+11 ; existing entry
+12 ; DELCCDE - 1 to clear the value for Certification Type (field 2.02)
+13 ; Optional, if not passed, defaults to 0
+14 ; DELAY - 'D' or a future date to set a next review date and status
+15 ; to '08'
+16 ; Optional, if not passed, defaults to ""
+17 ; NOOUTPUT - suppress error message output, if not passed, defaults to 0 (false)
+18 ; TTYPE - UM02 value for 278x215 if cancel
+19 ;
+20 ; Output: New entry created in 356.22
+21 ; Returns: 0 - Copy was NOT successful and error messages were displayed
+22 ; Otherwise, IEN of the new entry in 356.22 is returned
+23 NEW ERROR,FLDS,IENARRY,IENS,NEWENTRY,NIENS,NIENS16,OLDENTRY,STOPFLG,XX,Z,Z1,XX1
+24 if '$DATA(NOOUTPUT)
SET NOOUTPUT=0
+25 if '$DATA(IEN312)
SET IEN312=""
+26 if '$DATA(REQBY)
SET REQBY=""
+27 if '$DATA(DELCCDE)
SET DELCCDE=0
+28 if '$DATA(DELAY)
SET DELAY=""
+29 SET IENS=IBTRIEN_","
+30 SET FLDS=".02;.03:.07;.11;.16;2.01:2.25;3*;4.01:4.14;5.01:5.18;6.01:6.18"
+31 SET FLDS=FLDS_";7.01:7.13;8.01:8.08;9.01:9.08;10.01:10.13;11*;12;14*;15*;18.01:18.1;19.01:19.03;20:22"
+32 DO GETS^DIQ(356.22,IENS,FLDS,"NI","OLDENTRY","ERROR")
+33 ; Unsuccessful read of initial entry
IF $DATA(ERROR)
DO COPYERR(0,.ERROR)
QUIT 0
+34 ;
+35 ; Copy internal data from the specified entry to a new array
+36 MERGE NEWENTRY(356.22,"+1,")=OLDENTRY(356.22,IENS)
+37 DO COPYINT(.NEWENTRY)
+38 ;
+39 ; Set the Event Date to 'NOW'
+40 SET NEWENTRY(356.22,"+1,",.01)=$$NOW^XLFDT()
+41 ; Set Insurance Multiple IEN
if IEN312'=""
SET NEWENTRY(356.22,"+1,",.03)=IEN312
+42 ; Initialize status to 0
SET NEWENTRY(356.22,"+1,",.08)=$SELECT(DELAY'="":"08",1:0)
+43 if REQBY'=""
SET NEWENTRY(356.22,"+1,",.11)=REQBY
+44 IF DELCCDE
Begin DoDot:1
+45 ; Clear Certification Type field
SET NEWENTRY(356.22,"+1,",2.02)=""
+46 ; Flag creation from Response
SET NEWENTRY(356.22,"+1,",.18)=1
End DoDot:1
+47 IF $GET(TTYPE)="C"
SET NEWENTRY(356.22,"+1,",2.02)=3
+48 ; Delayed until DELAY
if DELAY'=""
SET NEWENTRY(356.22,"+1,",.17)=DELAY
+49 ; Auth. or Ref. number from response
SET XX=$$GET1^DIQ(356.22,RIEN_",",103.02)
+50 ; CERT ACT CODE
SET XX1=$$GET1^DIQ(356.22,RIEN_",",103.01)
+51 IF $FIND(",A1,A2,A6,",","_XX1_",")
SET NEWENTRY(356.22,"+1,",17.01)=XX
+52 IF $FIND(",A3,A4,C,CT,NA,",","_XX1_",")
Begin DoDot:1
+53 IF XX=""
SET XX=$$GET1^DIQ(356.22,RIEN_",",17.02)
+54 SET NEWENTRY(356.22,"+1,",17.02)=XX
End DoDot:1
+55 KILL IENARRY
+56 ; File the initial data
DO UPDATE^DIE(,"NEWENTRY","IENARRY","ERROR")
+57 ; Unsuccessful copy of initial data
IF $DATA(ERROR)
DO COPYERR(1,.ERROR)
QUIT 0
+58 ; update field .27 of response message
+59 IF DELCCDE
Begin DoDot:1
+60 NEW UPDRSP
+61 SET UPDRSP(356.22,RIEN_",",.27)=1
+62 DO FILE^DIE("I","UPDRSP","ERROR")
+63 QUIT
End DoDot:1
IF $DATA(ERROR)
DO COPYERR(1,.ERROR)
QUIT 0
+64 ;
+65 ; Next copy multiples IENs of the new entry in 356.22 (top level)
+66 SET NIENS=IENARRY(1)_","
+67 ;
+68 ; File Diagnosis multiples (356.223)
+69 IF '$$MLTCPY(356.223,NIENS)
QUIT 0
+70 ;
+71 ; File Attachment multiples (356.2211)
+72 IF '$$MLTCPY(356.2211,NIENS)
QUIT 0
+73 ;
+74 ; File Patient Event Transport multiples (356.2214)
+75 IF '$$MLTCPY(356.2214,NIENS)
QUIT 0
+76 ;
+77 ; File Other UMO multiples (356.2215)
+78 IF '$$MLTCPY(356.2215,NIENS)
QUIT 0
+79 ;
+80 ; File Provider multiples (356.2213)
+81 ; NOTE: not all fields are being copied, each entry needs to be handled separately
+82 SET Z=0
SET STOPFLG=0
+83 FOR
Begin DoDot:1
+84 SET Z=$ORDER(^IBT(356.22,IBTRIEN,13,Z))
+85 if 'Z
QUIT
+86 SET IENS=Z_","_IBTRIEN_","
+87 KILL NEWENTRY,OLDENTRY
+88 DO GETS^DIQ(356.2213,IENS,".01:.03","NI","OLDENTRY","ERROR")
+89 IF $DATA(ERROR)
DO COPYERR(0,.ERROR)
SET STOPFLG=1
QUIT
+90 MERGE NEWENTRY(356.2213,"+1,"_NIENS)=OLDENTRY(356.2213,IENS)
+91 DO COPYINT(.NEWENTRY)
+92 DO UPDATE^DIE(,"NEWENTRY",,"ERROR")
+93 IF $DATA(ERROR)
DO COPYERR(1,.ERROR)
SET STOPFLG=1
End DoDot:1
if 'Z!STOPFLG
QUIT
+94 if STOPFLG
QUIT 0
+95 ;
+96 ; File Service Line multiples (356.2216)
+97 ; NOTE: not all fields are being copied, each entry needs to be handled separately
+98 SET Z=0
SET STOPFLG=0
+99 FOR
Begin DoDot:1
+100 SET Z=$ORDER(^IBT(356.22,IBTRIEN,16,Z))
+101 if 'Z
QUIT
+102 SET IENS=Z_","_IBTRIEN_","
+103 KILL OLDENTRY
+104 SET FLDS=".01:.14;1.01:1.12;2.01:2.09;3.01:3.07;4*;5.01:5.08;6*;7"
+105 DO GETS^DIQ(356.2216,IENS,FLDS,"NI","OLDENTRY","ERROR")
+106 IF $DATA(ERROR)
DO COPYERR(0,.ERROR)
SET STOPFLG=1
QUIT
+107 KILL NEWENTRY
+108 MERGE NEWENTRY(356.2216,"+1,"_NIENS)=OLDENTRY(356.2216,IENS)
+109 DO COPYINT(.NEWENTRY)
+110 KILL IENARRY
+111 DO UPDATE^DIE(,"NEWENTRY","IENARRY","ERROR")
+112 IF $DATA(ERROR)
DO COPYERR(1,.ERROR)
SET STOPFLG=1
+113 ; IENs of the new Service Line in 356.2216
SET NIENS16=IENARRY(1)_","_NIENS
+114 ;
+115 ; File Service Line Tooth Information multiples (356.22164)
+116 IF '$$MLTCPY(356.22164,NIENS16)
SET STOPFLG=1
QUIT
+117 ;
+118 ; File Service Line Attachment multiple (356.22166)
+119 IF '$$MLTCPY(356.22166,NIENS16)
SET STOPFLG=1
QUIT
+120 ;
+121 ; File Service Line Provider Data multiples (356.22168)
+122 ; NOTE - not all fields are being copied, each entry needs to be handled separately
+123 SET Z1=0
+124 FOR
Begin DoDot:2
+125 SET Z1=$ORDER(^IBT(356.22,IBTRIEN,16,Z,8,Z1))
+126 if 'Z1
QUIT
+127 SET IENS=Z1_","_Z_","_IBTRIEN_","
+128 KILL NEWENTRY,OLDENTRY
+129 DO GETS^DIQ(356.22168,IENS,".01:.03","NI","OLDENTRY","ERROR")
+130 IF $DATA(ERROR)
DO COPYERR(0,.ERROR)
SET STOPFLG=1
QUIT
+131 MERGE NEWENTRY(356.22168,"+1,"_NIENS16)=OLDENTRY(356.22168,IENS)
+132 DO COPYINT(.NEWENTRY)
+133 DO UPDATE^DIE(,"NEWENTRY",,"ERROR")
+134 IF $DATA(ERROR)
DO COPYERR(1,.ERROR)
SET STOPFLG=1
End DoDot:2
if 'Z1!STOPFLG
QUIT
End DoDot:1
if 'Z!STOPFLG
QUIT
+135 IF STOPFLG
QUIT 0
+136 QUIT $PIECE(NIENS,",",1)
+137 ;
COPYERR(TYPE,ERROR) ; Displays any errors encountered while copying a request
+1 ; Input: TYPE - 0 - Error while reading data
+2 ; - 1 - Error while filing data
+3 ; ERROR - Array used for FM error reporting
+4 ; Output: Error(s) are displayed
+5 ;IF NOT TO DISPLAY OUTPUT, for background job
IF '$GET(NOOUTPUT)
QUIT
+6 NEW STR,Z,Z1
+7 if '$DATA(ERROR)
QUIT
+8 WRITE !,"Unable to copy - the following error was encountered while "
+9 WRITE $SELECT(TYPE:"filing",1:"retrieving")," the data:"
+10 SET Z=0
+11 FOR
Begin DoDot:1
+12 SET Z=$ORDER(ERROR("DIERR",Z))
+13 if 'Z
QUIT
+14 SET STR=$GET(ERROR("DIERR",Z))
+15 if STR'=""
WRITE !,"Error code: "_STR
+16 SET STR=$GET(ERROR("DIERR",Z,"PARAM","FILE"))
+17 if STR'=""
WRITE !,"File number: "_STR
+18 SET STR=$GET(ERROR("DIERR",Z,"PARAM","FIELD"))
+19 if STR'=""
WRITE !,"Field number: "_STR
+20 WRITE !,"Error text:"
+21 SET Z1=0
+22 FOR
Begin DoDot:2
+23 SET Z1=$ORDER(ERROR("DIERR",1,"TEXT",Z1))
+24 if 'Z1
QUIT
+25 WRITE !,ERROR("DIERR",1,"TEXT",Z1)
End DoDot:2
if 'Z1
QUIT
End DoDot:1
if 'Z
QUIT
+26 QUIT
+27 ;
MLTCPY(SFNUM,NEWIENS) ; Copies the specified multiple
+1 ; Input: SFNUM - Sub-file number of the multiple to copy
+2 ; NIENS - IENs of the new entry (copied to)
+3 ; OLDENTRY - FDA array to get data from (defined in the calling tag)
+4 ; Returns: 1 on successful copy, 0 on failure
+5 ;
+6 NEW ERROR,NEWENTRY,RES,STOPFLG,Z
+7 SET RES=1
SET STOPFLG=0
+8 SET Z=0
+9 FOR
Begin DoDot:1
+10 SET Z=$ORDER(OLDENTRY(SFNUM,Z))
+11 if 'Z
QUIT
+12 KILL NEWENTRY
+13 MERGE NEWENTRY(SFNUM,"+1,"_NEWIENS)=OLDENTRY(SFNUM,Z)
+14 DO COPYINT(.NEWENTRY)
+15 DO UPDATE^DIE(,"NEWENTRY",,"ERROR")
+16 IF $DATA(ERROR)
DO COPYERR(1)
SET STOPFLG=1
SET RES=0
End DoDot:1
if 'Z!STOPFLG
QUIT
+17 QUIT RES
+18 ;
COPYINT(NEW) ; Copies an array of internal values to a new array
+1 ; Input: NEW - Current Array of internal values
+2 ; Retrieved using D GETS^DIQ(356.22,IENS,FLDS,"NI","OLD","ERROR")
+3 ; e.g. NEW(356.223,"+1,19,",.02,"I")=7209320
+4 ; Output: NEW - Updated array of internal values, stripping off the "I" subscript
+5 ; e.g. NEW(356.223,"+1,19,",.02)=7209320
+6 NEW ARRAY,NEW2,YY
+7 SET ARRAY="NEW("""")"
+8 FOR
Begin DoDot:1
+9 SET ARRAY=$QUERY(@ARRAY)
+10 if ARRAY=""
QUIT
+11 IF ARRAY[",""I"")"
Begin DoDot:2
+12 SET YY=$PIECE(ARRAY,",""I"")",1)_")"
+13 SET YY="NEW2("_$PIECE(YY,"(",2)
+14 SET @YY=@ARRAY
End DoDot:2
QUIT
+15 SET YY="NEW2("_$PIECE(ARRAY,"(",2)
+16 SET @YY=@ARRAY
End DoDot:1
if ARRAY=""
QUIT
+17 KILL NEW
+18 MERGE NEW=NEW2
+19 QUIT
+20 ;
OXYET(IBTRIEN) ;EP
+1 ; Called from within the input template
+2 ; Checks to see if any of the currently filed Oxygen Equipment
+3 ; Types have a value of 'D' or 'E'
+4 ; Input: IBTRIEN - IEN of the Patient Event
+5 ; Returns: 1 - at least one of the Oxygen Equipment Types is 'D' or 'E'
+6 ; 0 Otherwise
+7 NEW NDE
+8 SET NDE=$GET(^IBT(356.22,IBTRIEN,8))
+9 IF ($PIECE(NDE,"^",1)=4)!($PIECE(NDE,"^",1)=5)
QUIT 1
+10 IF ($PIECE(NDE,"^",2)=4)!($PIECE(NDE,"^",2)=5)
QUIT 1
+11 IF ($PIECE(NDE,"^",3)=4)!($PIECE(NDE,"^",3)=5)
QUIT 1
+12 QUIT 0
+13 ;
ATTPHY(IBTRIEN) ;EP
+1 ; Returns the Attending Physician for the admission of the
+2 ; specified Inpatient event
+3 ; Input: IBTRIEN - IEN of the Inpatient Event
+4 ; Returns: IEN in file 200 of the Attending Physician or ""
+5 NEW ADATE,DA,DFN,DT,EVENT,FOUND,IADATE
+6 SET EVENT=$GET(^IBT(356.22,IBTRIEN,0))
+7 ; DFN of the patient
SET DFN=$PIECE(EVENT,"^",2)
+8 ; Internal Admit date
SET ADATE=$PIECE($PIECE(EVENT,"^",7),"-",1)
+9 SET IADATE=9999999.9999999-ADATE
+10 ; DBIA419
SET DA=$ORDER(^DGPM("ATID1",DFN,IADATE,""))
+11 ; No Patient Movement admission record
if DA=""
QUIT ""
+12 QUIT $$GET1^DIQ(405,DA_",",.19,"I")
+13 ;
REQCAT(FIELD) ;EP
+1 ; Dictionary Screen for Request Category (2.01)
+2 ; Checks the Request Category (2.01 OR 356.2216/.15) to make sure the answer
+3 ; is valid for the event type
+4 ; Input: FIELD - Only passed when called from 356.2216/.15
+5 ; DA - IEN of the 356.22 entry being edited
+6 ; Y - Internal Value of the user response
+7 ; Output: None
+8 ; Returns: 1 - Answer is valid, 0 - Otherwise
+9 NEW RETURN,STAT
+10 IF $DATA(FIELD)
Begin DoDot:1
+11 SET RETURN=1
+12 IF Y'=2
IF Y'=4
SET RETURN=0
End DoDot:1
QUIT RETURN
+13 ;
+14 SET STAT=$PIECE($GET(^IBT(356.22,DA,0)),"^",4)
+15 IF STAT="I"
IF Y'=1
QUIT 0
+16 IF STAT="O"
IF Y=1
QUIT 0
+17 QUIT 1
+18 ;
CERTCD() ;EP
+1 ; Dictionary screen for field Certification Type Code 2.02
+2 ; Checks the code to make sure the answer is valid for the event type
+3 ; Input: DA - IEN of the 356.22 entry being edited
+4 ; Y - Internal Value of the user response
+5 ; Output: None
+6 ; Returns: 1 - Answer is valid, 0 - Otherwise
+7 NEW FREP
+8 IF '$FIND(",3,5,",","_Y_",")
QUIT 0
+9 SET FREP=$PIECE($GET(^IBT(356.22,DA,0)),"^",18)
+10 IF FREP=1
IF Y=5
QUIT 0
+11 QUIT 1
+12 ;
AMBTI(IBTRIEN) ;EP
+1 ; Called from Input Template IB CREATE 278 REQUEST to check if any of the
+2 ; Ambulance Transport Information fields has a value. Used to potentially
+3 ; skip to potentially skip the Patient Event Transport Information questions
+4 ; Input: IBTRIEN - IEN of the 356.22 entry being edited
+5 ; Returns: 1 - At least one field has a value, 0 otherwise
+6 NEW NDE
+7 SET NDE=$GET(^IBT(356.22,IBTRIEN,18))
+8 IF $PIECE(NDE,"^",1)'=""
QUIT 1
+9 IF $PIECE(NDE,"^",2)'=""
QUIT 1
+10 IF $PIECE(NDE,"^",3)'=""
QUIT 1
+11 IF $PIECE(NDE,"^",4)'=""
QUIT 1
+12 IF $PIECE(NDE,"^",5)'=""
QUIT 1
+13 IF $PIECE(NDE,"^",6)'=""
QUIT 1
+14 IF $PIECE(NDE,"^",9)'=""
QUIT 1
+15 IF $PIECE(NDE,"^",10)'=""
QUIT 1
+16 QUIT 0
+17 ;
SLDXDUP(FIELD) ;EP
+1 ; Dictionary Screen Function
+2 ; Checks to see if the specified Service Line Diagnosis is a duplicate entry
+3 ; AND points to valid Diagnosis multiple.
+4 ; Fields: 2216,2.01, 2216,2.02, 2216,2.03, 2216,2.04
+5 ; Input: FIELD - Field number of the field being checked
+6 ; DA(1) - IEN of the 356.22 entry being edited
+7 ; DA - IEN of the service line multiple
+8 ; Y - Internal Value of the user response
+9 ; Output: None
+10 ; Returns: 1 - Answer is valid, 0 - Otherwise
+11 NEW NDE,RETURN
+12 ; Assume Valid Input
SET RETURN=1
+13 ; No value entered
if Y=""
QUIT 1
+14 ;
+15 ; Not a valid service line multiple
+16 IF '$DATA(^IBT(356.22,DA(1),3,Y,0))
QUIT 0
+17 ;
+18 ; Check for duplicates
+19 SET NDE=$GET(^IBT(356.22,DA(1),16,DA,2))
+20 IF FIELD="2.01"
Begin DoDot:1
+21 IF $PIECE(NDE,"^",2)=Y
SET RETURN=0
QUIT
+22 IF $PIECE(NDE,"^",3)=Y
SET RETURN=0
QUIT
+23 IF $PIECE(NDE,"^",4)=Y
SET RETURN=0
QUIT
End DoDot:1
QUIT RETURN
+24 IF FIELD="2.02"
Begin DoDot:1
+25 IF $PIECE(NDE,"^",1)=Y
SET RETURN=0
QUIT
+26 IF $PIECE(NDE,"^",3)=Y
SET RETURN=0
QUIT
+27 IF $PIECE(NDE,"^",4)=Y
SET RETURN=0
QUIT
End DoDot:1
QUIT RETURN
+28 IF FIELD="2.03"
Begin DoDot:1
+29 IF $PIECE(NDE,"^",1)=Y
SET RETURN=0
QUIT
+30 IF $PIECE(NDE,"^",2)=Y
SET RETURN=0
QUIT
+31 IF $PIECE(NDE,"^",4)=Y
SET RETURN=0
QUIT
End DoDot:1
QUIT RETURN
+32 IF FIELD="2.04"
Begin DoDot:1
+33 IF $PIECE(NDE,"^",1)=Y
SET RETURN=0
QUIT
+34 IF $PIECE(NDE,"^",2)=Y
SET RETURN=0
QUIT
+35 IF $PIECE(NDE,"^",3)=Y
SET RETURN=0
QUIT
End DoDot:1
QUIT RETURN
+36 QUIT 1
+37 ;
TOOTHSP(FIELD) ;EP
+1 ; Called from Input Template IB CREATE 278 REQUEST for Service Line Tooth
+2 ; Surface fields. Checks to see if subsequent Tooth Surfaces have values.
+3 ; Input: FIELD - Field # of the field being checked
+4 ; DA - IEN of the Tooth multiple being edited
+5 ; DA(1) - IEN of the Service Line Multiple being edited
+6 ; DA(2) - IEN of the 356.22 entry being edited
+7 ; Returns: 1 - Subsequent entries have values, 0 otherwise
+8 NEW NDE,RETURN
+9 SET NDE=$GET(^IBT(356.22,DA(2),16,DA(1),4,DA,0))
+10 IF FIELD=.02
Begin DoDot:1
+11 IF $PIECE(NDE,"^",2)'=""
SET RETURN=1
QUIT
+12 IF $PIECE(NDE,"^",3)'=""
SET RETURN=1
QUIT
+13 IF $PIECE(NDE,"^",4)'=""
SET RETURN=1
QUIT
+14 IF $PIECE(NDE,"^",5)'=""
SET RETURN=1
QUIT
+15 IF $PIECE(NDE,"^",6)'=""
SET RETURN=1
QUIT
+16 SET RETURN=0
End DoDot:1
QUIT RETURN
+17 IF FIELD=.03
Begin DoDot:1
+18 IF $PIECE(NDE,"^",4)'=""
SET RETURN=1
QUIT
+19 IF $PIECE(NDE,"^",5)'=""
SET RETURN=1
QUIT
+20 IF $PIECE(NDE,"^",6)'=""
SET RETURN=1
QUIT
+21 SET RETURN=0
End DoDot:1
QUIT RETURN
+22 IF FIELD=.04
Begin DoDot:1
+23 IF $PIECE(NDE,"^",5)'=""
SET RETURN=1
QUIT
+24 IF $PIECE(NDE,"^",6)'=""
SET RETURN=1
QUIT
+25 SET RETURN=0
End DoDot:1
QUIT RETURN
+26 IF FIELD=.05
IF $PIECE(NDE,"^",6)'=""
QUIT 1
+27 QUIT 0
+28 ;
