DVBABFRM ;ALB/SPH - CAPRI TEMPLATE/WORKSHEETS UTILITIES ;11/17/02
;;2.7;AMIE;**53,57,90,123,181**;Apr 10, 1995;Build 38
;
DEFINE(Y,DVBIEN,DVBTYPE) ;
; DVBTYPE: 1= Form Definition, 2=Script, 3=Report
N DVBJ K ^TMP($J,"AMIE")
S DVBJ=0,DVBTYPE=DVBTYPE+2,Y=$NA(^TMP($J,"AMIE"))
F S DVBJ=$O(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ)) Q:'DVBJ D
.S ^TMP($J,"AMIE",DVBJ)=$G(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ,0))_$C(13)
Q
UPDATE(Y,DVBIEN,DVBTYPE,DVBLINES,DVBLINEC,DVBLINEB) ;
; DVBTYPE: 1= Form Definition, 2=Script, 3=Report
N DVBNUM,DVBCOUNT
I DVBTYPE=1,DVBLINEB=0 D
.K ^DVB(396.18,DVBIEN,3)
.S ^DVB(396.18,DVBIEN,3,0)=DVBLINES(1)
S DVBNUM=DVBLINEB,DVBCOUNT=1,DVBTYPE=DVBTYPE+2
I DVBLINEB=0 S DVBCOUNT=2
I DVBNUM>0 S DVBNUM=DVBNUM-1
F S DVBNUM=DVBNUM+1 Q:DVBNUM=(DVBLINEC+DVBLINEB) D
.S ^DVB(396.18,DVBIEN,DVBTYPE,DVBNUM,0)=DVBLINES(DVBCOUNT),DVBCOUNT=DVBCOUNT+1
Q
SAVE(Y,DVBIEN,DVBLINES,DVBLINEC,DVBLINEB,DVBTPSV) ;
; DVBTPSV: 3/NULL=NORMAL GLOBAL
N DVBNUM,DVBCOUNT
S DVBTPSV=$G(DVBTPSV,3),DVBNUM=DVBLINEB,DVBCOUNT=1
I DVBLINEB=0 D
.K ^DVB(396.17,DVBIEN,DVBTPSV)
.S ^DVB(396.17,DVBIEN,DVBTPSV,0)=DVBLINES(1),DVBCOUNT=2
I DVBNUM>0 S DVBNUM=DVBNUM-1
F S DVBNUM=DVBNUM+1 Q:DVBNUM=(DVBLINEC+DVBLINEB) D
.S ^DVB(396.17,DVBIEN,DVBTPSV,DVBNUM,0)=DVBLINES(DVBCOUNT),DVBCOUNT=DVBCOUNT+1
; SET Y TO NUMBER OF LINES IN THE GLOBAL FOR GUI VERIFICATION
S Y=+$P($G(^DVB(396.17,DVBIEN,DVBTPSV,0)),U,3)
Q
LOAD(Y,DVBIEN,DVBTPSV) ;
; DVBTPSV: 3/NULL=NORMAL GLOBAL
N DVBABCNT,DVBABIEN K ^TMP("DVBAFRML",DUZ)
S DVBTPSV=$G(DVBTPSV,3),DVBABCNT=1,DVBABIEN=0,Y=$NA(^TMP("DVBAFRML",DUZ))
F S DVBABIEN=$O(^DVB(396.17,DVBIEN,DVBTPSV,DVBABIEN)) Q:'DVBABIEN D
.S ^TMP("DVBAFRML",DUZ,DVBABCNT-1)=$G(^DVB(396.17,DVBIEN,DVBTPSV,DVBABCNT,0))_$C(13),DVBABCNT=DVBABCNT+1
Q
CCOW(Y,F) ;RPC DVBAB CCOW
S Y=-1
S:F=1 Y=$$SITE^VASITE
S:F=2 Y=$$PROD^XUPROD
Q
U1N4(Y,ARR) ;RPC DVBAB FETCH 1U4N
N I,X S I="",Y=$NA(^TMP("DVBU1N4",$J)) K @Y
F S I=$O(ARR(I)) Q:I="" D
.S X=$P($G(^DVB(396.17,ARR(I),0)),U)
.S:X X=$$GET1^DIQ(2,X_",",.0905)
.S ^TMP("DVBU1N4",$J,I)=ARR(I)_U_$S(X]"":X,1:"?????")
Q
DELETE(Y,IEN) ;RPC DVBAB FORM DATA BACKUP DELETE
S IEN=$G(IEN),Y=$S(IEN?1.N:0,1:"1^INVALID ARGUMENT")
I 'Y,'$D(^DVB(396.17,IEN,0)) S Y="1^RECORD NOT FOUND"
K:'Y&$D(^DVB(396.17,IEN,9)) ^DVB(396.17,IEN,9)
Q
BACKUP(Y,IEN,TXT) ;RPC DVBAB FORM DATA BACKUP
N F,S,A,N,M,R S F=396.17,M="-1^RECORD NOT FOUND",IEN=$G(IEN)_","
S R="^DVB("_F_","_IEN,Y=$S(IEN?1.N1",":0,1:"-1^INVALID ARGUMENT")
I 'Y,'$D(@(R_"0)")) S Y=M
Q:Y S M=$P($G(@(R_"3,0)")),U,3) Q:'M
S S=396.19,N="+1,"_IEN,TXT=$G(TXT)
S A(S,N,.01)=$$NOW^XLFDT
S A(S,N,2)=$S(TXT]"":TXT,1:"Automatic Save by "_$P($G(^VA(200,DUZ,0)),U))
D UPDATE^DIE(,"A"),ERR(.Y)
I 'Y D
.S N=$P($G(@(R_"9,0)")),U,3)_","_IEN
.D WP^DIE(S,N,1,"A",R_"3)"),ERR(.Y)
.D:'Y WP^DIE(S,N,3,"A",R_"1)"),ERR(.Y)
S:'Y Y=M
Q
RESTORE(Y,IEN,SN) ;RPC DVBAB FORM DATA BACKUP RESTORE
N Z,F,T,M,N,R
;
S IEN=$G(IEN)_","
S SN=$G(SN)
S N=396.17
S R="^DVB("_N_","_IEN
S Y=$S(IEN?1.N1","&(SN?1.N):0,1:"-1^INVALID ARGUMENT")
S M="-1^RECORD NOT FOUND"
S SN=R_"9,"_SN_","
S F="RESTORE "
;
I 'Y,'$D(@(R_"0)")) S Y=M
I 'Y,'$D(@(R_"9,0)")) S $P(M,U,2)="SUB-"_$P(M,U,2),Y=M
I 'Y,'$D(@(SN_"0)")) S $P(M,U,2)=F_$P(M,U,2),Y=M
Q:Y S M=$P($G(@(SN_"1,0)")),U,3),F=F_"FAILED: " Q:'M
;
M ^XTMP("DVBA",$J,"NODE3")=@(R_"3)") K @(R_"3)")
D WP^DIE(N,IEN,8,"A",SN_"1)"),ERR(.Y)
I Y K @(R_"3)") M @(R_"3)")=^XTMP("DVBA",$J,"NODE3") S $P(Y,U,2)=F_$P(Y,U,2) Q
;
M ^XTMP("DVBA",$J,"NODE1")=@(R_"1)") K @(R_"1)")
D WP^DIE(N,IEN,6,"A",SN_"3)"),ERR(.Y) I 'Y S Y=M Q
K @(R_"3)"),@(R_"1)")
M @(R_"3)")=^XTMP("DVBA",$J,"NODE3"),@(R_"1)")=^XTMP("DVBA",$J,"NODE1")
S $P(Y,U,2)=F_$P(Y,U,2)
;
;cleanup ^xtmp global
K ^XTMP("DVBA",$J)
Q
COPY(Y,DA,DFN) ;RPC DVBAB FORM COPY
N F,A,P,N,M,R S DA=$G(DA)_",",F=396.17,R="^DVB("_F_","_DA
S N=" NOT FOUND",M="-1^RECORD"_N,DFN=$G(DFN,$P($G(@(R_"0)")),U))
S Y=$S(DA?1.N1",":0,1:"-1^INVALID ARGUMENT")
I 'Y,'$D(@(R_"0)")) S Y=M
I 'Y,'$D(^DPT(DFN,0)) S Y="-1^PATIENT"_N
S:'Y Y=$$AF(R) Q:Y
S P="+1,",A(F,P,.01)=DFN,A(F,P,2)=DUZ,A(F,P,11)="D"
S N=$$NOW^XLFDT,A(F,P,3)=N,A(F,P,4)=N
S A(F,P,9)=$P($G(@(R_"4)")),U),A(F,P,5)=2800101
D UPDATE^DIE(,"A"),ERR(.Y)
S DA=$P(@($P(R,",")_",0)"),U,3)
D:'Y WP^DIE(F,DA_",",6,"A",R_"1)"),ERR(.Y),DEL(Y,DA,F)
D:'Y WP^DIE(F,DA_",",8,"A",R_"3)"),ERR(.Y),DEL(Y,DA,F)
S:'Y Y=DA
Q
DEL(Y,DA,F,DIK) Q:'Y S DIK=$G(DIK,^DIC(F,0,"GL")) D ^DIK Q
AF(R) N C,I,J,K,L,N,X,Z S (I,C)=0,R=R_"1,",L=""
F S I=$O(@(R_I_")")) Q:'I D
.S K=$G(@(R_I_",0)")),N=$P(K,U,2),(Z,J)=0,K=+K
.S:K J=$G(^DVB(396.18,K,2)),X=$P(J,U,2),Z=DT<+J!(X'>DT&X)
.I Z!'K!'J S C=C+1 S:C>1 L=L_"; " S L=L_$S(N]"":N,1:$G(^DVB(396.18,K,0)))
Q:'C 0
Q "-1^Can't copy because th"_$S(C=1:"is form is",1:"ese forms are")_"n't active: "_L
ERR(M) N D,I,K,X S M=0,D="DIERR" Q:'$D(^TMP(D,$J))
S M=$O(^TMP(D,$J,"E","")),I=$O(^(M,"")),X=","
F K=0:1 S K=$O(^TMP(D,$J,I,"TEXT",K)) Q:'K S X=X_" "_^(K)
S M="-1^Error "_M_X K ^TMP(D,$J)
Q
RSTLIST(DVBABY,IEN) ;RPC DVBAB RESTRICTED LIST PATIENTS
; RETURNS A LIST OF PATIENTS IN THE USER'S CLAIMS SYSTEM
; RESTRICTED LIST IN THE FORMAT
; LISTNAME (OR NULL)^PTIEN^PT NAME^EXP DATE^EXP DAT INTERNAL^SSN^DOB^ICN
; $$GETICN^MPIF001 - supported ICR #2701
;
N DVB1,DVB2,DVB3,DVB4,DVB5,DVBABIEN,DVBABIE2,DVBABIE3,DVBABIE4
N DVBABPT1
N DVBABDTA,DVBABD1,DVBABD2,DVBABD3,DVBABD4,DVBABD5,DVBABD6
N DVBABD7,DVBABD8
N DVBABCNT
S DVBABCNT=0
K ^TMP("DVBARLST",DUZ)
S DVBABIEN=0,DVBABPT1=0
; FIND MATCH TO USER IEN
F S DVBABIEN=$O(^DVB(396.956,DVBABIEN)) Q:'DVBABIEN I $P(^DVB(396.956,DVBABIEN,0),"^",1)=IEN S DVBABPT1=DVBABIEN
I DVBABPT1>0 D
.;FOUND A USER, NOW FIND PATIENTS ASSIGNED TO THE USER
.W "FOUND AT ",DVBABPT1,!
.S DVBABIE4=0
.F S DVBABIE4=$O(^DVB(396.956,DVBABPT1,1,DVBABIE4)) Q:'DVBABIE4 D
..S DVBABD1="" ;LISTNAME
..S DVBABD2=$P(^DVB(396.956,DVBABPT1,1,DVBABIE4,0),"^",1) ;PT IEN
..S DVBABD3=$P(^DPT(DVBABD2,0),"^",1) ; PT EXTERNAL NAME
..S DVBABD5=$P(^DVB(396.956,DVBABPT1,1,DVBABIE4,0),"^",2) ;EXPIRATION DATE
..S Y=DVBABD5 D DD^%DT S DVBABD4=Y ;EXPIRATION DATE EXTERNAL FORMAT
..S DVBABD6=$P(^DPT(DVBABD2,0),"^",9) ; SSN
..S DVBABD7=$P(^DPT(DVBABD2,0),U,3) ; DOB
..S DVBABD8=$$GETICN^MPIF001(DVBABD2) ; ICN
..S DVBABDTA=DVBABD1_"^"_DVBABD2_"^"_DVBABD3_"^"_DVBABD4_"^"_DVBABD5_"^"_DVBABD6_U_DVBABD7_U_DVBABD8
..W "DATA: ",DVBABDTA,!
..S ^TMP("DVBARLST",DUZ,DVBABCNT)=DVBABDTA_$C(13),DVBABCNT=DVBABCNT+1
.;
.;NEXT CHECK IF USER HAS ANY LISTS ASSIGNED
.;IF SO, ADD THE PATIENTS FROM THOSE LISTS TO THE OUTPUT
.;
.S DVBABIE4=0
.F S DVBABIE4=$O(^DVB(396.956,DVBABPT1,2,DVBABIE4)) Q:'DVBABIE4 D
..S DVBABIE3=$P(^DVB(396.956,DVBABPT1,2,DVBABIE4,0),"^",1) ;LIST IEN
..W "LIST: ",DVBABIE3,!
..;
..;USER HAS A LIST. FIND IT AND ADD THOSE PATIENTS
..;
..S DVBABIE2=0
..F S DVBABIE2=$O(^DVB(396.965,DVBABIE3,1,DVBABIE2)) Q:'DVBABIE2 D
...S DVBABD1=$P(^DVB(396.965,DVBABIE3,0),"^",1) ;LOSTNAME
...S DVBABD2=$P(^DVB(396.965,DVBABIE3,1,DVBABIE2,0),"^",1) ;PT IEN
...S DVBABD3=$P(^DPT(DVBABD2,0),"^",1) ; PT EXTERNAL NAME
...S DVBABD5=$P(^DVB(396.965,DVBABIE3,1,DVBABIE2,0),"^",2) ;EXPIRATION DATE
...S Y=DVBABD5 D DD^%DT S DVBABD4=Y ;EXPIRATION DATE EXTERNAL FORMAT
...S DVBABD6=$P(^DPT(DVBABD2,0),"^",9) ; SSN
...S DVBABD7=$P(^DPT(DVBABD2,0),U,3) ; DOB
...S DVBABD8=$$GETICN^MPIF001(DVBABD2) ; ICN
...S DVBABDTA=DVBABD1_"^"_DVBABD2_"^"_DVBABD3_"^"_DVBABD4_"^"_DVBABD5_"^"_DVBABD6_U_DVBABD7_U_DVBABD8
...W "DATA: ",DVBABDTA,!
...S ^TMP("DVBARLST",DUZ,DVBABCNT)=DVBABDTA_$C(13),DVBABCNT=DVBABCNT+1
S DVBABY=$NA(^TMP("DVBARLST",DUZ))
K DVB1,DVB2,DVB3,DVB4,DVB5,DVBABIEN,DVBABPT1,DVBABIE2,DVBABIE3,DVBABIE4
K DVBABDTA,DVBABD1,DVBABD2,DVBABD3,DVBABD4,DVBABD5,DVBABD6
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBABFRM 7917 printed Dec 13, 2024@01:40:51 Page 2
DVBABFRM ;ALB/SPH - CAPRI TEMPLATE/WORKSHEETS UTILITIES ;11/17/02
+1 ;;2.7;AMIE;**53,57,90,123,181**;Apr 10, 1995;Build 38
+2 ;
DEFINE(Y,DVBIEN,DVBTYPE) ;
+1 ; DVBTYPE: 1= Form Definition, 2=Script, 3=Report
+2 NEW DVBJ
KILL ^TMP($JOB,"AMIE")
+3 SET DVBJ=0
SET DVBTYPE=DVBTYPE+2
SET Y=$NAME(^TMP($JOB,"AMIE"))
+4 FOR
SET DVBJ=$ORDER(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ))
if 'DVBJ
QUIT
Begin DoDot:1
+5 SET ^TMP($JOB,"AMIE",DVBJ)=$GET(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ,0))_$CHAR(13)
End DoDot:1
+6 QUIT
UPDATE(Y,DVBIEN,DVBTYPE,DVBLINES,DVBLINEC,DVBLINEB) ;
+1 ; DVBTYPE: 1= Form Definition, 2=Script, 3=Report
+2 NEW DVBNUM,DVBCOUNT
+3 IF DVBTYPE=1
IF DVBLINEB=0
Begin DoDot:1
+4 KILL ^DVB(396.18,DVBIEN,3)
+5 SET ^DVB(396.18,DVBIEN,3,0)=DVBLINES(1)
End DoDot:1
+6 SET DVBNUM=DVBLINEB
SET DVBCOUNT=1
SET DVBTYPE=DVBTYPE+2
+7 IF DVBLINEB=0
SET DVBCOUNT=2
+8 IF DVBNUM>0
SET DVBNUM=DVBNUM-1
+9 FOR
SET DVBNUM=DVBNUM+1
if DVBNUM=(DVBLINEC+DVBLINEB)
QUIT
Begin DoDot:1
+10 SET ^DVB(396.18,DVBIEN,DVBTYPE,DVBNUM,0)=DVBLINES(DVBCOUNT)
SET DVBCOUNT=DVBCOUNT+1
End DoDot:1
+11 QUIT
SAVE(Y,DVBIEN,DVBLINES,DVBLINEC,DVBLINEB,DVBTPSV) ;
+1 ; DVBTPSV: 3/NULL=NORMAL GLOBAL
+2 NEW DVBNUM,DVBCOUNT
+3 SET DVBTPSV=$GET(DVBTPSV,3)
SET DVBNUM=DVBLINEB
SET DVBCOUNT=1
+4 IF DVBLINEB=0
Begin DoDot:1
+5 KILL ^DVB(396.17,DVBIEN,DVBTPSV)
+6 SET ^DVB(396.17,DVBIEN,DVBTPSV,0)=DVBLINES(1)
SET DVBCOUNT=2
End DoDot:1
+7 IF DVBNUM>0
SET DVBNUM=DVBNUM-1
+8 FOR
SET DVBNUM=DVBNUM+1
if DVBNUM=(DVBLINEC+DVBLINEB)
QUIT
Begin DoDot:1
+9 SET ^DVB(396.17,DVBIEN,DVBTPSV,DVBNUM,0)=DVBLINES(DVBCOUNT)
SET DVBCOUNT=DVBCOUNT+1
End DoDot:1
+10 ; SET Y TO NUMBER OF LINES IN THE GLOBAL FOR GUI VERIFICATION
+11 SET Y=+$PIECE($GET(^DVB(396.17,DVBIEN,DVBTPSV,0)),U,3)
+12 QUIT
LOAD(Y,DVBIEN,DVBTPSV) ;
+1 ; DVBTPSV: 3/NULL=NORMAL GLOBAL
+2 NEW DVBABCNT,DVBABIEN
KILL ^TMP("DVBAFRML",DUZ)
+3 SET DVBTPSV=$GET(DVBTPSV,3)
SET DVBABCNT=1
SET DVBABIEN=0
SET Y=$NAME(^TMP("DVBAFRML",DUZ))
+4 FOR
SET DVBABIEN=$ORDER(^DVB(396.17,DVBIEN,DVBTPSV,DVBABIEN))
if 'DVBABIEN
QUIT
Begin DoDot:1
+5 SET ^TMP("DVBAFRML",DUZ,DVBABCNT-1)=$GET(^DVB(396.17,DVBIEN,DVBTPSV,DVBABCNT,0))_$CHAR(13)
SET DVBABCNT=DVBABCNT+1
End DoDot:1
+6 QUIT
CCOW(Y,F) ;RPC DVBAB CCOW
+1 SET Y=-1
+2 if F=1
SET Y=$$SITE^VASITE
+3 if F=2
SET Y=$$PROD^XUPROD
+4 QUIT
U1N4(Y,ARR) ;RPC DVBAB FETCH 1U4N
+1 NEW I,X
SET I=""
SET Y=$NAME(^TMP("DVBU1N4",$JOB))
KILL @Y
+2 FOR
SET I=$ORDER(ARR(I))
if I=""
QUIT
Begin DoDot:1
+3 SET X=$PIECE($GET(^DVB(396.17,ARR(I),0)),U)
+4 if X
SET X=$$GET1^DIQ(2,X_",",.0905)
+5 SET ^TMP("DVBU1N4",$JOB,I)=ARR(I)_U_$SELECT(X]"":X,1:"?????")
End DoDot:1
+6 QUIT
DELETE(Y,IEN) ;RPC DVBAB FORM DATA BACKUP DELETE
+1 SET IEN=$GET(IEN)
SET Y=$SELECT(IEN?1.N:0,1:"1^INVALID ARGUMENT")
+2 IF 'Y
IF '$DATA(^DVB(396.17,IEN,0))
SET Y="1^RECORD NOT FOUND"
+3 if 'Y&$DATA(^DVB(396.17,IEN,9))
KILL ^DVB(396.17,IEN,9)
+4 QUIT
BACKUP(Y,IEN,TXT) ;RPC DVBAB FORM DATA BACKUP
+1 NEW F,S,A,N,M,R
SET F=396.17
SET M="-1^RECORD NOT FOUND"
SET IEN=$GET(IEN)_","
+2 SET R="^DVB("_F_","_IEN
SET Y=$SELECT(IEN?1.N1",":0,1:"-1^INVALID ARGUMENT")
+3 IF 'Y
IF '$DATA(@(R_"0)"))
SET Y=M
+4 if Y
QUIT
SET M=$PIECE($GET(@(R_"3,0)")),U,3)
if 'M
QUIT
+5 SET S=396.19
SET N="+1,"_IEN
SET TXT=$GET(TXT)
+6 SET A(S,N,.01)=$$NOW^XLFDT
+7 SET A(S,N,2)=$SELECT(TXT]"":TXT,1:"Automatic Save by "_$PIECE($GET(^VA(200,DUZ,0)),U))
+8 DO UPDATE^DIE(,"A")
DO ERR(.Y)
+9 IF 'Y
Begin DoDot:1
+10 SET N=$PIECE($GET(@(R_"9,0)")),U,3)_","_IEN
+11 DO WP^DIE(S,N,1,"A",R_"3)")
DO ERR(.Y)
+12 if 'Y
DO WP^DIE(S,N,3,"A",R_"1)")
DO ERR(.Y)
End DoDot:1
+13 if 'Y
SET Y=M
+14 QUIT
RESTORE(Y,IEN,SN) ;RPC DVBAB FORM DATA BACKUP RESTORE
+1 NEW Z,F,T,M,N,R
+2 ;
+3 SET IEN=$GET(IEN)_","
+4 SET SN=$GET(SN)
+5 SET N=396.17
+6 SET R="^DVB("_N_","_IEN
+7 SET Y=$SELECT(IEN?1.N1","&(SN?1.N):0,1:"-1^INVALID ARGUMENT")
+8 SET M="-1^RECORD NOT FOUND"
+9 SET SN=R_"9,"_SN_","
+10 SET F="RESTORE "
+11 ;
+12 IF 'Y
IF '$DATA(@(R_"0)"))
SET Y=M
+13 IF 'Y
IF '$DATA(@(R_"9,0)"))
SET $PIECE(M,U,2)="SUB-"_$PIECE(M,U,2)
SET Y=M
+14 IF 'Y
IF '$DATA(@(SN_"0)"))
SET $PIECE(M,U,2)=F_$PIECE(M,U,2)
SET Y=M
+15 if Y
QUIT
SET M=$PIECE($GET(@(SN_"1,0)")),U,3)
SET F=F_"FAILED: "
if 'M
QUIT
+16 ;
+17 MERGE ^XTMP("DVBA",$JOB,"NODE3")=@(R_"3)")
KILL @(R_"3)")
+18 DO WP^DIE(N,IEN,8,"A",SN_"1)")
DO ERR(.Y)
+19 IF Y
KILL @(R_"3)")
MERGE @(R_"3)")=^XTMP("DVBA",$JOB,"NODE3")
SET $PIECE(Y,U,2)=F_$PIECE(Y,U,2)
QUIT
+20 ;
+21 MERGE ^XTMP("DVBA",$JOB,"NODE1")=@(R_"1)")
KILL @(R_"1)")
+22 DO WP^DIE(N,IEN,6,"A",SN_"3)")
DO ERR(.Y)
IF 'Y
SET Y=M
QUIT
+23 KILL @(R_"3)"),@(R_"1)")
+24 MERGE @(R_"3)")=^XTMP("DVBA",$JOB,"NODE3"),@(R_"1)")=^XTMP("DVBA",$JOB,"NODE1")
+25 SET $PIECE(Y,U,2)=F_$PIECE(Y,U,2)
+26 ;
+27 ;cleanup ^xtmp global
+28 KILL ^XTMP("DVBA",$JOB)
+29 QUIT
COPY(Y,DA,DFN) ;RPC DVBAB FORM COPY
+1 NEW F,A,P,N,M,R
SET DA=$GET(DA)_","
SET F=396.17
SET R="^DVB("_F_","_DA
+2 SET N=" NOT FOUND"
SET M="-1^RECORD"_N
SET DFN=$GET(DFN,$PIECE($GET(@(R_"0)")),U))
+3 SET Y=$SELECT(DA?1.N1",":0,1:"-1^INVALID ARGUMENT")
+4 IF 'Y
IF '$DATA(@(R_"0)"))
SET Y=M
+5 IF 'Y
IF '$DATA(^DPT(DFN,0))
SET Y="-1^PATIENT"_N
+6 if 'Y
SET Y=$$AF(R)
if Y
QUIT
+7 SET P="+1,"
SET A(F,P,.01)=DFN
SET A(F,P,2)=DUZ
SET A(F,P,11)="D"
+8 SET N=$$NOW^XLFDT
SET A(F,P,3)=N
SET A(F,P,4)=N
+9 SET A(F,P,9)=$PIECE($GET(@(R_"4)")),U)
SET A(F,P,5)=2800101
+10 DO UPDATE^DIE(,"A")
DO ERR(.Y)
+11 SET DA=$PIECE(@($PIECE(R,",")_",0)"),U,3)
+12 if 'Y
DO WP^DIE(F,DA_",",6,"A",R_"1)")
DO ERR(.Y)
DO DEL(Y,DA,F)
+13 if 'Y
DO WP^DIE(F,DA_",",8,"A",R_"3)")
DO ERR(.Y)
DO DEL(Y,DA,F)
+14 if 'Y
SET Y=DA
+15 QUIT
DEL(Y,DA,F,DIK) if 'Y
QUIT
SET DIK=$GET(DIK,^DIC(F,0,"GL"))
DO ^DIK
QUIT
AF(R) NEW C,I,J,K,L,N,X,Z
SET (I,C)=0
SET R=R_"1,"
SET L=""
+1 FOR
SET I=$ORDER(@(R_I_")"))
if 'I
QUIT
Begin DoDot:1
+2 SET K=$GET(@(R_I_",0)"))
SET N=$PIECE(K,U,2)
SET (Z,J)=0
SET K=+K
+3 if K
SET J=$GET(^DVB(396.18,K,2))
SET X=$PIECE(J,U,2)
SET Z=DT<+J!(X'>DT&X)
+4 IF Z!'K!'J
SET C=C+1
if C>1
SET L=L_"; "
SET L=L_$SELECT(N]"":N,1:$GET(^DVB(396.18,K,0)))
End DoDot:1
+5 if 'C
QUIT 0
+6 QUIT "-1^Can't copy because th"_$SELECT(C=1:"is form is",1:"ese forms are")_"n't active: "_L
ERR(M) NEW D,I,K,X
SET M=0
SET D="DIERR"
if '$DATA(^TMP(D,$JOB))
QUIT
+1 SET M=$ORDER(^TMP(D,$JOB,"E",""))
SET I=$ORDER(^(M,""))
SET X=","
+2 FOR K=0:1
SET K=$ORDER(^TMP(D,$JOB,I,"TEXT",K))
if 'K
QUIT
SET X=X_" "_^(K)
+3 SET M="-1^Error "_M_X
KILL ^TMP(D,$JOB)
+4 QUIT
RSTLIST(DVBABY,IEN) ;RPC DVBAB RESTRICTED LIST PATIENTS
+1 ; RETURNS A LIST OF PATIENTS IN THE USER'S CLAIMS SYSTEM
+2 ; RESTRICTED LIST IN THE FORMAT
+3 ; LISTNAME (OR NULL)^PTIEN^PT NAME^EXP DATE^EXP DAT INTERNAL^SSN^DOB^ICN
+4 ; $$GETICN^MPIF001 - supported ICR #2701
+5 ;
+6 NEW DVB1,DVB2,DVB3,DVB4,DVB5,DVBABIEN,DVBABIE2,DVBABIE3,DVBABIE4
+7 NEW DVBABPT1
+8 NEW DVBABDTA,DVBABD1,DVBABD2,DVBABD3,DVBABD4,DVBABD5,DVBABD6
+9 NEW DVBABD7,DVBABD8
+10 NEW DVBABCNT
+11 SET DVBABCNT=0
+12 KILL ^TMP("DVBARLST",DUZ)
+13 SET DVBABIEN=0
SET DVBABPT1=0
+14 ; FIND MATCH TO USER IEN
+15 FOR
SET DVBABIEN=$ORDER(^DVB(396.956,DVBABIEN))
if 'DVBABIEN
QUIT
IF $PIECE(^DVB(396.956,DVBABIEN,0),"^",1)=IEN
SET DVBABPT1=DVBABIEN
+16 IF DVBABPT1>0
Begin DoDot:1
+17 ;FOUND A USER, NOW FIND PATIENTS ASSIGNED TO THE USER
+18 WRITE "FOUND AT ",DVBABPT1,!
+19 SET DVBABIE4=0
+20 FOR
SET DVBABIE4=$ORDER(^DVB(396.956,DVBABPT1,1,DVBABIE4))
if 'DVBABIE4
QUIT
Begin DoDot:2
+21 ;LISTNAME
SET DVBABD1=""
+22 ;PT IEN
SET DVBABD2=$PIECE(^DVB(396.956,DVBABPT1,1,DVBABIE4,0),"^",1)
+23 ; PT EXTERNAL NAME
SET DVBABD3=$PIECE(^DPT(DVBABD2,0),"^",1)
+24 ;EXPIRATION DATE
SET DVBABD5=$PIECE(^DVB(396.956,DVBABPT1,1,DVBABIE4,0),"^",2)
+25 ;EXPIRATION DATE EXTERNAL FORMAT
SET Y=DVBABD5
DO DD^%DT
SET DVBABD4=Y
+26 ; SSN
SET DVBABD6=$PIECE(^DPT(DVBABD2,0),"^",9)
+27 ; DOB
SET DVBABD7=$PIECE(^DPT(DVBABD2,0),U,3)
+28 ; ICN
SET DVBABD8=$$GETICN^MPIF001(DVBABD2)
+29 SET DVBABDTA=DVBABD1_"^"_DVBABD2_"^"_DVBABD3_"^"_DVBABD4_"^"_DVBABD5_"^"_DVBABD6_U_DVBABD7_U_DVBABD8
+30 WRITE "DATA: ",DVBABDTA,!
+31 SET ^TMP("DVBARLST",DUZ,DVBABCNT)=DVBABDTA_$CHAR(13)
SET DVBABCNT=DVBABCNT+1
End DoDot:2
+32 ;
+33 ;NEXT CHECK IF USER HAS ANY LISTS ASSIGNED
+34 ;IF SO, ADD THE PATIENTS FROM THOSE LISTS TO THE OUTPUT
+35 ;
+36 SET DVBABIE4=0
+37 FOR
SET DVBABIE4=$ORDER(^DVB(396.956,DVBABPT1,2,DVBABIE4))
if 'DVBABIE4
QUIT
Begin DoDot:2
+38 ;LIST IEN
SET DVBABIE3=$PIECE(^DVB(396.956,DVBABPT1,2,DVBABIE4,0),"^",1)
+39 WRITE "LIST: ",DVBABIE3,!
+40 ;
+41 ;USER HAS A LIST. FIND IT AND ADD THOSE PATIENTS
+42 ;
+43 SET DVBABIE2=0
+44 FOR
SET DVBABIE2=$ORDER(^DVB(396.965,DVBABIE3,1,DVBABIE2))
if 'DVBABIE2
QUIT
Begin DoDot:3
+45 ;LOSTNAME
SET DVBABD1=$PIECE(^DVB(396.965,DVBABIE3,0),"^",1)
+46 ;PT IEN
SET DVBABD2=$PIECE(^DVB(396.965,DVBABIE3,1,DVBABIE2,0),"^",1)
+47 ; PT EXTERNAL NAME
SET DVBABD3=$PIECE(^DPT(DVBABD2,0),"^",1)
+48 ;EXPIRATION DATE
SET DVBABD5=$PIECE(^DVB(396.965,DVBABIE3,1,DVBABIE2,0),"^",2)
+49 ;EXPIRATION DATE EXTERNAL FORMAT
SET Y=DVBABD5
DO DD^%DT
SET DVBABD4=Y
+50 ; SSN
SET DVBABD6=$PIECE(^DPT(DVBABD2,0),"^",9)
+51 ; DOB
SET DVBABD7=$PIECE(^DPT(DVBABD2,0),U,3)
+52 ; ICN
SET DVBABD8=$$GETICN^MPIF001(DVBABD2)
+53 SET DVBABDTA=DVBABD1_"^"_DVBABD2_"^"_DVBABD3_"^"_DVBABD4_"^"_DVBABD5_"^"_DVBABD6_U_DVBABD7_U_DVBABD8
+54 WRITE "DATA: ",DVBABDTA,!
+55 SET ^TMP("DVBARLST",DUZ,DVBABCNT)=DVBABDTA_$CHAR(13)
SET DVBABCNT=DVBABCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+56 SET DVBABY=$NAME(^TMP("DVBARLST",DUZ))
+57 KILL DVB1,DVB2,DVB3,DVB4,DVB5,DVBABIEN,DVBABPT1,DVBABIE2,DVBABIE3,DVBABIE4
+58 KILL DVBABDTA,DVBABD1,DVBABD2,DVBABD3,DVBABD4,DVBABD5,DVBABD6
+59 QUIT
