BDMGEB ; cmi/anch/maw - BDM DMS GUI Filing Routine ;
;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1**;JAN 17, 2008
;
;
;
;1/25/2005 added in REGSV a check for DX
;3/22/2006 added diagnosis save to complications list add, subroutine CMPA
;
DEBUG(BDMRET,BDMSTR) ;-- debugger
D DEBUG^%Serenji("DME^BDMGE(.BDMRET,.BDMSTR)")
Q
;
CMPL(BDMRET,BDMSTR) ;-- save complications list
N P,BDMDA,BDMIEN,BDMREG,BDMREGE,BDMCL,BDMCNT
S P="|"
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,0)="T00050RETURN"_$C(30)
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
S BDMREGE=$P(BDMSTR,P)
S BDMCNT=0
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
I $P(BDMSTR,P,2)="" D Q
. N BDMDA
. S BDMDA=0 F S BDMDA=$O(^ACM(42.1,"RG",BDMREG,BDMDA)) Q:'BDMDA D
.. N BDMIEN
.. S BDMIEN=0 F S BDMIEN=$O(^ACM(42.1,"RG",BDMREG,BDMDA,BDMIEN)) Q:'BDMIEN D
... S DA(1)=BDMDA,DA=BDMIEN,DIK="^ACM(42.1,"_DA(1)_",""RG"","
... D ^DIK
F I=2:1 D Q:$P(BDMSTR,P,I)=""
. Q:$P(BDMSTR,P,I)=""
. S BDMCNT=BDMCNT+1
. S BDMCL(BDMCNT)=$P(BDMSTR,P,I)
D CLNCL(.BDMCL,BDMREG)
D ADDCL(.BDMCL,BDMREG)
S ^BDMTMP($J,1)=$C(31)_$G(BDMERR)
Q
;
CMPA(BDMRET,BDMSTR) ;-- add complication to list
N P,BDMDA,BDMIEN,BDMREG,BDMREGE,BDMCL,BDMICD
S P="|"
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,0)="T00050Error"_$C(30)
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
S BDMREG=$P(BDMSTR,P)
S BDMCL=$P(BDMSTR,P,2)
S BDMCNT=0
D ADDCL(BDMCL,BDMREG)
S ^BDMTMP($J,2)=$C(31)_$G(BDMERR)
Q
;
CMPDXA(BDMRET,BDMSTR) ;-- add complication diagnosis to list
N P,BDMDA,BDMIEN,BDMREG,BDMREGE,BDMCL,BDMICD
S P="|"
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,0)="T00050RETURN"_$C(30)
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
S BDMREG=$P(BDMSTR,P)
S BDMCL=$P(BDMSTR,P,2)
S BDMICD=$P(BDMSTR,P,3)
S BDMCNT=0
D ADDCLDX(BDMCL,BDMICD)
S ^BDMTMP($J,1)=$C(31)_$G(BDMERR)
Q
;
CLNCL(CL,REG) ;-- clean up deleted complications first
N BDMDA,BDMIEN,BDMCL
S BDMDA=0 F S BDMDA=$O(CL(BDMDA)) Q:'BDMDA D
. S BDMCL=$G(CL(BDMDA))
. S BDMCLI=$O(^ACM(42.1,"B",BDMCL,0))
. I BDMCLI,$D(^ACM(42.1,"RG",REG,BDMCL)) K CL(BDMDA)
N BDMDA
S BDMDA=0 F S BDMDA=$O(CL(BDMDA)) Q:'BDMDA D
. N BDMCL,BDMIEN
. S BDMCL=$G(CL,BDMDA)
. S BDMCLI=$O(^ACM(42.1,"B",BDMCL,0))
. Q:'BDMCLI
. S BDMIEN=$O(^ACM(42.1,"RG",REG,BDMCLI,0))
. Q:'BDMIEN
. S DA(1)=BDMCLI,DA=BDMIEN,DIK="^ACM(42.1,"_DA(1)_",""RG"","
. D ^DIK
Q
;
ADDCL(CL,REG) ;-- add new complications to the complications list
N BDMDA,BDMIEN,BDMCL
S BDMCL=CL
S BDMCLI=$O(^ACM(42.1,"B",BDMCL,0))
I 'BDMCLI D Q
. N BDMFDA,BDMIENS,BDMERR
. S BDMIENS=""
. S BDMFDA(9002242.1,"?+1,",.01)=BDMCL
. S BDMFDA(9002242.11,"+2,?+1,",.01)=REG
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. S ^BDMTMP($J,1)=$G(BDMIENS(1))_$C(30)
I '$D(^ACM(42.1,"RG",REG,BDMCL)) D Q
. N BDMFDA,BDMIENS,BDMERR
. S BDMIENS(1)=BDMCLI
. S BDMFDA(9002242.11,"+2,"_BDMIENS(1)_",",.01)=REG
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
S ^BDMTMP($J,1)=BDMCLI_$C(30)
Q
;
ADDCLDX(CL,ICD) ;-- add new complications diagnosis to the complication
N BDMDA,BDMIEN,BDMCL
N I,R
S R="~"
F I=1:1 D Q:$P(ICD,R,I)=""
. Q:$P(ICD,R,I)=""
. N BDMICDI
. S BDMICDI=$P(ICD,R,I)
. N BDMFDA,BDMIENS,BDMERR
. S BDMIENS="?+2,"_CL_","
. S BDMFDA(9002242.11101,BDMIENS,.01)=BDMICDI
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. Q
Q
;
NLET(BDMRET,BDMSTR) ;-- save the new letter definition in RPMS
N P,BDMDIR,BDMFN
S P="|"
S BDMDIR=$P(BDMSTR,P)
S BDMFN=$P(BDMSTR,P,2)
N BDMFDA,BDMERR,BDMIENS,BDMI
S BDMIENS=""
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S ^BDMTMP($J,BDMI)="T00009BMXIEN"_$C(30)
I $O(^BDMLET("B",BDMFN,0)) D Q
. S ^BDMTMP($J,BDMI+1)="Letter Already Exists"_$C(31)
S BDMFDA(9003201,"+1,",.01)=BDMFN
S BDMFDA(9003201,"+1,",.02)=DUZ
S BDMFDA(9003201,"+1,",.03)=DT
S BDMFDA(9003201,"+1,",.04)=BDMDIR
S BDMFDA(9003201,"+1,",.05)=$TR(BDMFN,"/")_".doc"
D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
S ^BDMTMP($J,BDMI+1)=$G(BDMIENS(1))_$C(31)
Q
;
LETE(BDMRET,BDMSTR) ;-- add directory/filename to letter
N P,BDMDIR,BDMIEN
S P="|"
S BDMIEN=$P(BDMSTR,P)
S BDMDIR=$P(BDMSTR,P,2)
N BDMFDA,BDMERR,BDMIENS,BDMI
S BDMIENS=BDMIEN_","
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S ^BDMTMP($J,BDMI)="T00009BMXIEN"_$C(30)
N BDMFN
S BDMFN=$P($G(^BDMLET(BDMIEN,0)),U)
S BDMFDA(9003201,BDMIENS,.04)=BDMDIR
S BDMFDA(9003201,BDMIENS,.05)=$TR(BDMFN,"/")_".doc"
D FILE^DIE("K","BDMFDA","BDMERR(1)")
S ^BDMTMP($J,BDMI+1)=$G(BDMIENS(1))_$C(31)
Q
;
LETP(BDMRET,BDMSTR) ;-- save letter insert items
N P,BDMLETI,BDMITEM,R
S P="|",R="~"
S BDMLETI=$P(BDMSTR,P)
S BDMITEM=$P(BDMSTR,P,2)
N BDMI
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S ^BDMTMP($J,BDMI)="T00009BMXIEN"_$C(30)
;S BDMLETI=$O(^BDMLET("B",BDMLET,0))
N BDMDA
S BDMDA=0 F S BDMDA=$O(^BDMLET(BDMLETI,"ITEM",BDMDA)) Q:'BDMDA D
. S DA(1)=BDMLETI,DA=BDMDA,DIK="^BDMLET("_DA(1)_","_"""ITEM"""_","
. D ^DIK
N I
F I=2:1 D Q:$P(BDMITEM,R,I)=""
. N BDMFDA,BDMERR,BDMIENS
. Q:$P(BDMITEM,R,I)=""
. S BDMIENS(1)=BDMLETI
. S BDMIENS="?+2,"_BDMLETI_","
. N BDMIT,BDMITI
. S BDMIT=$P(BDMITEM,R,I)
. S BDMITI=$O(^DD("FUNC","B",BDMIT,0))
. S BDMFDA(9003201.02,BDMIENS,.01)=BDMITI
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
S ^BDMTMP($J,BDMI+1)=$G(BDMIENS(1))_$C(31)
Q
;
BDMGEB ; cmi/anch/maw - BDM DMS GUI Filing Routine ;
+1 ;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1**;JAN 17, 2008
+2 ;
+3 ;
+4 ;
+5 ;1/25/2005 added in REGSV a check for DX
+6 ;3/22/2006 added diagnosis save to complications list add, subroutine CMPA
+7 ;
DEBUG(BDMRET,BDMSTR) ;-- debugger
+1 DO DEBUG^%Serenji("DME^BDMGE(.BDMRET,.BDMSTR)")
+2 QUIT
+3 ;
CMPL(BDMRET,BDMSTR) ;-- save complications list
+1 NEW P,BDMDA,BDMIEN,BDMREG,BDMREGE,BDMCL,BDMCNT
+2 SET P="|"
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET ^BDMTMP($JOB,0)="T00050RETURN"_$CHAR(30)
+6 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+7 SET BDMREGE=$PIECE(BDMSTR,P)
+8 SET BDMCNT=0
+9 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+10 IF $PIECE(BDMSTR,P,2)=""
Begin DoDot:1
+11 NEW BDMDA
+12 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ACM(42.1,"RG",BDMREG,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:2
+13 NEW BDMIEN
+14 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^ACM(42.1,"RG",BDMREG,BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:3
+15 SET DA(1)=BDMDA
SET DA=BDMIEN
SET DIK="^ACM(42.1,"_DA(1)_",""RG"","
+16 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+17 FOR I=2:1
Begin DoDot:1
+18 IF $PIECE(BDMSTR,P,I)=""
QUIT
+19 SET BDMCNT=BDMCNT+1
+20 SET BDMCL(BDMCNT)=$PIECE(BDMSTR,P,I)
End DoDot:1
IF $PIECE(BDMSTR,P,I)=""
QUIT
+21 DO CLNCL(.BDMCL,BDMREG)
+22 DO ADDCL(.BDMCL,BDMREG)
+23 SET ^BDMTMP($JOB,1)=$CHAR(31)_$GET(BDMERR)
+24 QUIT
+25 ;
CMPA(BDMRET,BDMSTR) ;-- add complication to list
+1 NEW P,BDMDA,BDMIEN,BDMREG,BDMREGE,BDMCL,BDMICD
+2 SET P="|"
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET ^BDMTMP($JOB,0)="T00050Error"_$CHAR(30)
+6 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+7 SET BDMREG=$PIECE(BDMSTR,P)
+8 SET BDMCL=$PIECE(BDMSTR,P,2)
+9 SET BDMCNT=0
+10 DO ADDCL(BDMCL,BDMREG)
+11 SET ^BDMTMP($JOB,2)=$CHAR(31)_$GET(BDMERR)
+12 QUIT
+13 ;
CMPDXA(BDMRET,BDMSTR) ;-- add complication diagnosis to list
+1 NEW P,BDMDA,BDMIEN,BDMREG,BDMREGE,BDMCL,BDMICD
+2 SET P="|"
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET ^BDMTMP($JOB,0)="T00050RETURN"_$CHAR(30)
+6 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+7 SET BDMREG=$PIECE(BDMSTR,P)
+8 SET BDMCL=$PIECE(BDMSTR,P,2)
+9 SET BDMICD=$PIECE(BDMSTR,P,3)
+10 SET BDMCNT=0
+11 DO ADDCLDX(BDMCL,BDMICD)
+12 SET ^BDMTMP($JOB,1)=$CHAR(31)_$GET(BDMERR)
+13 QUIT
+14 ;
CLNCL(CL,REG) ;-- clean up deleted complications first
+1 NEW BDMDA,BDMIEN,BDMCL
+2 SET BDMDA=0
FOR
SET BDMDA=$ORDER(CL(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+3 SET BDMCL=$GET(CL(BDMDA))
+4 SET BDMCLI=$ORDER(^ACM(42.1,"B",BDMCL,0))
+5 IF BDMCLI
IF $DATA(^ACM(42.1,"RG",REG,BDMCL))
KILL CL(BDMDA)
End DoDot:1
+6 NEW BDMDA
+7 SET BDMDA=0
FOR
SET BDMDA=$ORDER(CL(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+8 NEW BDMCL,BDMIEN
+9 SET BDMCL=$GET(CL,BDMDA)
+10 SET BDMCLI=$ORDER(^ACM(42.1,"B",BDMCL,0))
+11 IF 'BDMCLI
QUIT
+12 SET BDMIEN=$ORDER(^ACM(42.1,"RG",REG,BDMCLI,0))
+13 IF 'BDMIEN
QUIT
+14 SET DA(1)=BDMCLI
SET DA=BDMIEN
SET DIK="^ACM(42.1,"_DA(1)_",""RG"","
+15 DO ^DIK
End DoDot:1
+16 QUIT
+17 ;
ADDCL(CL,REG) ;-- add new complications to the complications list
+1 NEW BDMDA,BDMIEN,BDMCL
+2 SET BDMCL=CL
+3 SET BDMCLI=$ORDER(^ACM(42.1,"B",BDMCL,0))
+4 IF 'BDMCLI
Begin DoDot:1
+5 NEW BDMFDA,BDMIENS,BDMERR
+6 SET BDMIENS=""
+7 SET BDMFDA(9002242.1,"?+1,",.01)=BDMCL
+8 SET BDMFDA(9002242.11,"+2,?+1,",.01)=REG
+9 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+10 SET ^BDMTMP($JOB,1)=$GET(BDMIENS(1))_$CHAR(30)
End DoDot:1
QUIT
+11 IF '$DATA(^ACM(42.1,"RG",REG,BDMCL))
Begin DoDot:1
+12 NEW BDMFDA,BDMIENS,BDMERR
+13 SET BDMIENS(1)=BDMCLI
+14 SET BDMFDA(9002242.11,"+2,"_BDMIENS(1)_",",.01)=REG
+15 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
End DoDot:1
QUIT
+16 SET ^BDMTMP($JOB,1)=BDMCLI_$CHAR(30)
+17 QUIT
+18 ;
ADDCLDX(CL,ICD) ;-- add new complications diagnosis to the complication
+1 NEW BDMDA,BDMIEN,BDMCL
+2 NEW I,R
+3 SET R="~"
+4 FOR I=1:1
Begin DoDot:1
+5 IF $PIECE(ICD,R,I)=""
QUIT
+6 NEW BDMICDI
+7 SET BDMICDI=$PIECE(ICD,R,I)
+8 NEW BDMFDA,BDMIENS,BDMERR
+9 SET BDMIENS="?+2,"_CL_","
+10 SET BDMFDA(9002242.11101,BDMIENS,.01)=BDMICDI
+11 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+12 QUIT
End DoDot:1
IF $PIECE(ICD,R,I)=""
QUIT
+13 QUIT
+14 ;
NLET(BDMRET,BDMSTR) ;-- save the new letter definition in RPMS
+1 NEW P,BDMDIR,BDMFN
+2 SET P="|"
+3 SET BDMDIR=$PIECE(BDMSTR,P)
+4 SET BDMFN=$PIECE(BDMSTR,P,2)
+5 NEW BDMFDA,BDMERR,BDMIENS,BDMI
+6 SET BDMIENS=""
+7 SET BDMRET="^BDMTMP("_$JOB_")"
+8 SET BDMI=0
+9 SET ^BDMTMP($JOB,BDMI)="T00009BMXIEN"_$CHAR(30)
+10 IF $ORDER(^BDMLET("B",BDMFN,0))
Begin DoDot:1
+11 SET ^BDMTMP($JOB,BDMI+1)="Letter Already Exists"_$CHAR(31)
End DoDot:1
QUIT
+12 SET BDMFDA(9003201,"+1,",.01)=BDMFN
+13 SET BDMFDA(9003201,"+1,",.02)=DUZ
+14 SET BDMFDA(9003201,"+1,",.03)=DT
+15 SET BDMFDA(9003201,"+1,",.04)=BDMDIR
+16 SET BDMFDA(9003201,"+1,",.05)=$TRANSLATE(BDMFN,"/")_".doc"
+17 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+18 SET ^BDMTMP($JOB,BDMI+1)=$GET(BDMIENS(1))_$CHAR(31)
+19 QUIT
+20 ;
LETE(BDMRET,BDMSTR) ;-- add directory/filename to letter
+1 NEW P,BDMDIR,BDMIEN
+2 SET P="|"
+3 SET BDMIEN=$PIECE(BDMSTR,P)
+4 SET BDMDIR=$PIECE(BDMSTR,P,2)
+5 NEW BDMFDA,BDMERR,BDMIENS,BDMI
+6 SET BDMIENS=BDMIEN_","
+7 SET BDMRET="^BDMTMP("_$JOB_")"
+8 SET BDMI=0
+9 SET ^BDMTMP($JOB,BDMI)="T00009BMXIEN"_$CHAR(30)
+10 NEW BDMFN
+11 SET BDMFN=$PIECE($GET(^BDMLET(BDMIEN,0)),U)
+12 SET BDMFDA(9003201,BDMIENS,.04)=BDMDIR
+13 SET BDMFDA(9003201,BDMIENS,.05)=$TRANSLATE(BDMFN,"/")_".doc"
+14 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+15 SET ^BDMTMP($JOB,BDMI+1)=$GET(BDMIENS(1))_$CHAR(31)
+16 QUIT
+17 ;
LETP(BDMRET,BDMSTR) ;-- save letter insert items
+1 NEW P,BDMLETI,BDMITEM,R
+2 SET P="|"
SET R="~"
+3 SET BDMLETI=$PIECE(BDMSTR,P)
+4 SET BDMITEM=$PIECE(BDMSTR,P,2)
+5 NEW BDMI
+6 SET BDMRET="^BDMTMP("_$JOB_")"
+7 SET BDMI=0
+8 SET ^BDMTMP($JOB,BDMI)="T00009BMXIEN"_$CHAR(30)
+9 ;S BDMLETI=$O(^BDMLET("B",BDMLET,0))
+10 NEW BDMDA
+11 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^BDMLET(BDMLETI,"ITEM",BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+12 SET DA(1)=BDMLETI
SET DA=BDMDA
SET DIK="^BDMLET("_DA(1)_","_"""ITEM"""_","
+13 DO ^DIK
End DoDot:1
+14 NEW I
+15 FOR I=2:1
Begin DoDot:1
+16 NEW BDMFDA,BDMERR,BDMIENS
+17 IF $PIECE(BDMITEM,R,I)=""
QUIT
+18 SET BDMIENS(1)=BDMLETI
+19 SET BDMIENS="?+2,"_BDMLETI_","
+20 NEW BDMIT,BDMITI
+21 SET BDMIT=$PIECE(BDMITEM,R,I)
+22 SET BDMITI=$ORDER(^DD("FUNC","B",BDMIT,0))
+23 SET BDMFDA(9003201.02,BDMIENS,.01)=BDMITI
+24 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
End DoDot:1
IF $PIECE(BDMITEM,R,I)=""
QUIT
+25 SET ^BDMTMP($JOB,BDMI+1)=$GET(BDMIENS(1))_$CHAR(31)
+26 QUIT
+27 ;
