- 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 ;
