APCDALVR ; IHS/CMI/LAB - V FILE CREATION ;
;;2.0;IHS PCC SUITE;**8,10**;MAY 14, 2009;Build 88
; Add entries to VISIT related files.
;
; Upon exit if APCDAFLG exists it means:
; Value=1 Invalid TEMPLATE specification
; Value=2 VISIT DFN incorrect or ^DIE rejected data
;
EN ;PEP - called to create PCC V File entries
K APCDALVR("APCDAFLG"),APCDDUZO
NEW (U,DT,IO,DTIME,DUZ,APCDALVR,ZTQUEUED,BLRLINK,ADGPMADT,XQORS) ;5/12/05 IHS/CMI/LAB added XQORS per Christy Smith, Daou
;Exception granted by SACC for unargumented NEW command
I DUZ(0)'["M"&(DUZ(0)'="@") S APCDDUZO=DUZ(0),DUZ(0)=DUZ(0)_"M"
S APCDX="" F APCDL=0:0 S APCDX=$O(APCDALVR(APCDX)) Q:APCDX="" S @APCDX=APCDALVR(APCDX)
K APCDAFLG
S APCDADFN="",APCDAVF=""
S:'$D(APCDAFLE) APCDAFLE=9000010
I '$D(APCDVSIT) S APCDAFLG=2 G XIT
I APCDVSIT'?1N.N S APCDAFLG=2 G XIT
I '$D(^AUPNVSIT(APCDVSIT,0)) S APCDAFLG=2 G XIT
;I $P(^AUPNVSIT(APCDVSIT,0),U,11) S APCDAFLG=2 G XIT ;deleted visit is invalid
I $P(^AUPNVSIT(APCDVSIT,0),U,11) S $P(^AUPNVSIT(APCDVSIT,0),U,11)="",DA=APCDVSIT,DIK="^AUPNVSIT(" D IX1^DIK K DA,D0,DO,DIK,DIC,DICR,DIU,DIV,DG ;reindex if visit is deleted, shouldn't happen, but does
I $E(APCDATMP)'="["!($E(APCDATMP,$L(APCDATMP))'="]") S APCDAFLG=1 G XIT
I '$D(^DIE("B",$P($E(APCDATMP,2,99),"]"))) S APCDAFLG=1 G XIT
S:'$D(APCDPAT) APCDPAT=$P(^AUPNVSIT(APCDVSIT,0),U,5)
S:$E(APCDPAT)="`" APCDPAT=$E(APCDPAT,2,99)
S Y=APCDPAT D ^AUPNPAT
S DIE=^DIC(APCDAFLE,0,"GL"),(DA,D0)=APCDVSIT,DR=APCDATMP
S APCDOVRR=1 D ^DIE
S:$D(Y)!((APCDADFN="")&(APCDATMP["(ADD)")) APCDAFLG=2
I $D(APCDAFLG),APCDADFN,APCDAVF,APCDATMP["(ADD)" S DIK=^DIC(APCDAVF,0,"GL"),(DA,D0)=APCDADFN,APCDADFN="" D ^DIK K DIK,DR
XIT ; KILL VARIABLES AND QUIT
;I $D(APCDAFLG) S %AIHSERR="APCDALVR",$ZE="" D ^%ET
I $D(APCDVFE) D VL
I $D(APCDDUZO) S DUZ(0)=APCDDUZO K APCDDUZO
;I '$D(APCDAFLG) S AUPNVSIT=APCDVSIT D MOD^AUPNVSIT ;IHS/CMI/LAB - see below **5**
I '$D(APCDAFLG) S AUPNVSIT=APCDVSIT D MOD^AUPNVSIT,MODVF,SNOMED,LOINC D
.Q:APCDATMP'[9000010.09
.Q:$T(EN^BLSLX)=""
.I APCDATMP["ADD",$G(APCDADFN) D EN^BLSLX(APCDADFN)
.I APCDATMP["MOD",$G(APCDLOOK) D EN^BLSLX(APCDLOOK)
.Q
K Y
S APCDALVR("APCDADFN")=APCDADFN,APCDALVR("APCDAVF")=APCDAVF S:$D(APCDAFLG) APCDALVR("APCDAFLG")=APCDAFLG
K APCDAFLE,APCDATMP,APCDAVF,APCDDUZO
Q
SNOMED ;
S APCDVF=$P(APCDATMP,"APCDALVR ",2),APCDVF=$P(APCDVF," ",1)
I APCDVF<9000010.01 Q
I APCDVF>9000010.99 Q
S APCDG=$G(^DIC(APCDVF,0,"GL"))
I $G(APCDTSND)]"" D
.;delete out these snomeds from 2601 field
.F APCDP=1:1 S APCDV=$P(APCDTSND,U,APCDP) Q:APCDV="" D
..S APCDVIGR=APCDG_APCDADFN_",26,"_"""B"",APCDV,0)"
..S DA=$O(@APCDVIGR)
..Q:'DA ;didn't find it
..S DA(1)=APCDADFN
..S DIK=APCDG_APCDADFN_",26,"
..D ^DIK K DA,DIK
I $G(APCDTSNO)]"" D
.F APCDP=1:1 S APCDV=$P(APCDTSNO,U,APCDP) Q:APCDV="" D
..S DA(1)=APCDADFN
..S X=APCDV
..S DIC=APCDG_DA(1)_",26," ;the root of the subfile for that entry
..S DIC(0)="L" ;LAYGO to the subfile is allowed
..S DIC("P")=$P(^DD(APCDVF,2601,0),"^",2) ;returns the subfile# and specifiers
..D ^DIC K DA,DIC
Q
;
LOINC ;
S APCDVF=$P(APCDATMP,"APCDALVR ",2),APCDVF=$P(APCDVF," ",1)
I APCDVF<9000010.01 Q
I APCDVF>9000010.99 Q
S APCDG=$G(^DIC(APCDVF,0,"GL"))
I $G(APCDTLDE)]"" D
.;delete out these snomeds from 2601 field
.F APCDP=1:1 S APCDV=$P(APCDTLDE,U,APCDP) Q:APCDV="" D
..S APCDVIGR=APCDG_APCDADFN_",27,"_"""B"",APCDV,0)"
..S DA=$O(@APCDVIGR)
..Q:'DA ;didn't find it
..S DA(1)=APCDADFN
..S DIK=APCDG_APCDADFN_",27,"
..D ^DIK K DA,DIK
I $G(APCDTLOI)]"" D
.F APCDP=1:1 S APCDV=$P(APCDTLOI,U,APCDP) Q:APCDV="" D
..S DA(1)=APCDADFN
..S X=APCDV
..S DIC=APCDG_DA(1)_",27," ;the root of the subfile for that entry
..S DIC(0)="L" ;LAYGO to the subfile is allowed
..S DIC("P")=$P(^DD(APCDVF,2701,0),"^",2) ;returns the subfile# and specifiers
..D ^DIC K DA,DIC
Q
MODVF ;
NEW APCDVF,DIE,DR,DA
S APCDVF=$P(APCDATMP,"APCDALVR ",2),APCDVF=$P(APCDVF," ",1)
I APCDVF<9000010.01 Q
I APCDVF>9000010.99 Q
Q:'APCDADFN
I APCDATMP["ADD" S DIE=APCDVF,DR="1216////"_$$NOW^XLFDT,DA=APCDADFN D ^DIE
I APCDATMP["MOD" S DIE=APCDVF,DR="1218////"_$$NOW^XLFDT,DA=APCDADFN D ^DIE
Q
VL ;EP - create v line item entries if appropriate
;not yet ready
Q
S APCDFILE=$P($P(APCDALVR("APCDATMP")," ",2)," ")
S APCDMODE=$E($P(APCDALVR("APCDATMP")," ",3))
D @$P(APCDFILE,".",2)
Q
;
DEL(DIK,DA) ;PEP - DELETE ONE V FILE ENTRY
;
; Meaning of returned values are:
; 0 = v file entry deleted
; 1 = data global invalid
; 2 = no 0th node for data global
; 3 = specified file is not a v file
; 4 = specified entry is not in specified v file
;
NEW (DA,DIK,DT,DTIME,DUZ,U)
;Exception granted by SACC for exclusive NEW command
;
S:DIK DIK=$G(^DIC(DIK,0,"GL")) ; get data gbl if file #
I DIK'?1"^".E1"(".E Q 1 ; data gbl invalid
S X=$E(DIK,$L(DIK)) ; get last chr of gbl
I X'="(",X'="," Q 1 ; data gbl invalid
I '$D(@(DIK_"0)")) Q 2 ; no 0th node for data gbl
S X=+$P(@(DIK_"0)"),U,2) ; get file #
I $P(X,".")'=9000010 Q 3 ; not a v file
I X=9000010 Q 3 ; not a v file
I '$D(@(DIK_DA_",0)")) Q 4 ; entry not in v file
D ^DIK ; delete v file entry
Q 0
;
LABC(LVIEN,LCOM) ;-- stuff v lab comments
I '$D(^AUPNVLAB(LVIEN,0)) S APCDALVR("APCDAFLG")="1^No V Lab Entry"
I '$O(LCOM("")) S APCDALVR("APCDAFLG")="1^No Comments Passed In"
S APCDCDA=0 F S APCDCDA=$O(LCOM(APCDCDA)) Q:'APCDCDA D
. S APCDLCOM=$G(LCOM(APCDCDA))
. K DD,DO
. S DIC="^AUPNVLAB("_LVIEN_",21,",DIC(0)="L",DA(1)=LVIEN
. S DIC("P")=$P(^DD(9000010.09,2100,0),U,2),X=APCDLCOM
. D FILE^DICN
. I +Y<0 S APCDALVR("APCDAFLG")="1^Error Adding Entry to V Lab"
I $G(APCDALVR("APCDAFLG")) Q APCDALVR("APCDAFLG")
Q ""
;
APCDALVR ; IHS/CMI/LAB - V FILE CREATION ;
+1 ;;2.0;IHS PCC SUITE;**8,10**;MAY 14, 2009;Build 88
+2 ; Add entries to VISIT related files.
+3 ;
+4 ; Upon exit if APCDAFLG exists it means:
+5 ; Value=1 Invalid TEMPLATE specification
+6 ; Value=2 VISIT DFN incorrect or ^DIE rejected data
+7 ;
EN ;PEP - called to create PCC V File entries
+1 KILL APCDALVR("APCDAFLG"),APCDDUZO
+2 ;5/12/05 IHS/CMI/LAB added XQORS per Christy Smith, Daou
NEW (U,DT,IO,DTIME,DUZ,APCDALVR,ZTQUEUED,BLRLINK,ADGPMADT,XQORS)
+3 ;Exception granted by SACC for unargumented NEW command
+4 IF DUZ(0)'["M"&(DUZ(0)'="@")
SET APCDDUZO=DUZ(0)
SET DUZ(0)=DUZ(0)_"M"
+5 SET APCDX=""
FOR APCDL=0:0
SET APCDX=$ORDER(APCDALVR(APCDX))
IF APCDX=""
QUIT
SET @APCDX=APCDALVR(APCDX)
+6 KILL APCDAFLG
+7 SET APCDADFN=""
SET APCDAVF=""
+8 IF '$DATA(APCDAFLE)
SET APCDAFLE=9000010
+9 IF '$DATA(APCDVSIT)
SET APCDAFLG=2
GOTO XIT
+10 IF APCDVSIT'?1N.N
SET APCDAFLG=2
GOTO XIT
+11 IF '$DATA(^AUPNVSIT(APCDVSIT,0))
SET APCDAFLG=2
GOTO XIT
+12 ;I $P(^AUPNVSIT(APCDVSIT,0),U,11) S APCDAFLG=2 G XIT ;deleted visit is invalid
+13 ;reindex if visit is deleted, shouldn't happen, but does
IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,11)
SET $PIECE(^AUPNVSIT(APCDVSIT,0),U,11)=""
SET DA=APCDVSIT
SET DIK="^AUPNVSIT("
DO IX1^DIK
KILL DA,D0,DO,DIK,DIC,DICR,DIU,DIV,DG
+14 IF $EXTRACT(APCDATMP)'="["!($EXTRACT(APCDATMP,$LENGTH(APCDATMP))'="]")
SET APCDAFLG=1
GOTO XIT
+15 IF '$DATA(^DIE("B",$PIECE($EXTRACT(APCDATMP,2,99),"]")))
SET APCDAFLG=1
GOTO XIT
+16 IF '$DATA(APCDPAT)
SET APCDPAT=$PIECE(^AUPNVSIT(APCDVSIT,0),U,5)
+17 IF $EXTRACT(APCDPAT)="`"
SET APCDPAT=$EXTRACT(APCDPAT,2,99)
+18 SET Y=APCDPAT
DO ^AUPNPAT
+19 SET DIE=^DIC(APCDAFLE,0,"GL")
SET (DA,D0)=APCDVSIT
SET DR=APCDATMP
+20 SET APCDOVRR=1
DO ^DIE
+21 IF $DATA(Y)!((APCDADFN="")&(APCDATMP["(ADD)"))
SET APCDAFLG=2
+22 IF $DATA(APCDAFLG)
IF APCDADFN
IF APCDAVF
IF APCDATMP["(ADD)"
SET DIK=^DIC(APCDAVF,0,"GL")
SET (DA,D0)=APCDADFN
SET APCDADFN=""
DO ^DIK
KILL DIK,DR
XIT ; KILL VARIABLES AND QUIT
+1 ;I $D(APCDAFLG) S %AIHSERR="APCDALVR",$ZE="" D ^%ET
+2 IF $DATA(APCDVFE)
DO VL
+3 IF $DATA(APCDDUZO)
SET DUZ(0)=APCDDUZO
KILL APCDDUZO
+4 ;I '$D(APCDAFLG) S AUPNVSIT=APCDVSIT D MOD^AUPNVSIT ;IHS/CMI/LAB - see below **5**
+5 IF '$DATA(APCDAFLG)
SET AUPNVSIT=APCDVSIT
DO MOD^AUPNVSIT
DO MODVF
DO SNOMED
DO LOINC
Begin DoDot:1
+6 IF APCDATMP'[9000010.09
QUIT
+7 IF $TEXT(EN^BLSLX)=""
QUIT
+8 IF APCDATMP["ADD"
IF $GET(APCDADFN)
DO EN^BLSLX(APCDADFN)
+9 IF APCDATMP["MOD"
IF $GET(APCDLOOK)
DO EN^BLSLX(APCDLOOK)
+10 QUIT
End DoDot:1
+11 KILL Y
+12 SET APCDALVR("APCDADFN")=APCDADFN
SET APCDALVR("APCDAVF")=APCDAVF
IF $DATA(APCDAFLG)
SET APCDALVR("APCDAFLG")=APCDAFLG
+13 KILL APCDAFLE,APCDATMP,APCDAVF,APCDDUZO
+14 QUIT
SNOMED ;
+1 SET APCDVF=$PIECE(APCDATMP,"APCDALVR ",2)
SET APCDVF=$PIECE(APCDVF," ",1)
+2 IF APCDVF<9000010.01
QUIT
+3 IF APCDVF>9000010.99
QUIT
+4 SET APCDG=$GET(^DIC(APCDVF,0,"GL"))
+5 IF $GET(APCDTSND)]""
Begin DoDot:1
+6 ;delete out these snomeds from 2601 field
+7 FOR APCDP=1:1
SET APCDV=$PIECE(APCDTSND,U,APCDP)
IF APCDV=""
QUIT
Begin DoDot:2
+8 SET APCDVIGR=APCDG_APCDADFN_",26,"_"""B"",APCDV,0)"
+9 SET DA=$ORDER(@APCDVIGR)
+10 ;didn't find it
IF 'DA
QUIT
+11 SET DA(1)=APCDADFN
+12 SET DIK=APCDG_APCDADFN_",26,"
+13 DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+14 IF $GET(APCDTSNO)]""
Begin DoDot:1
+15 FOR APCDP=1:1
SET APCDV=$PIECE(APCDTSNO,U,APCDP)
IF APCDV=""
QUIT
Begin DoDot:2
+16 SET DA(1)=APCDADFN
+17 SET X=APCDV
+18 ;the root of the subfile for that entry
SET DIC=APCDG_DA(1)_",26,"
+19 ;LAYGO to the subfile is allowed
SET DIC(0)="L"
+20 ;returns the subfile# and specifiers
SET DIC("P")=$PIECE(^DD(APCDVF,2601,0),"^",2)
+21 DO ^DIC
KILL DA,DIC
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
LOINC ;
+1 SET APCDVF=$PIECE(APCDATMP,"APCDALVR ",2)
SET APCDVF=$PIECE(APCDVF," ",1)
+2 IF APCDVF<9000010.01
QUIT
+3 IF APCDVF>9000010.99
QUIT
+4 SET APCDG=$GET(^DIC(APCDVF,0,"GL"))
+5 IF $GET(APCDTLDE)]""
Begin DoDot:1
+6 ;delete out these snomeds from 2601 field
+7 FOR APCDP=1:1
SET APCDV=$PIECE(APCDTLDE,U,APCDP)
IF APCDV=""
QUIT
Begin DoDot:2
+8 SET APCDVIGR=APCDG_APCDADFN_",27,"_"""B"",APCDV,0)"
+9 SET DA=$ORDER(@APCDVIGR)
+10 ;didn't find it
IF 'DA
QUIT
+11 SET DA(1)=APCDADFN
+12 SET DIK=APCDG_APCDADFN_",27,"
+13 DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+14 IF $GET(APCDTLOI)]""
Begin DoDot:1
+15 FOR APCDP=1:1
SET APCDV=$PIECE(APCDTLOI,U,APCDP)
IF APCDV=""
QUIT
Begin DoDot:2
+16 SET DA(1)=APCDADFN
+17 SET X=APCDV
+18 ;the root of the subfile for that entry
SET DIC=APCDG_DA(1)_",27,"
+19 ;LAYGO to the subfile is allowed
SET DIC(0)="L"
+20 ;returns the subfile# and specifiers
SET DIC("P")=$PIECE(^DD(APCDVF,2701,0),"^",2)
+21 DO ^DIC
KILL DA,DIC
End DoDot:2
End DoDot:1
+22 QUIT
MODVF ;
+1 NEW APCDVF,DIE,DR,DA
+2 SET APCDVF=$PIECE(APCDATMP,"APCDALVR ",2)
SET APCDVF=$PIECE(APCDVF," ",1)
+3 IF APCDVF<9000010.01
QUIT
+4 IF APCDVF>9000010.99
QUIT
+5 IF 'APCDADFN
QUIT
+6 IF APCDATMP["ADD"
SET DIE=APCDVF
SET DR="1216////"_$$NOW^XLFDT
SET DA=APCDADFN
DO ^DIE
+7 IF APCDATMP["MOD"
SET DIE=APCDVF
SET DR="1218////"_$$NOW^XLFDT
SET DA=APCDADFN
DO ^DIE
+8 QUIT
VL ;EP - create v line item entries if appropriate
+1 ;not yet ready
+2 QUIT
+3 SET APCDFILE=$PIECE($PIECE(APCDALVR("APCDATMP")," ",2)," ")
+4 SET APCDMODE=$EXTRACT($PIECE(APCDALVR("APCDATMP")," ",3))
+5 DO @$PIECE(APCDFILE,".",2)
+6 QUIT
+7 ;
DEL(DIK,DA) ;PEP - DELETE ONE V FILE ENTRY
+1 ;
+2 ; Meaning of returned values are:
+3 ; 0 = v file entry deleted
+4 ; 1 = data global invalid
+5 ; 2 = no 0th node for data global
+6 ; 3 = specified file is not a v file
+7 ; 4 = specified entry is not in specified v file
+8 ;
+9 NEW (DA,DIK,DT,DTIME,DUZ,U)
+10 ;Exception granted by SACC for exclusive NEW command
+11 ;
+12 ; get data gbl if file #
IF DIK
SET DIK=$GET(^DIC(DIK,0,"GL"))
+13 ; data gbl invalid
IF DIK'?1"^".E1"(".E
QUIT 1
+14 ; get last chr of gbl
SET X=$EXTRACT(DIK,$LENGTH(DIK))
+15 ; data gbl invalid
IF X'="("
IF X'=","
QUIT 1
+16 ; no 0th node for data gbl
IF '$DATA(@(DIK_"0)"))
QUIT 2
+17 ; get file #
SET X=+$PIECE(@(DIK_"0)"),U,2)
+18 ; not a v file
IF $PIECE(X,".")'=9000010
QUIT 3
+19 ; not a v file
IF X=9000010
QUIT 3
+20 ; entry not in v file
IF '$DATA(@(DIK_DA_",0)"))
QUIT 4
+21 ; delete v file entry
DO ^DIK
+22 QUIT 0
+23 ;
LABC(LVIEN,LCOM) ;-- stuff v lab comments
+1 IF '$DATA(^AUPNVLAB(LVIEN,0))
SET APCDALVR("APCDAFLG")="1^No V Lab Entry"
+2 IF '$ORDER(LCOM(""))
SET APCDALVR("APCDAFLG")="1^No Comments Passed In"
+3 SET APCDCDA=0
FOR
SET APCDCDA=$ORDER(LCOM(APCDCDA))
IF 'APCDCDA
QUIT
Begin DoDot:1
+4 SET APCDLCOM=$GET(LCOM(APCDCDA))
+5 KILL DD,DO
+6 SET DIC="^AUPNVLAB("_LVIEN_",21,"
SET DIC(0)="L"
SET DA(1)=LVIEN
+7 SET DIC("P")=$PIECE(^DD(9000010.09,2100,0),U,2)
SET X=APCDLCOM
+8 DO FILE^DICN
+9 IF +Y<0
SET APCDALVR("APCDAFLG")="1^Error Adding Entry to V Lab"
End DoDot:1
+10 IF $GET(APCDALVR("APCDAFLG"))
QUIT APCDALVR("APCDAFLG")
+11 QUIT ""
+12 ;
