- 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 Feb 18, 2025@23:07:22 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 ;