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

DVBABFRM.m

Go to the documentation of this file. 
  1. DVBABFRM ;ALB/SPH - CAPRI TEMPLATE/WORKSHEETS UTILITIES ;11/17/02
  1.  ;;2.7;AMIE;**53,57,90,123,181**;Apr 10, 1995;Build 38
  1.  ;
  1. DEFINE(Y,DVBIEN,DVBTYPE) ;
  1.  ; DVBTYPE:  1= Form Definition, 2=Script, 3=Report
  1.  N DVBJ K ^TMP($J,"AMIE")
  1.  S DVBJ=0,DVBTYPE=DVBTYPE+2,Y=$NA(^TMP($J,"AMIE"))
  1.  F  S DVBJ=$O(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ)) Q:'DVBJ  D
  1.  .S ^TMP($J,"AMIE",DVBJ)=$G(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ,0))_$C(13)
  1.  Q
  1. UPDATE(Y,DVBIEN,DVBTYPE,DVBLINES,DVBLINEC,DVBLINEB) ;
  1.  ; DVBTYPE:  1= Form Definition, 2=Script, 3=Report
  1.  N DVBNUM,DVBCOUNT
  1.  I DVBTYPE=1,DVBLINEB=0 D
  1.  .K ^DVB(396.18,DVBIEN,3)
  1.  .S ^DVB(396.18,DVBIEN,3,0)=DVBLINES(1)
  1.  S DVBNUM=DVBLINEB,DVBCOUNT=1,DVBTYPE=DVBTYPE+2
  1.  I DVBLINEB=0 S DVBCOUNT=2
  1.  I DVBNUM>0 S DVBNUM=DVBNUM-1
  1.  F  S DVBNUM=DVBNUM+1 Q:DVBNUM=(DVBLINEC+DVBLINEB)  D
  1.  .S ^DVB(396.18,DVBIEN,DVBTYPE,DVBNUM,0)=DVBLINES(DVBCOUNT),DVBCOUNT=DVBCOUNT+1
  1.  Q
  1. SAVE(Y,DVBIEN,DVBLINES,DVBLINEC,DVBLINEB,DVBTPSV) ;
  1.  ; DVBTPSV:  3/NULL=NORMAL GLOBAL
  1.  N DVBNUM,DVBCOUNT
  1.  S DVBTPSV=$G(DVBTPSV,3),DVBNUM=DVBLINEB,DVBCOUNT=1
  1.  I DVBLINEB=0 D
  1.  .K ^DVB(396.17,DVBIEN,DVBTPSV)
  1.  .S ^DVB(396.17,DVBIEN,DVBTPSV,0)=DVBLINES(1),DVBCOUNT=2
  1.  I DVBNUM>0 S DVBNUM=DVBNUM-1
  1.  F  S DVBNUM=DVBNUM+1 Q:DVBNUM=(DVBLINEC+DVBLINEB)  D
  1.  .S ^DVB(396.17,DVBIEN,DVBTPSV,DVBNUM,0)=DVBLINES(DVBCOUNT),DVBCOUNT=DVBCOUNT+1
  1.  ; SET Y TO NUMBER OF LINES IN THE GLOBAL FOR GUI VERIFICATION
  1.  S Y=+$P($G(^DVB(396.17,DVBIEN,DVBTPSV,0)),U,3)
  1.  Q
  1. LOAD(Y,DVBIEN,DVBTPSV) ;
  1.  ; DVBTPSV:  3/NULL=NORMAL GLOBAL
  1.  N DVBABCNT,DVBABIEN K ^TMP("DVBAFRML",DUZ)
  1.  S DVBTPSV=$G(DVBTPSV,3),DVBABCNT=1,DVBABIEN=0,Y=$NA(^TMP("DVBAFRML",DUZ))
  1.  F  S DVBABIEN=$O(^DVB(396.17,DVBIEN,DVBTPSV,DVBABIEN)) Q:'DVBABIEN  D
  1.  .S ^TMP("DVBAFRML",DUZ,DVBABCNT-1)=$G(^DVB(396.17,DVBIEN,DVBTPSV,DVBABCNT,0))_$C(13),DVBABCNT=DVBABCNT+1
  1.  Q
  1. CCOW(Y,F) ;RPC DVBAB CCOW
  1.  S Y=-1
  1.  S:F=1 Y=$$SITE^VASITE
  1.  S:F=2 Y=$$PROD^XUPROD
  1.  Q
  1. U1N4(Y,ARR) ;RPC DVBAB FETCH 1U4N
  1.  N I,X S I="",Y=$NA(^TMP("DVBU1N4",$J)) K @Y
  1.  F  S I=$O(ARR(I)) Q:I=""  D
  1.  .S X=$P($G(^DVB(396.17,ARR(I),0)),U)
  1.  .S:X X=$$GET1^DIQ(2,X_",",.0905)
  1.  .S ^TMP("DVBU1N4",$J,I)=ARR(I)_U_$S(X]"":X,1:"?????")
  1.  Q
  1. DELETE(Y,IEN) ;RPC DVBAB FORM DATA BACKUP DELETE
  1.  S IEN=$G(IEN),Y=$S(IEN?1.N:0,1:"1^INVALID ARGUMENT")
  1.  I 'Y,'$D(^DVB(396.17,IEN,0)) S Y="1^RECORD NOT FOUND"
  1.  K:'Y&$D(^DVB(396.17,IEN,9)) ^DVB(396.17,IEN,9)
  1.  Q
  1. BACKUP(Y,IEN,TXT) ;RPC DVBAB FORM DATA BACKUP
  1.  N F,S,A,N,M,R S F=396.17,M="-1^RECORD NOT FOUND",IEN=$G(IEN)_","
  1.  S R="^DVB("_F_","_IEN,Y=$S(IEN?1.N1",":0,1:"-1^INVALID ARGUMENT")
  1.  I 'Y,'$D(@(R_"0)")) S Y=M
  1.  Q:Y  S M=$P($G(@(R_"3,0)")),U,3) Q:'M
  1.  S S=396.19,N="+1,"_IEN,TXT=$G(TXT)
  1.  S A(S,N,.01)=$$NOW^XLFDT
  1.  S A(S,N,2)=$S(TXT]"":TXT,1:"Automatic Save by "_$P($G(^VA(200,DUZ,0)),U))
  1.  D UPDATE^DIE(,"A"),ERR(.Y)
  1.  I 'Y D
  1.  .S N=$P($G(@(R_"9,0)")),U,3)_","_IEN
  1.  .D WP^DIE(S,N,1,"A",R_"3)"),ERR(.Y)
  1.  .D:'Y WP^DIE(S,N,3,"A",R_"1)"),ERR(.Y)
  1.  S:'Y Y=M
  1.  Q
  1. RESTORE(Y,IEN,SN) ;RPC DVBAB FORM DATA BACKUP RESTORE
  1.  N Z,F,T,M,N,R
  1.  ;
  1.  S IEN=$G(IEN)_","
  1.  S SN=$G(SN)
  1.  S N=396.17
  1.  S R="^DVB("_N_","_IEN
  1.  S Y=$S(IEN?1.N1","&(SN?1.N):0,1:"-1^INVALID ARGUMENT")
  1.  S M="-1^RECORD NOT FOUND"
  1.  S SN=R_"9,"_SN_","
  1.  S F="RESTORE "
  1.  ;
  1.  I 'Y,'$D(@(R_"0)")) S Y=M
  1.  I 'Y,'$D(@(R_"9,0)")) S $P(M,U,2)="SUB-"_$P(M,U,2),Y=M
  1.  I 'Y,'$D(@(SN_"0)")) S $P(M,U,2)=F_$P(M,U,2),Y=M
  1.  Q:Y  S M=$P($G(@(SN_"1,0)")),U,3),F=F_"FAILED: " Q:'M
  1.  ;
  1.  M ^XTMP("DVBA",$J,"NODE3")=@(R_"3)") K @(R_"3)")
  1.  D WP^DIE(N,IEN,8,"A",SN_"1)"),ERR(.Y)
  1.  I Y  K @(R_"3)") M @(R_"3)")=^XTMP("DVBA",$J,"NODE3") S $P(Y,U,2)=F_$P(Y,U,2) Q
  1.  ;
  1.  M ^XTMP("DVBA",$J,"NODE1")=@(R_"1)") K @(R_"1)")
  1.  D WP^DIE(N,IEN,6,"A",SN_"3)"),ERR(.Y) I 'Y S Y=M Q
  1.  K @(R_"3)"),@(R_"1)")
  1.  M @(R_"3)")=^XTMP("DVBA",$J,"NODE3"),@(R_"1)")=^XTMP("DVBA",$J,"NODE1")
  1.  S $P(Y,U,2)=F_$P(Y,U,2)
  1.  ;
  1.  ;cleanup ^xtmp global
  1.  K ^XTMP("DVBA",$J)
  1.  Q
  1. COPY(Y,DA,DFN) ;RPC DVBAB FORM COPY
  1.  N F,A,P,N,M,R S DA=$G(DA)_",",F=396.17,R="^DVB("_F_","_DA
  1.  S N=" NOT FOUND",M="-1^RECORD"_N,DFN=$G(DFN,$P($G(@(R_"0)")),U))
  1.  S Y=$S(DA?1.N1",":0,1:"-1^INVALID ARGUMENT")
  1.  I 'Y,'$D(@(R_"0)")) S Y=M
  1.  I 'Y,'$D(^DPT(DFN,0)) S Y="-1^PATIENT"_N
  1.  S:'Y Y=$$AF(R) Q:Y
  1.  S P="+1,",A(F,P,.01)=DFN,A(F,P,2)=DUZ,A(F,P,11)="D"
  1.  S N=$$NOW^XLFDT,A(F,P,3)=N,A(F,P,4)=N
  1.  S A(F,P,9)=$P($G(@(R_"4)")),U),A(F,P,5)=2800101
  1.  D UPDATE^DIE(,"A"),ERR(.Y)
  1.  S DA=$P(@($P(R,",")_",0)"),U,3)
  1.  D:'Y WP^DIE(F,DA_",",6,"A",R_"1)"),ERR(.Y),DEL(Y,DA,F)
  1.  D:'Y WP^DIE(F,DA_",",8,"A",R_"3)"),ERR(.Y),DEL(Y,DA,F)
  1.  S:'Y Y=DA
  1.  Q
  1. DEL(Y,DA,F,DIK) Q:'Y  S DIK=$G(DIK,^DIC(F,0,"GL")) D ^DIK Q
  1. AF(R) N C,I,J,K,L,N,X,Z S (I,C)=0,R=R_"1,",L=""
  1.  F  S I=$O(@(R_I_")")) Q:'I  D
  1.  .S K=$G(@(R_I_",0)")),N=$P(K,U,2),(Z,J)=0,K=+K
  1.  .S:K J=$G(^DVB(396.18,K,2)),X=$P(J,U,2),Z=DT<+J!(X'>DT&X)
  1.  .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)))
  1.  Q:'C 0
  1.  Q "-1^Can't copy because th"_$S(C=1:"is form is",1:"ese forms are")_"n't active: "_L
  1. ERR(M) N D,I,K,X  S M=0,D="DIERR" Q:'$D(^TMP(D,$J))
  1.  S M=$O(^TMP(D,$J,"E","")),I=$O(^(M,"")),X=","
  1.  F K=0:1 S K=$O(^TMP(D,$J,I,"TEXT",K)) Q:'K  S X=X_" "_^(K)
  1.  S M="-1^Error "_M_X K ^TMP(D,$J)
  1.  Q
  1. RSTLIST(DVBABY,IEN) ;RPC DVBAB RESTRICTED LIST PATIENTS
  1.  ; RETURNS A LIST OF PATIENTS IN THE USER'S CLAIMS SYSTEM
  1.  ; RESTRICTED LIST IN THE FORMAT
  1.  ; LISTNAME (OR NULL)^PTIEN^PT NAME^EXP DATE^EXP DAT INTERNAL^SSN^DOB^ICN
  1.  ;  $$GETICN^MPIF001 - supported ICR #2701
  1.  ;
  1.  N DVB1,DVB2,DVB3,DVB4,DVB5,DVBABIEN,DVBABIE2,DVBABIE3,DVBABIE4
  1.  N DVBABPT1
  1.  N DVBABDTA,DVBABD1,DVBABD2,DVBABD3,DVBABD4,DVBABD5,DVBABD6
  1.  N DVBABD7,DVBABD8
  1.  N DVBABCNT
  1.  S DVBABCNT=0
  1.  K ^TMP("DVBARLST",DUZ)
  1.  S DVBABIEN=0,DVBABPT1=0
  1.  ; FIND MATCH TO USER IEN
  1.  F  S DVBABIEN=$O(^DVB(396.956,DVBABIEN)) Q:'DVBABIEN  I $P(^DVB(396.956,DVBABIEN,0),"^",1)=IEN S DVBABPT1=DVBABIEN
  1.  I DVBABPT1>0  D
  1.  .;FOUND A USER, NOW FIND PATIENTS ASSIGNED TO THE USER
  1.  .W "FOUND AT ",DVBABPT1,!
  1.  .S DVBABIE4=0
  1.  .F  S DVBABIE4=$O(^DVB(396.956,DVBABPT1,1,DVBABIE4)) Q:'DVBABIE4  D
  1.  ..S DVBABD1=""  ;LISTNAME
  1.  ..S DVBABD2=$P(^DVB(396.956,DVBABPT1,1,DVBABIE4,0),"^",1)  ;PT IEN
  1.  ..S DVBABD3=$P(^DPT(DVBABD2,0),"^",1) ; PT EXTERNAL NAME
  1.  ..S DVBABD5=$P(^DVB(396.956,DVBABPT1,1,DVBABIE4,0),"^",2)  ;EXPIRATION DATE
  1.  ..S Y=DVBABD5 D DD^%DT S DVBABD4=Y  ;EXPIRATION DATE EXTERNAL FORMAT
  1.  ..S DVBABD6=$P(^DPT(DVBABD2,0),"^",9) ; SSN
  1.  ..S DVBABD7=$P(^DPT(DVBABD2,0),U,3)  ; DOB
  1.  ..S DVBABD8=$$GETICN^MPIF001(DVBABD2)  ; ICN
  1.  ..S DVBABDTA=DVBABD1_"^"_DVBABD2_"^"_DVBABD3_"^"_DVBABD4_"^"_DVBABD5_"^"_DVBABD6_U_DVBABD7_U_DVBABD8
  1.  ..W "DATA: ",DVBABDTA,!
  1.  ..S ^TMP("DVBARLST",DUZ,DVBABCNT)=DVBABDTA_$C(13),DVBABCNT=DVBABCNT+1
  1.  .;
  1.  .;NEXT CHECK IF USER HAS ANY LISTS ASSIGNED
  1.  .;IF SO, ADD THE PATIENTS FROM THOSE LISTS TO THE OUTPUT
  1.  .;
  1.  .S DVBABIE4=0
  1.  .F  S DVBABIE4=$O(^DVB(396.956,DVBABPT1,2,DVBABIE4)) Q:'DVBABIE4  D
  1.  ..S DVBABIE3=$P(^DVB(396.956,DVBABPT1,2,DVBABIE4,0),"^",1)  ;LIST IEN
  1.  ..W "LIST: ",DVBABIE3,!
  1.  ..;
  1.  ..;USER HAS A LIST. FIND IT AND ADD THOSE PATIENTS
  1.  ..;
  1.  ..S DVBABIE2=0
  1.  ..F  S DVBABIE2=$O(^DVB(396.965,DVBABIE3,1,DVBABIE2))  Q:'DVBABIE2  D 
  1.  ...S DVBABD1=$P(^DVB(396.965,DVBABIE3,0),"^",1)  ;LOSTNAME
  1.  ...S DVBABD2=$P(^DVB(396.965,DVBABIE3,1,DVBABIE2,0),"^",1)  ;PT IEN
  1.  ...S DVBABD3=$P(^DPT(DVBABD2,0),"^",1) ; PT EXTERNAL NAME
  1.  ...S DVBABD5=$P(^DVB(396.965,DVBABIE3,1,DVBABIE2,0),"^",2)  ;EXPIRATION DATE
  1.  ...S Y=DVBABD5 D DD^%DT S DVBABD4=Y  ;EXPIRATION DATE EXTERNAL FORMAT
  1.  ...S DVBABD6=$P(^DPT(DVBABD2,0),"^",9) ; SSN
  1.  ...S DVBABD7=$P(^DPT(DVBABD2,0),U,3)  ; DOB
  1.  ...S DVBABD8=$$GETICN^MPIF001(DVBABD2)  ; ICN
  1.  ...S DVBABDTA=DVBABD1_"^"_DVBABD2_"^"_DVBABD3_"^"_DVBABD4_"^"_DVBABD5_"^"_DVBABD6_U_DVBABD7_U_DVBABD8
  1.  ...W "DATA: ",DVBABDTA,!
  1.  ...S ^TMP("DVBARLST",DUZ,DVBABCNT)=DVBABDTA_$C(13),DVBABCNT=DVBABCNT+1
  1.  S DVBABY=$NA(^TMP("DVBARLST",DUZ))
  1.  K DVB1,DVB2,DVB3,DVB4,DVB5,DVBABIEN,DVBABPT1,DVBABIE2,DVBABIE3,DVBABIE4
  1.  K DVBABDTA,DVBABD1,DVBABD2,DVBABD3,DVBABD4,DVBABD5,DVBABD6
  1.  Q