DVBACPR1 ;ALB/GAK - PATCH DVBA*2.7*189 introduced field utility RPCs;April 14, 2023 ; 5/16/23 11:59am
;;2.7;AMIE;**189,248**;Apr 10, 1995;Build 6
; This routine provides list, get and set features for several CAPRI RPCs
Q
;
LSTCT(RTRN) ;
;LIST VALID CLAIM TYPES
;RPC: DVBA CAPRI LISTCLAIMTYPE
N CTIEN,CODE,CTR
K ^TEMP($J,"LSTCT")
S CTIEN=0
F S CTIEN=$O(^DVB(396.27,CTIEN)) Q:CTIEN=""!('CTIEN) D
. Q:$G(^DVB(396.27,CTIEN,0))=""
. S ^TEMP($J,"LSTCT",$P(^DVB(396.27,CTIEN,0),"^",1))=CTIEN
S CODE="",CTR=0
F S CODE=$O(^TEMP($J,"LSTCT",CODE)) Q:CODE="" D
. S CTR=CTR+1
. S RTRN(CTR)=CODE_"^"_^TEMP($J,"LSTCT",CODE)
K ^TEMP($J,"LSTCT")
Q
;
GETCT(RTRN,REQIEN) ;
;GET CLAIM TYPE
;RPC: DVBA CAPRI GETCLAIMTYPE
I $G(REQIEN)="" S RTRN(1)="INVALID REQUEST IEN" Q
I '$D(^DVB(396.3,$G(REQIEN))) S RTRN(1)="INVALID REQUEST IEN" Q
N MSG,ERR,CTR,MSGIEN,FIND,OUT
D GETS^DIQ(396.3,REQIEN_",","9.1*","E","MSG","ERR")
I $D(ERR)>1 S RTRN(1)="NO CLAIM TYPE ON FILE" Q
S CTR=0
S MSGIEN="" F S MSGIEN=$O(MSG(396.32,MSGIEN)) Q:MSGIEN="" D
. S CTR=CTR+1
. K FIND,OUT
. S FIND=MSG(396.32,MSGIEN,.01,"E")
. D FIND^DIC(396.27,"",.01,"",.FIND,"","","","","OUT")
. S RTRN(CTR)=MSG(396.32,MSGIEN,.01,"E")_"^"_$G(OUT("DILIST",2,1))
Q
;
SETCT(RTRN,REQIEN,ARRAYCT) ;
;SET CLAIM TYPE
;RPC: DVBA CAPRI SETCLAIMTYPE
;
N VAL,SUB,DA,DIK
S VAL="" F S VAL=$O(^DVB(396.3,REQIEN,9,"B",VAL)) Q:VAL="" D
. S SUB="" F S SUB=$O(^DVB(396.3,REQIEN,9,"B",VAL,SUB)) Q:SUB="" D
.. K DA,DIK
.. S DA(1)=REQIEN
.. S DA=SUB
.. S DIK="^DVB(396.3,"_DA(1)_",""9"","
.. D ^DIK
;
I $G(REQIEN)="" S RTRN(1)="INVALID REQUEST IEN" Q
I '$D(^DVB(396.3,$G(REQIEN))) S RTRN(1)="INVALID EXAM IEN" Q
N ARYIEN,CTR,FDA,ERR,KEYIEN,FIND
S CTR=0
S ARYIEN="" F S ARYIEN=$O(ARRAYCT(ARYIEN)) Q:ARYIEN="" D
. S CTR=CTR+1
. K FIND,OUT
. S FIND=ARRAYCT(ARYIEN)
. D FIND^DIC(396.27,"",.01,"",.FIND,"","","","","OUT")
. I $G(OUT("DILIST",2,1))="" S RTRN(CTR)=FIND_"^"_"NOT A VALID CLAIM TYPE" Q
. K FDA,ERR,KEYIEN
. S KEYIEN=OUT("DILIST",2,1)
. S FDA(396.32,"+2,"_REQIEN_",",.01)=KEYIEN
. D UPDATE^DIE("","FDA","KEYIEN","ERR")
. I $D(ERR)>1 S RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED" Q
. S RTRN(CTR)=FIND_"^"_"FILED"
;
Q
;
LSTSC(RTRN) ;
;LIST SPECIAL CONSIDERATION
;RPC: DVBA CAPRI LISTSPCLCONSID
N SCIEN,CTR,CODE
K ^TEMP($J,"LSTSC")
S SCIEN=0
F S SCIEN=$O(^DVB(396.25,SCIEN)) Q:SCIEN=""!('SCIEN) D
. Q:$G(^DVB(396.25,SCIEN,0))=""
. Q:$P($G(^DVB(396.25,SCIEN,0)),U,2)'=1
. S ^TEMP($J,"LSTSC",$P(^DVB(396.25,SCIEN,0),"^",1))=SCIEN
S CODE="",CTR=0
F S CODE=$O(^TEMP($J,"LSTSC",CODE)) Q:CODE="" D
. S CTR=CTR+1
. S RTRN(CTR)=CODE_"^"_^TEMP($J,"LSTSC",CODE)
K ^TEMP($J,"LSTSC")
Q
;
GETSC(RTRN,REQIEN) ;
;GET SPECIAL CONSIDERATION
;RPC: DVBA CAPRI GETSPCLCONSID
I $G(REQIEN)="" S RTRN(1)="INVALID REQUEST IEN" Q
I '$D(^DVB(396.3,$G(REQIEN))) S RTRN(1)="INVALID REQUEST IEN" Q
N MSG,ERR,CTR,MSGIEN,FIND,OUT
D GETS^DIQ(396.3,REQIEN_",","50*","E","MSG","ERR")
I $D(ERR)>1 S RTRN(1)="NO SPECIAL CONSIDERATIONS ON FILE" Q
S CTR=0
S MSGIEN="" F S MSGIEN=$O(MSG(396.31,MSGIEN)) Q:MSGIEN="" D
. S CTR=CTR+1
. K FIND,OUT
. S FIND=MSG(396.31,MSGIEN,.01,"E")
. D FIND^DIC(396.25,"",.01,"",.FIND,"","","","","OUT")
. S RTRN(CTR)=MSG(396.31,MSGIEN,.01,"E")_"^"_$G(OUT("DILIST",2,1))
Q
;
SETSC(RTRN,REQIEN,ARRAYSC) ;
;SET SPECIAL CONSIDERATION
;RPC: DVBA CAPRI SETSPCLCONSID
;
N VAL,SUB,DA,DIK
S VAL="" F S VAL=$O(^DVB(396.3,REQIEN,8,"B",VAL)) Q:VAL="" D
. S SUB="" F S SUB=$O(^DVB(396.3,REQIEN,8,"B",VAL,SUB)) Q:SUB="" D
.. K DA,DIK
.. S DA(1)=REQIEN
.. S DA=SUB
.. S DIK="^DVB(396.3,"_DA(1)_",""8"","
.. D ^DIK
;
I $G(REQIEN)="" S RTRN(1)="INVALID REQUEST IEN" Q
I '$D(^DVB(396.3,$G(REQIEN))) S RTRN(1)="INVALID REQUEST IEN" Q
N ARYIEN,CTR,FDA,ERR,KEYIEN,FIND
S CTR=0
S ARYIEN="" F S ARYIEN=$O(ARRAYSC(ARYIEN)) Q:ARYIEN="" D
. S CTR=CTR+1
. K FIND,OUT
. S FIND=ARRAYSC(ARYIEN)
. D FIND^DIC(396.25,"",.01,"",.FIND,"","","","","OUT")
. I $G(OUT("DILIST",2,1))="" S RTRN(CTR)=FIND_"^"_"NOT A VALID SPECIAL CONSIDERATION" Q
. K FDA,ERR,KEYIEN
. S KEYIEN=OUT("DILIST",2,1)
. S FDA(396.31,"+2,"_REQIEN_",",.01)=KEYIEN
. D UPDATE^DIE("","FDA","KEYIEN","ERR")
. I $D(ERR)>1 S RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED" Q
. S RTRN(CTR)=FIND_"^"_"FILED"
;
Q
;
LSTIR(RTRN) ;
;LIST INSUFFICIENT REASON
;RPC: DVBA CAPRI LISTINSUFRSN
;FILE #396.4 FIELD .11 --> FILE #396.94
;BUILD LIST OF VALID (ACTIVE) REASONS
N IRIEN,CTR,CODE
K ^TEMP($J,"LSTIR")
S IRIEN=0
F S IRIEN=$O(^DVB(396.94,IRIEN)) Q:IRIEN=""!('IRIEN) D
. Q:$G(^DVB(396.94,IRIEN,0))=""
. Q:$P(^DVB(396.94,IRIEN,0),"^",4)="Y"
. S ^TEMP($J,"LSTIR",$P(^DVB(396.94,IRIEN,0),"^",1))=IRIEN
S CODE="",CTR=0
F S CODE=$O(^TEMP($J,"LSTIR",CODE)) Q:CODE="" D
. S CTR=CTR+1
. S RTRN(CTR)=CODE_"^"_^TEMP($J,"LSTIR",CODE)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBACPR1 4982 printed Dec 13, 2024@01:40:59 Page 2
DVBACPR1 ;ALB/GAK - PATCH DVBA*2.7*189 introduced field utility RPCs;April 14, 2023 ; 5/16/23 11:59am
+1 ;;2.7;AMIE;**189,248**;Apr 10, 1995;Build 6
+2 ; This routine provides list, get and set features for several CAPRI RPCs
+3 QUIT
+4 ;
LSTCT(RTRN) ;
+1 ;LIST VALID CLAIM TYPES
+2 ;RPC: DVBA CAPRI LISTCLAIMTYPE
+3 NEW CTIEN,CODE,CTR
+4 KILL ^TEMP($JOB,"LSTCT")
+5 SET CTIEN=0
+6 FOR
SET CTIEN=$ORDER(^DVB(396.27,CTIEN))
if CTIEN=""!('CTIEN)
QUIT
Begin DoDot:1
+7 if $GET(^DVB(396.27,CTIEN,0))=""
QUIT
+8 SET ^TEMP($JOB,"LSTCT",$PIECE(^DVB(396.27,CTIEN,0),"^",1))=CTIEN
End DoDot:1
+9 SET CODE=""
SET CTR=0
+10 FOR
SET CODE=$ORDER(^TEMP($JOB,"LSTCT",CODE))
if CODE=""
QUIT
Begin DoDot:1
+11 SET CTR=CTR+1
+12 SET RTRN(CTR)=CODE_"^"_^TEMP($JOB,"LSTCT",CODE)
End DoDot:1
+13 KILL ^TEMP($JOB,"LSTCT")
+14 QUIT
+15 ;
GETCT(RTRN,REQIEN) ;
+1 ;GET CLAIM TYPE
+2 ;RPC: DVBA CAPRI GETCLAIMTYPE
+3 IF $GET(REQIEN)=""
SET RTRN(1)="INVALID REQUEST IEN"
QUIT
+4 IF '$DATA(^DVB(396.3,$GET(REQIEN)))
SET RTRN(1)="INVALID REQUEST IEN"
QUIT
+5 NEW MSG,ERR,CTR,MSGIEN,FIND,OUT
+6 DO GETS^DIQ(396.3,REQIEN_",","9.1*","E","MSG","ERR")
+7 IF $DATA(ERR)>1
SET RTRN(1)="NO CLAIM TYPE ON FILE"
QUIT
+8 SET CTR=0
+9 SET MSGIEN=""
FOR
SET MSGIEN=$ORDER(MSG(396.32,MSGIEN))
if MSGIEN=""
QUIT
Begin DoDot:1
+10 SET CTR=CTR+1
+11 KILL FIND,OUT
+12 SET FIND=MSG(396.32,MSGIEN,.01,"E")
+13 DO FIND^DIC(396.27,"",.01,"",.FIND,"","","","","OUT")
+14 SET RTRN(CTR)=MSG(396.32,MSGIEN,.01,"E")_"^"_$GET(OUT("DILIST",2,1))
End DoDot:1
+15 QUIT
+16 ;
SETCT(RTRN,REQIEN,ARRAYCT) ;
+1 ;SET CLAIM TYPE
+2 ;RPC: DVBA CAPRI SETCLAIMTYPE
+3 ;
+4 NEW VAL,SUB,DA,DIK
+5 SET VAL=""
FOR
SET VAL=$ORDER(^DVB(396.3,REQIEN,9,"B",VAL))
if VAL=""
QUIT
Begin DoDot:1
+6 SET SUB=""
FOR
SET SUB=$ORDER(^DVB(396.3,REQIEN,9,"B",VAL,SUB))
if SUB=""
QUIT
Begin DoDot:2
+7 KILL DA,DIK
+8 SET DA(1)=REQIEN
+9 SET DA=SUB
+10 SET DIK="^DVB(396.3,"_DA(1)_",""9"","
+11 DO ^DIK
End DoDot:2
End DoDot:1
+12 ;
+13 IF $GET(REQIEN)=""
SET RTRN(1)="INVALID REQUEST IEN"
QUIT
+14 IF '$DATA(^DVB(396.3,$GET(REQIEN)))
SET RTRN(1)="INVALID EXAM IEN"
QUIT
+15 NEW ARYIEN,CTR,FDA,ERR,KEYIEN,FIND
+16 SET CTR=0
+17 SET ARYIEN=""
FOR
SET ARYIEN=$ORDER(ARRAYCT(ARYIEN))
if ARYIEN=""
QUIT
Begin DoDot:1
+18 SET CTR=CTR+1
+19 KILL FIND,OUT
+20 SET FIND=ARRAYCT(ARYIEN)
+21 DO FIND^DIC(396.27,"",.01,"",.FIND,"","","","","OUT")
+22 IF $GET(OUT("DILIST",2,1))=""
SET RTRN(CTR)=FIND_"^"_"NOT A VALID CLAIM TYPE"
QUIT
+23 KILL FDA,ERR,KEYIEN
+24 SET KEYIEN=OUT("DILIST",2,1)
+25 SET FDA(396.32,"+2,"_REQIEN_",",.01)=KEYIEN
+26 DO UPDATE^DIE("","FDA","KEYIEN","ERR")
+27 IF $DATA(ERR)>1
SET RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED"
QUIT
+28 SET RTRN(CTR)=FIND_"^"_"FILED"
End DoDot:1
+29 ;
+30 QUIT
+31 ;
LSTSC(RTRN) ;
+1 ;LIST SPECIAL CONSIDERATION
+2 ;RPC: DVBA CAPRI LISTSPCLCONSID
+3 NEW SCIEN,CTR,CODE
+4 KILL ^TEMP($JOB,"LSTSC")
+5 SET SCIEN=0
+6 FOR
SET SCIEN=$ORDER(^DVB(396.25,SCIEN))
if SCIEN=""!('SCIEN)
QUIT
Begin DoDot:1
+7 if $GET(^DVB(396.25,SCIEN,0))=""
QUIT
+8 if $PIECE($GET(^DVB(396.25,SCIEN,0)),U,2)'=1
QUIT
+9 SET ^TEMP($JOB,"LSTSC",$PIECE(^DVB(396.25,SCIEN,0),"^",1))=SCIEN
End DoDot:1
+10 SET CODE=""
SET CTR=0
+11 FOR
SET CODE=$ORDER(^TEMP($JOB,"LSTSC",CODE))
if CODE=""
QUIT
Begin DoDot:1
+12 SET CTR=CTR+1
+13 SET RTRN(CTR)=CODE_"^"_^TEMP($JOB,"LSTSC",CODE)
End DoDot:1
+14 KILL ^TEMP($JOB,"LSTSC")
+15 QUIT
+16 ;
GETSC(RTRN,REQIEN) ;
+1 ;GET SPECIAL CONSIDERATION
+2 ;RPC: DVBA CAPRI GETSPCLCONSID
+3 IF $GET(REQIEN)=""
SET RTRN(1)="INVALID REQUEST IEN"
QUIT
+4 IF '$DATA(^DVB(396.3,$GET(REQIEN)))
SET RTRN(1)="INVALID REQUEST IEN"
QUIT
+5 NEW MSG,ERR,CTR,MSGIEN,FIND,OUT
+6 DO GETS^DIQ(396.3,REQIEN_",","50*","E","MSG","ERR")
+7 IF $DATA(ERR)>1
SET RTRN(1)="NO SPECIAL CONSIDERATIONS ON FILE"
QUIT
+8 SET CTR=0
+9 SET MSGIEN=""
FOR
SET MSGIEN=$ORDER(MSG(396.31,MSGIEN))
if MSGIEN=""
QUIT
Begin DoDot:1
+10 SET CTR=CTR+1
+11 KILL FIND,OUT
+12 SET FIND=MSG(396.31,MSGIEN,.01,"E")
+13 DO FIND^DIC(396.25,"",.01,"",.FIND,"","","","","OUT")
+14 SET RTRN(CTR)=MSG(396.31,MSGIEN,.01,"E")_"^"_$GET(OUT("DILIST",2,1))
End DoDot:1
+15 QUIT
+16 ;
SETSC(RTRN,REQIEN,ARRAYSC) ;
+1 ;SET SPECIAL CONSIDERATION
+2 ;RPC: DVBA CAPRI SETSPCLCONSID
+3 ;
+4 NEW VAL,SUB,DA,DIK
+5 SET VAL=""
FOR
SET VAL=$ORDER(^DVB(396.3,REQIEN,8,"B",VAL))
if VAL=""
QUIT
Begin DoDot:1
+6 SET SUB=""
FOR
SET SUB=$ORDER(^DVB(396.3,REQIEN,8,"B",VAL,SUB))
if SUB=""
QUIT
Begin DoDot:2
+7 KILL DA,DIK
+8 SET DA(1)=REQIEN
+9 SET DA=SUB
+10 SET DIK="^DVB(396.3,"_DA(1)_",""8"","
+11 DO ^DIK
End DoDot:2
End DoDot:1
+12 ;
+13 IF $GET(REQIEN)=""
SET RTRN(1)="INVALID REQUEST IEN"
QUIT
+14 IF '$DATA(^DVB(396.3,$GET(REQIEN)))
SET RTRN(1)="INVALID REQUEST IEN"
QUIT
+15 NEW ARYIEN,CTR,FDA,ERR,KEYIEN,FIND
+16 SET CTR=0
+17 SET ARYIEN=""
FOR
SET ARYIEN=$ORDER(ARRAYSC(ARYIEN))
if ARYIEN=""
QUIT
Begin DoDot:1
+18 SET CTR=CTR+1
+19 KILL FIND,OUT
+20 SET FIND=ARRAYSC(ARYIEN)
+21 DO FIND^DIC(396.25,"",.01,"",.FIND,"","","","","OUT")
+22 IF $GET(OUT("DILIST",2,1))=""
SET RTRN(CTR)=FIND_"^"_"NOT A VALID SPECIAL CONSIDERATION"
QUIT
+23 KILL FDA,ERR,KEYIEN
+24 SET KEYIEN=OUT("DILIST",2,1)
+25 SET FDA(396.31,"+2,"_REQIEN_",",.01)=KEYIEN
+26 DO UPDATE^DIE("","FDA","KEYIEN","ERR")
+27 IF $DATA(ERR)>1
SET RTRN(CTR)=FIND_"^"_"COULD NOT BE FILED"
QUIT
+28 SET RTRN(CTR)=FIND_"^"_"FILED"
End DoDot:1
+29 ;
+30 QUIT
+31 ;
LSTIR(RTRN) ;
+1 ;LIST INSUFFICIENT REASON
+2 ;RPC: DVBA CAPRI LISTINSUFRSN
+3 ;FILE #396.4 FIELD .11 --> FILE #396.94
+4 ;BUILD LIST OF VALID (ACTIVE) REASONS
+5 NEW IRIEN,CTR,CODE
+6 KILL ^TEMP($JOB,"LSTIR")
+7 SET IRIEN=0
+8 FOR
SET IRIEN=$ORDER(^DVB(396.94,IRIEN))
if IRIEN=""!('IRIEN)
QUIT
Begin DoDot:1
+9 if $GET(^DVB(396.94,IRIEN,0))=""
QUIT
+10 if $PIECE(^DVB(396.94,IRIEN,0),"^",4)="Y"
QUIT
+11 SET ^TEMP($JOB,"LSTIR",$PIECE(^DVB(396.94,IRIEN,0),"^",1))=IRIEN
End DoDot:1
+12 SET CODE=""
SET CTR=0
+13 FOR
SET CODE=$ORDER(^TEMP($JOB,"LSTIR",CODE))
if CODE=""
QUIT
Begin DoDot:1
+14 SET CTR=CTR+1
+15 SET RTRN(CTR)=CODE_"^"_^TEMP($JOB,"LSTIR",CODE)
End DoDot:1
+16 QUIT
+17 ;
