BGOVPOV1 ; MSC/IND/DKM - Fix VPOV sequencing (primary first) ;20-Jun-2017 15:26;DU
;;1.1;BGO COMPONENTS;**3,13,19,20,23**;Mar 20, 2007;Build 1
; Display routine help
HELP ;EP
N LP,X
F LP=0:1 S X=$P($T(HELPDATA+LP),";;",2,99) Q:X="<END>" W X,!
Q
; Finds all visits with improperly sequenced VPOVs
; If FIX is true, the VPOVs will be resequenced
FINDALL(FIX) ;EP
N VIEN,FND,FIXED,LP
K ^XTMP("BGOVPOV1")
S ^XTMP("BGOVPOV1",0)=DT_U_DT
S (FND,FIXED,VIEN)=0,FIX=+$G(FIX)
F LP=0:1 S VIEN=$O(^AUPNVPOV("AD",VIEN)) Q:'VIEN D
.W:'(LP#1000) "."
.Q:$$GETVPOVS(VIEN)
.S FND=FND+1
.I FIX,$$FIXVPOVS(VIEN)=1 S FIXED=FIXED+1,^XTMP("BGOVPOV1","FIXED",VIEN)=""
.E S ^XTMP("BGOVPOV1","NOT FIXED",VIEN)=""
S ^XTMP("BGOVPOV1","FIXED")=FIXED,^("NOT FIXED")=FND-FIXED
W !,"Visits with improperly sequenced VPOVs: ",FND,!
W !,"Visits with successfully resequenced VPOVs: ",FIXED,!
Q
; Called from BGOVPOV to insure that the primary is the first entry.
; VIEN = IEN of visit to inspect
; .VPOV = IEN of entry to track (optional - returned as new IEN if changed)
; Returns: 0 = VPOV entries require no resequencing
; 1 = VPOV entries were successfully resequenced
; 2 = VPOV entries were not successfully resequenced
FIXVPOVS(VIEN,VPOV) ;EP
N VPOV1,VPOV2,RET
Q:$$GETVPOVS(VIEN,.VPOV1,.VPOV2) 0
S RET=$$SWAP(VPOV1,VPOV2)
Q:'RET 2
S VPOV=$G(VPOV)
S VPOV=$S(VPOV=VPOV1:VPOV2,VPOV=VPOV2:VPOV1,1:VPOV)
Q 1
; Returns two VPOVs to be swapped.
; VIEN = IEN of visit to inspect
; VPOV1, VPOV2 = VPOV's to be swapped
; Return value is 1 if VPOVs are in correct order
GETVPOVS(VIEN,VPOV1,VPOV2) ;EP
S VPOV1=$$FNDPRI(VIEN)
Q:'VPOV1 1
S VPOV2=$O(^AUPNVPOV("AD",VIEN,0))
Q:'VPOV2!(VPOV2=VPOV1) 1
Q 0
; Swap VPOVs
; Returns true if successful
SWAP(VPOV1,VPOV2) ;
N FDA,RET,NEWNUM
Q:'$$BLDFDA(VPOV1,VPOV2,.FDA) 0
S RET=$$UPDATE^BGOUTL(.FDA,"@")
Q $S(RET<0:0,1:1)
; Build FDA array for swap
; Returns true if successful
BLDFDA(VPOV1,VPOV2,FDA,FLG) ;
N REC,ERR,FLD,FNUM,IENS1,IENS2,FUM,FNUM2,SIEN,MULT,MULT2,RET
S RET=""
S IENS1=VPOV1_",",IENS2=VPOV2_",",FNUM=9000010.07
D GETS^DIQ(FNUM,IENS1,"**","I","REC","ERR")
Q:$$REFERR 0
S FLD=""
F S FLD=$O(REC(FNUM,IENS1,FLD)) Q:'$L(FLD) D
.Q:$$GET1^DID(FNUM,FLD,,"TYPE")="COMPUTED"
.S FDA(FNUM,IENS2,FLD)=REC(FNUM,IENS1,FLD,"I")
F FUM=13,14,17,18 D
.;Delete subfile if any
.D DELSUB(.RET,$P(IENS1,",",1),FUM)
.Q:+RET
.S FNUM2=FNUM_FUM
.S MULT=""
.F S MULT=$O(REC(FNUM2,MULT)) Q:'$L(MULT) D
..S NUMNEW=$G(NUMNEW)+1
..S FLD="" F S FLD=$O(REC(FNUM2,MULT,FLD)) Q:'$L(FLD) D
...Q:FLD=.019
...Q:$$GET1^DIQ(FNUM2,FLD,,"TYPE")="COMPUTED"
...S SIEN="+"_NUMNEW_",",MULT2=SIEN_IENS2
...S FDA(FNUM2,MULT2,FLD)=REC(FNUM2,MULT,FLD,"I")
Q:'$G(FLG) $$BLDFDA(VPOV2,VPOV1,.FDA,1)
S FLD=""
F S FLD=$O(FDA(FNUM,IENS1,FLD)) Q:'$L(FLD) D
.I FDA(FNUM,IENS1,FLD)=FDA(FNUM,IENS2,FLD) D
..K FDA(FNUM,IENS1,FLD),FDA(FNUM,IENS2,FLD)
Q:$D(FDA(FNUM,IENS1,.03)) 0
Q:$D(FDA(FNUM,IENS1,.02)) 0
Q 1
DELSUB(RET,IEN,SFIL) ;Delete the subfile entries
N I,SIEN
S SIEN="" F S SIEN=$O(^AUPNVPOV(IEN,SFIL,SIEN)) Q:SIEN=""!(+RET) D
.S DA(1)=IEN,DA=SIEN
.S DIK="^AUPNVPOV(DA(1),SFIL,"
.S:DA RET=$$DELETE^BGOUTL(DIK,.DA)
Q
REFERR() I $D(ERR("DIERR",1,"TEXT",1)) D Q 1
.S ^XTMP("BGOVPOV1","ERROR",VPOV1)=ERR("DIERR",1,"TEXT",1)
Q 0
; Display POVs associated with a visit
DISPPOVS(VIEN) ;
N VPOV,X,Y
S VPOV=0
F S VPOV=$O(^AUPNVPOV("AD",VIEN,VPOV)) Q:'VPOV D
.S X=$G(^AUPNVPOV(VPOV,0)),Y=$G(^(12))
.W !,VIEN,": ",VPOV,!?5,"0: ",X,!?4,"12: ",Y,!!
Q
; Return IEN of primary POV for a visit
FNDPRI(VIEN) ;EP
N VPOV,RET,X
S VPOV=0
F S VPOV=$O(^AUPNVPOV("AD",VIEN,VPOV)) Q:'VPOV D Q:$D(RET)
.S X=$G(^AUPNVPOV(VPOV,0))
.I $P(X,U,3)=VIEN,$P(X,U,12)="P" S RET=VPOV
Q $G(RET)
UPREV(RET,DFN,VIEN) ;Update review data
N VSTR,ERR,TYPE,UTYP,INP
S ERR=""
S VSTR=$$VIS2VSTR^BEHOENCX(DFN,VIEN,ERR)
I ERR'="" S RET=ERR Q
F TYPE="PROBLEM LIST REVIEWED","PROBLEM LIST UPDATED" D
.S UTYP=$O(^AUTTCRA("B",TYPE,""))
.Q:'+UTYP
.S INP=UTYP_U_0_U_DFN_U_VSTR_U_U_DUZ
.D SET^BGOVUPD(.RET,INP)
Q
QUAL(RET,POV,QUAL) ;EP
;Store the episodicity qualifiers
N FNUM,IEN,SNO,DEL
S FNUM=9000010.0714
S IEN=+$P(QUAL,U,3)
S SNO=$P(QUAL,U,4)
S DEL=$P(QUAL,U,7)
I '$D(^AUPNVPOV(POV,14,"B")) S IEN=""
E S IEN=0 S IEN=$O(^AUPNVPOV(POV,14,IEN))
I +IEN&(DEL=1) D DELQ(RET,POV,IEN)
E D STORE(.RET,POV,SNO,FNUM,IEN)
Q
STORE(RET,POV,SNO,FNUM,IEN) ;Store the qualifier data
N AIEN,IEN2,ERR,FDA
I IEN="" S AIEN="+1,"_POV_","
E S AIEN=IEN_","_POV_","
S SNO=$TR(SNO," ","")
S FDA(FNUM,AIEN,.01)=SNO
D UPDATE^DIE(,"FDA","IEN2","ERR")
I $G(ERR("DIERR",1)) S RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
Q
QUALB(RET,PROB,POV) ;EP
;Move the qualfiers from the problem over to the POV fields
N FUM,SNO,FNUM,I,IEN
Q:$G(PROB)=""
F FUM=13,17,18 D
.S I=0 F S I=$O(^AUPNPROB(PROB,FUM,I)) Q:'+I D
..S SNO=$P($G(^AUPNPROB(PROB,FUM,I,0)),U,1)
..I SNO'="" D
...S FNUM=$S(FUM=13:9000010.0713,FUM=17:9000010.0717,FUM=18:9000010.0718)
...S IEN=""
...D STORE(.RET,POV,SNO,FNUM,IEN)
Q
DELQ(RET,POV,PRIEN) ;Delete a qualifer
N ERR,DA,DIK,NODE
S ERR=""
S NODE=14
S DA(1)=PRIEN,DA=IEN
S DIK="^AUPNVPOV(DA(1),"_NODE_","
S:DA ERR=$$DELETE^BGOUTL(DIK,.DA)
I ERR'="" S RET=RET_"^"_ERR
Q
GETQUAL(IEN) ;Get any qualifiers for this POV
N AIEN,IEN2,BY,WHEN,X,FNUM,Q,STRING,STRING2,STRING3,STRING4
S (STRING,STRING2,STRING3,STRING4)=""
F X=13,17,18,14 D
.S IEN2=0 F S IEN2=$O(^AUPNVPOV(IEN,X,IEN2)) Q:'+IEN2 D
..S AIEN=IEN2_","_IEN_","
..I X=13 D
...S Q=$$GET1^DIQ(9000010.0713,AIEN,.01)
...S Q=$$CONCEPT^BGOPAUD(Q)
...I STRING="" S STRING=Q
...E S STRING=STRING_" "_Q
..I X=17 D
...S Q=$$GET1^DIQ(9000010.0717,AIEN,.01)
...S Q=$$CONCEPT^BGOPAUD(Q)
...I STRING2="" S STRING2=Q
...E S STRING2=STRING2_" "_Q
..I X=18 D
...S Q=$$GET1^DIQ(9000010.0718,AIEN,.01)
...S Q=$$CONCEPT^BGOPAUD(Q)
...I STRING3="" S STRING3=Q
...E S STRING3=STRING3_" "_Q
..I X=14 D
...S Q=$$GET1^DIQ(9000010.0714,AIEN,.01)
...S Q=$$CONCEPT^BGOPAUD(Q)
...I STRING4="" S STRING4=Q
...E S STRING4=STRING4_" "_Q
S QUAL=STRING_"|"_STRING2_"|"_STRING3_"^"_STRING4
Q QUAL
QUALLK(PROMPT,SNOMED,TYPE) ;Lookup for normal/abnormal qualifier added P19
;Determine if this snomed code needs to be prompted for normal/abnormal qualifiers
N IN,SEARCH,X
S PROMPT=0
S SEARCH=$S(TYPE="N":"EHR IPL PROMPT ABN FINDINGS",1:"")
I SEARCH'="" D
.S IN=SNOMED_U_SEARCH_U_U_1
.S PROMPT=$$VSBTRMF^BSTSAPI(IN)
Q
FRAC(CODES,CONCT) ;Lookup new problems to see if its a fracture added P23
N FRACTURE,FXLST,SNODATA
S CODES=""
S SNODATA=$$CONC^BSTSAPI(CONCT_"^^^1")
S FRACTURE=$P(SNODATA,U,10)
S FXLST=$P(SNODATA,U,11)
S CODES=FRACTURE_U_FXLST
Q
;IHS/MSC/MGH check for duplicates
;INP=DFN ^ SNOMED Concept CT ^ PRIEN
LATCHK(RET,INP) ;EP-Check laterality
N CNT,DFN,CONCID,PRIEN,LAT,LEF,RI,BI,DATA
S RET=$$TMPGBL^BGOUTL
S DFN=$P(INP,U,1)
S CNT=0
S LEF="272741003|7771000",RI="272741003|24028007",BI="272741003|51440002"
S CONCID=$P(INP,U,2)
S PRIEN=$P(INP,U,3)
S DATA("None",PRIEN)=1
;start with left
K ARR
D EQUIV^BSTSAPI("ARR",CONCID_"^"_$P(LEF,"|",2))
D CHKTR(.ARR,"Left",LEF)
;then right
K ARR
D EQUIV^BSTSAPI("ARR",CONCID_"^"_$P(RI,"|",2))
D CHKTR(.ARR,"Right",RI)
;then bilateral
K ARR
D EQUIV^BSTSAPI("ARR",CONCID_"^"_$P(BI,"|",2))
D CHKTR(.ARR,"Bilateral",BI)
;Set up the 4 types
F TYP="None","Left","Right","Bilateral" D
.S IEN=$O(DATA(TYP,""))
.I 'IEN D NEW(CONCID,TYP)
.E D SETDATA(IEN,TYP)
Q
CHKTR(ARR,LATNAME,LATTYP) ;EP- Find equivalent problems
N I1,ENOD,ESNO,ELAT,EEXT,ELAT,IEN,STAT,PLAT
S I1="" F S I1=$O(ARR(I1)) Q:I1="" D
.S ENOD=$G(ARR(I1))
.S ESNO=$P(ENOD,U,1)
.S ELAT=$P(ENOD,U,2)
.S EEXT=$P(ENOD,U,3)
.I ELAT="" D
..S IEN="" F S IEN=$O(^AUPNPROB("APCT",DFN,ESNO,IEN)) Q:'+IEN D
...S STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
...Q:STAT="D"
...S PLAT=$$GET1^DIQ(9000011,IEN,.22)
...Q:EEXT'=1
...S DATA(LATNAME,IEN)=1_U_LATTYP
.I ELAT'="" D
..S IEN="" F S IEN=$O(^AUPNPROB("ASLT",DFN,ESNO,ELAT,IEN)) Q:'+IEN D
...S STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
...Q:STAT="D"
...S DATA(LATNAME,IEN)=1_U_LATTYP
Q
SETDATA(PRIEN,TYP) ;get data for exisitng problem
N DESCT,PNAR,EXLAT,PLAT,ICD,STAT
S DESCT=$$GET1^DIQ(9000011,PRIEN_",",80002) ;Description ID
S PNAR=$$GET1^DIQ(9000011,PRIEN_",",.05) ;Prov nar
S PLAT=$$GET1^DIQ(9000011,PRIEN_",",.22,"I") ;Laterality
S ICD=$$GET1^DIQ(9000011,PRIEN_",",.01) ;ICD code
S EXLAT=""
I PLAT'="" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|",2))
S STAT=$$GET1^DIQ(9000011,PRIEN,.12,"I")
S CNT=CNT+1
S @RET@(CNT)=TYP_U_PRIEN_U_CONCID_U_PLAT_U_DESCT_U_PNAR_U_EXLAT_U_ICD_U_STAT
Q
NEW(CONCID,TYP) ;Enter data for a new item
N DESCT,PNAR,EXLAT,PLAT,ICD,STAT,NODE,DEFST
S PLAT=$S(TYP="Left":"272741003|7771000",TYP="Right":"272741003|24028007",TYP="Bilateral":"272741003|51440002",1:"")
S NODE=$$CONC^BSTSAPI(CONCID_"^^^1^^"_$P(PLAT,"|",2))
S DESCT=$P(NODE,U,3)
S PNAR=$P(NODE,U,4)
S ICD=$P(NODE,U,5)
S EXLAT=""
I PLAT'="" S EXLAT=$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(PLAT,"|",2))
S DEFST=$P(NODE,U,9)
S DEFST=$S(DEFST="Chronic":"A",DEFST="Sub-acute":"S",DEFST="Episodic":"E",DEFST="Social/Environmental":"O",DEFST="Routine/Admin":"R",DEFST="Admin":"R",1:"")
S CNT=CNT+1
S @RET@(CNT)=TYP_U_0_U_CONCID_U_PLAT_U_DESCT_U_PNAR_U_EXLAT_U_ICD_U_DEFST
Q
HELPDATA ;;
;;
;;When BGOVPOV files VPOV entries, it does not place the primary POV
;;first. PCC expects the primary POV to always have the lowest IEN
;;of POV's associated with a visit. This utility aids in identifying
;;and fixing VPOV entries that are improperly sequenced. The following
;;entry points are available:
;;
;;FIXVPOVS: This entry point accepts a visit IEN as its parameter.
;;When invoked, it will examine the specified visit and resequence
;;the associated POV entries if necessary. It will return one of
;;the following values:
;;
;; 0 = No resequencing required
;; 1 = Resequencing succeeded
;; 2 = Resequencing failed
;;
;;FINDALL: This entry point will search all visits with associated
;;POV entries and report any with improperly sequenced entries.
;;It accepts an optional parameter. If this parameter is passed
;;and has a nonzero value, improperly sequenced entries will be
;;repaired automatically.
;;
;;This entry point stores the results of the search in the
;;^XTMP("BGOVPOV1") global. This global may be examined to
;;determine which visits were successfully resequenced
;;(listed under ^XTMP("BGOVPOV1","FIXED")) and which were not
;;(listed under ^XTMP("BGOVPOV1","NOT FIXED")).
;;
;;
;;<END>
BGOVPOV1 ; MSC/IND/DKM - Fix VPOV sequencing (primary first) ;20-Jun-2017 15:26;DU
+1 ;;1.1;BGO COMPONENTS;**3,13,19,20,23**;Mar 20, 2007;Build 1
+2 ; Display routine help
HELP ;EP
+1 NEW LP,X
+2 FOR LP=0:1
SET X=$PIECE($TEXT(HELPDATA+LP),";;",2,99)
IF X="<END>"
QUIT
WRITE X,!
+3 QUIT
+4 ; Finds all visits with improperly sequenced VPOVs
+5 ; If FIX is true, the VPOVs will be resequenced
FINDALL(FIX) ;EP
+1 NEW VIEN,FND,FIXED,LP
+2 KILL ^XTMP("BGOVPOV1")
+3 SET ^XTMP("BGOVPOV1",0)=DT_U_DT
+4 SET (FND,FIXED,VIEN)=0
SET FIX=+$GET(FIX)
+5 FOR LP=0:1
SET VIEN=$ORDER(^AUPNVPOV("AD",VIEN))
IF 'VIEN
QUIT
Begin DoDot:1
+6 IF '(LP#1000)
WRITE "."
+7 IF $$GETVPOVS(VIEN)
QUIT
+8 SET FND=FND+1
+9 IF FIX
IF $$FIXVPOVS(VIEN)=1
SET FIXED=FIXED+1
SET ^XTMP("BGOVPOV1","FIXED",VIEN)=""
+10 IF '$TEST
SET ^XTMP("BGOVPOV1","NOT FIXED",VIEN)=""
End DoDot:1
+11 SET ^XTMP("BGOVPOV1","FIXED")=FIXED
SET ^("NOT FIXED")=FND-FIXED
+12 WRITE !,"Visits with improperly sequenced VPOVs: ",FND,!
+13 WRITE !,"Visits with successfully resequenced VPOVs: ",FIXED,!
+14 QUIT
+15 ; Called from BGOVPOV to insure that the primary is the first entry.
+16 ; VIEN = IEN of visit to inspect
+17 ; .VPOV = IEN of entry to track (optional - returned as new IEN if changed)
+18 ; Returns: 0 = VPOV entries require no resequencing
+19 ; 1 = VPOV entries were successfully resequenced
+20 ; 2 = VPOV entries were not successfully resequenced
FIXVPOVS(VIEN,VPOV) ;EP
+1 NEW VPOV1,VPOV2,RET
+2 IF $$GETVPOVS(VIEN,.VPOV1,.VPOV2)
QUIT 0
+3 SET RET=$$SWAP(VPOV1,VPOV2)
+4 IF 'RET
QUIT 2
+5 SET VPOV=$GET(VPOV)
+6 SET VPOV=$SELECT(VPOV=VPOV1:VPOV2,VPOV=VPOV2:VPOV1,1:VPOV)
+7 QUIT 1
+8 ; Returns two VPOVs to be swapped.
+9 ; VIEN = IEN of visit to inspect
+10 ; VPOV1, VPOV2 = VPOV's to be swapped
+11 ; Return value is 1 if VPOVs are in correct order
GETVPOVS(VIEN,VPOV1,VPOV2) ;EP
+1 SET VPOV1=$$FNDPRI(VIEN)
+2 IF 'VPOV1
QUIT 1
+3 SET VPOV2=$ORDER(^AUPNVPOV("AD",VIEN,0))
+4 IF 'VPOV2!(VPOV2=VPOV1)
QUIT 1
+5 QUIT 0
+6 ; Swap VPOVs
+7 ; Returns true if successful
SWAP(VPOV1,VPOV2) ;
+1 NEW FDA,RET,NEWNUM
+2 IF '$$BLDFDA(VPOV1,VPOV2,.FDA)
QUIT 0
+3 SET RET=$$UPDATE^BGOUTL(.FDA,"@")
+4 QUIT $SELECT(RET<0:0,1:1)
+5 ; Build FDA array for swap
+6 ; Returns true if successful
BLDFDA(VPOV1,VPOV2,FDA,FLG) ;
+1 NEW REC,ERR,FLD,FNUM,IENS1,IENS2,FUM,FNUM2,SIEN,MULT,MULT2,RET
+2 SET RET=""
+3 SET IENS1=VPOV1_","
SET IENS2=VPOV2_","
SET FNUM=9000010.07
+4 DO GETS^DIQ(FNUM,IENS1,"**","I","REC","ERR")
+5 IF $$REFERR
QUIT 0
+6 SET FLD=""
+7 FOR
SET FLD=$ORDER(REC(FNUM,IENS1,FLD))
IF '$LENGTH(FLD)
QUIT
Begin DoDot:1
+8 IF $$GET1^DID(FNUM,FLD,,"TYPE")="COMPUTED"
QUIT
+9 SET FDA(FNUM,IENS2,FLD)=REC(FNUM,IENS1,FLD,"I")
End DoDot:1
+10 FOR FUM=13,14,17,18
Begin DoDot:1
+11 ;Delete subfile if any
+12 DO DELSUB(.RET,$PIECE(IENS1,",",1),FUM)
+13 IF +RET
QUIT
+14 SET FNUM2=FNUM_FUM
+15 SET MULT=""
+16 FOR
SET MULT=$ORDER(REC(FNUM2,MULT))
IF '$LENGTH(MULT)
QUIT
Begin DoDot:2
+17 SET NUMNEW=$GET(NUMNEW)+1
+18 SET FLD=""
FOR
SET FLD=$ORDER(REC(FNUM2,MULT,FLD))
IF '$LENGTH(FLD)
QUIT
Begin DoDot:3
+19 IF FLD=.019
QUIT
+20 IF $$GET1^DIQ(FNUM2,FLD,,"TYPE")="COMPUTED"
QUIT
+21 SET SIEN="+"_NUMNEW_","
SET MULT2=SIEN_IENS2
+22 SET FDA(FNUM2,MULT2,FLD)=REC(FNUM2,MULT,FLD,"I")
End DoDot:3
End DoDot:2
End DoDot:1
+23 IF '$GET(FLG)
QUIT $$BLDFDA(VPOV2,VPOV1,.FDA,1)
+24 SET FLD=""
+25 FOR
SET FLD=$ORDER(FDA(FNUM,IENS1,FLD))
IF '$LENGTH(FLD)
QUIT
Begin DoDot:1
+26 IF FDA(FNUM,IENS1,FLD)=FDA(FNUM,IENS2,FLD)
Begin DoDot:2
+27 KILL FDA(FNUM,IENS1,FLD),FDA(FNUM,IENS2,FLD)
End DoDot:2
End DoDot:1
+28 IF $DATA(FDA(FNUM,IENS1,.03))
QUIT 0
+29 IF $DATA(FDA(FNUM,IENS1,.02))
QUIT 0
+30 QUIT 1
DELSUB(RET,IEN,SFIL) ;Delete the subfile entries
+1 NEW I,SIEN
+2 SET SIEN=""
FOR
SET SIEN=$ORDER(^AUPNVPOV(IEN,SFIL,SIEN))
IF SIEN=""!(+RET)
QUIT
Begin DoDot:1
+3 SET DA(1)=IEN
SET DA=SIEN
+4 SET DIK="^AUPNVPOV(DA(1),SFIL,"
+5 IF DA
SET RET=$$DELETE^BGOUTL(DIK,.DA)
End DoDot:1
+6 QUIT
REFERR() IF $DATA(ERR("DIERR",1,"TEXT",1))
Begin DoDot:1
+1 SET ^XTMP("BGOVPOV1","ERROR",VPOV1)=ERR("DIERR",1,"TEXT",1)
End DoDot:1
QUIT 1
+2 QUIT 0
+3 ; Display POVs associated with a visit
DISPPOVS(VIEN) ;
+1 NEW VPOV,X,Y
+2 SET VPOV=0
+3 FOR
SET VPOV=$ORDER(^AUPNVPOV("AD",VIEN,VPOV))
IF 'VPOV
QUIT
Begin DoDot:1
+4 SET X=$GET(^AUPNVPOV(VPOV,0))
SET Y=$GET(^(12))
+5 WRITE !,VIEN,": ",VPOV,!?5,"0: ",X,!?4,"12: ",Y,!!
End DoDot:1
+6 QUIT
+7 ; Return IEN of primary POV for a visit
FNDPRI(VIEN) ;EP
+1 NEW VPOV,RET,X
+2 SET VPOV=0
+3 FOR
SET VPOV=$ORDER(^AUPNVPOV("AD",VIEN,VPOV))
IF 'VPOV
QUIT
Begin DoDot:1
+4 SET X=$GET(^AUPNVPOV(VPOV,0))
+5 IF $PIECE(X,U,3)=VIEN
IF $PIECE(X,U,12)="P"
SET RET=VPOV
End DoDot:1
IF $DATA(RET)
QUIT
+6 QUIT $GET(RET)
UPREV(RET,DFN,VIEN) ;Update review data
+1 NEW VSTR,ERR,TYPE,UTYP,INP
+2 SET ERR=""
+3 SET VSTR=$$VIS2VSTR^BEHOENCX(DFN,VIEN,ERR)
+4 IF ERR'=""
SET RET=ERR
QUIT
+5 FOR TYPE="PROBLEM LIST REVIEWED","PROBLEM LIST UPDATED"
Begin DoDot:1
+6 SET UTYP=$ORDER(^AUTTCRA("B",TYPE,""))
+7 IF '+UTYP
QUIT
+8 SET INP=UTYP_U_0_U_DFN_U_VSTR_U_U_DUZ
+9 DO SET^BGOVUPD(.RET,INP)
End DoDot:1
+10 QUIT
QUAL(RET,POV,QUAL) ;EP
+1 ;Store the episodicity qualifiers
+2 NEW FNUM,IEN,SNO,DEL
+3 SET FNUM=9000010.0714
+4 SET IEN=+$PIECE(QUAL,U,3)
+5 SET SNO=$PIECE(QUAL,U,4)
+6 SET DEL=$PIECE(QUAL,U,7)
+7 IF '$DATA(^AUPNVPOV(POV,14,"B"))
SET IEN=""
+8 IF '$TEST
SET IEN=0
SET IEN=$ORDER(^AUPNVPOV(POV,14,IEN))
+9 IF +IEN&(DEL=1)
DO DELQ(RET,POV,IEN)
+10 IF '$TEST
DO STORE(.RET,POV,SNO,FNUM,IEN)
+11 QUIT
STORE(RET,POV,SNO,FNUM,IEN) ;Store the qualifier data
+1 NEW AIEN,IEN2,ERR,FDA
+2 IF IEN=""
SET AIEN="+1,"_POV_","
+3 IF '$TEST
SET AIEN=IEN_","_POV_","
+4 SET SNO=$TRANSLATE(SNO," ","")
+5 SET FDA(FNUM,AIEN,.01)=SNO
+6 DO UPDATE^DIE(,"FDA","IEN2","ERR")
+7 IF $GET(ERR("DIERR",1))
SET RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
+8 QUIT
QUALB(RET,PROB,POV) ;EP
+1 ;Move the qualfiers from the problem over to the POV fields
+2 NEW FUM,SNO,FNUM,I,IEN
+3 IF $GET(PROB)=""
QUIT
+4 FOR FUM=13,17,18
Begin DoDot:1
+5 SET I=0
FOR
SET I=$ORDER(^AUPNPROB(PROB,FUM,I))
IF '+I
QUIT
Begin DoDot:2
+6 SET SNO=$PIECE($GET(^AUPNPROB(PROB,FUM,I,0)),U,1)
+7 IF SNO'=""
Begin DoDot:3
+8 SET FNUM=$SELECT(FUM=13:9000010.0713,FUM=17:9000010.0717,FUM=18:9000010.0718)
+9 SET IEN=""
+10 DO STORE(.RET,POV,SNO,FNUM,IEN)
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
DELQ(RET,POV,PRIEN) ;Delete a qualifer
+1 NEW ERR,DA,DIK,NODE
+2 SET ERR=""
+3 SET NODE=14
+4 SET DA(1)=PRIEN
SET DA=IEN
+5 SET DIK="^AUPNVPOV(DA(1),"_NODE_","
+6 IF DA
SET ERR=$$DELETE^BGOUTL(DIK,.DA)
+7 IF ERR'=""
SET RET=RET_"^"_ERR
+8 QUIT
GETQUAL(IEN) ;Get any qualifiers for this POV
+1 NEW AIEN,IEN2,BY,WHEN,X,FNUM,Q,STRING,STRING2,STRING3,STRING4
+2 SET (STRING,STRING2,STRING3,STRING4)=""
+3 FOR X=13,17,18,14
Begin DoDot:1
+4 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNVPOV(IEN,X,IEN2))
IF '+IEN2
QUIT
Begin DoDot:2
+5 SET AIEN=IEN2_","_IEN_","
+6 IF X=13
Begin DoDot:3
+7 SET Q=$$GET1^DIQ(9000010.0713,AIEN,.01)
+8 SET Q=$$CONCEPT^BGOPAUD(Q)
+9 IF STRING=""
SET STRING=Q
+10 IF '$TEST
SET STRING=STRING_" "_Q
End DoDot:3
+11 IF X=17
Begin DoDot:3
+12 SET Q=$$GET1^DIQ(9000010.0717,AIEN,.01)
+13 SET Q=$$CONCEPT^BGOPAUD(Q)
+14 IF STRING2=""
SET STRING2=Q
+15 IF '$TEST
SET STRING2=STRING2_" "_Q
End DoDot:3
+16 IF X=18
Begin DoDot:3
+17 SET Q=$$GET1^DIQ(9000010.0718,AIEN,.01)
+18 SET Q=$$CONCEPT^BGOPAUD(Q)
+19 IF STRING3=""
SET STRING3=Q
+20 IF '$TEST
SET STRING3=STRING3_" "_Q
End DoDot:3
+21 IF X=14
Begin DoDot:3
+22 SET Q=$$GET1^DIQ(9000010.0714,AIEN,.01)
+23 SET Q=$$CONCEPT^BGOPAUD(Q)
+24 IF STRING4=""
SET STRING4=Q
+25 IF '$TEST
SET STRING4=STRING4_" "_Q
End DoDot:3
End DoDot:2
End DoDot:1
+26 SET QUAL=STRING_"|"_STRING2_"|"_STRING3_"^"_STRING4
+27 QUIT QUAL
QUALLK(PROMPT,SNOMED,TYPE) ;Lookup for normal/abnormal qualifier added P19
+1 ;Determine if this snomed code needs to be prompted for normal/abnormal qualifiers
+2 NEW IN,SEARCH,X
+3 SET PROMPT=0
+4 SET SEARCH=$SELECT(TYPE="N":"EHR IPL PROMPT ABN FINDINGS",1:"")
+5 IF SEARCH'=""
Begin DoDot:1
+6 SET IN=SNOMED_U_SEARCH_U_U_1
+7 SET PROMPT=$$VSBTRMF^BSTSAPI(IN)
End DoDot:1
+8 QUIT
FRAC(CODES,CONCT) ;Lookup new problems to see if its a fracture added P23
+1 NEW FRACTURE,FXLST,SNODATA
+2 SET CODES=""
+3 SET SNODATA=$$CONC^BSTSAPI(CONCT_"^^^1")
+4 SET FRACTURE=$PIECE(SNODATA,U,10)
+5 SET FXLST=$PIECE(SNODATA,U,11)
+6 SET CODES=FRACTURE_U_FXLST
+7 QUIT
+8 ;IHS/MSC/MGH check for duplicates
+9 ;INP=DFN ^ SNOMED Concept CT ^ PRIEN
LATCHK(RET,INP) ;EP-Check laterality
+1 NEW CNT,DFN,CONCID,PRIEN,LAT,LEF,RI,BI,DATA
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET DFN=$PIECE(INP,U,1)
+4 SET CNT=0
+5 SET LEF="272741003|7771000"
SET RI="272741003|24028007"
SET BI="272741003|51440002"
+6 SET CONCID=$PIECE(INP,U,2)
+7 SET PRIEN=$PIECE(INP,U,3)
+8 SET DATA("None",PRIEN)=1
+9 ;start with left
+10 KILL ARR
+11 DO EQUIV^BSTSAPI("ARR",CONCID_"^"_$PIECE(LEF,"|",2))
+12 DO CHKTR(.ARR,"Left",LEF)
+13 ;then right
+14 KILL ARR
+15 DO EQUIV^BSTSAPI("ARR",CONCID_"^"_$PIECE(RI,"|",2))
+16 DO CHKTR(.ARR,"Right",RI)
+17 ;then bilateral
+18 KILL ARR
+19 DO EQUIV^BSTSAPI("ARR",CONCID_"^"_$PIECE(BI,"|",2))
+20 DO CHKTR(.ARR,"Bilateral",BI)
+21 ;Set up the 4 types
+22 FOR TYP="None","Left","Right","Bilateral"
Begin DoDot:1
+23 SET IEN=$ORDER(DATA(TYP,""))
+24 IF 'IEN
DO NEW(CONCID,TYP)
+25 IF '$TEST
DO SETDATA(IEN,TYP)
End DoDot:1
+26 QUIT
CHKTR(ARR,LATNAME,LATTYP) ;EP- Find equivalent problems
+1 NEW I1,ENOD,ESNO,ELAT,EEXT,ELAT,IEN,STAT,PLAT
+2 SET I1=""
FOR
SET I1=$ORDER(ARR(I1))
IF I1=""
QUIT
Begin DoDot:1
+3 SET ENOD=$GET(ARR(I1))
+4 SET ESNO=$PIECE(ENOD,U,1)
+5 SET ELAT=$PIECE(ENOD,U,2)
+6 SET EEXT=$PIECE(ENOD,U,3)
+7 IF ELAT=""
Begin DoDot:2
+8 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPROB("APCT",DFN,ESNO,IEN))
IF '+IEN
QUIT
Begin DoDot:3
+9 SET STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
+10 IF STAT="D"
QUIT
+11 SET PLAT=$$GET1^DIQ(9000011,IEN,.22)
+12 IF EEXT'=1
QUIT
+13 SET DATA(LATNAME,IEN)=1_U_LATTYP
End DoDot:3
End DoDot:2
+14 IF ELAT'=""
Begin DoDot:2
+15 SET IEN=""
FOR
SET IEN=$ORDER(^AUPNPROB("ASLT",DFN,ESNO,ELAT,IEN))
IF '+IEN
QUIT
Begin DoDot:3
+16 SET STAT=$$GET1^DIQ(9000011,IEN,.12,"I")
+17 IF STAT="D"
QUIT
+18 SET DATA(LATNAME,IEN)=1_U_LATTYP
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
SETDATA(PRIEN,TYP) ;get data for exisitng problem
+1 NEW DESCT,PNAR,EXLAT,PLAT,ICD,STAT
+2 ;Description ID
SET DESCT=$$GET1^DIQ(9000011,PRIEN_",",80002)
+3 ;Prov nar
SET PNAR=$$GET1^DIQ(9000011,PRIEN_",",.05)
+4 ;Laterality
SET PLAT=$$GET1^DIQ(9000011,PRIEN_",",.22,"I")
+5 ;ICD code
SET ICD=$$GET1^DIQ(9000011,PRIEN_",",.01)
+6 SET EXLAT=""
+7 IF PLAT'=""
SET EXLAT=$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|",2))
+8 SET STAT=$$GET1^DIQ(9000011,PRIEN,.12,"I")
+9 SET CNT=CNT+1
+10 SET @RET@(CNT)=TYP_U_PRIEN_U_CONCID_U_PLAT_U_DESCT_U_PNAR_U_EXLAT_U_ICD_U_STAT
+11 QUIT
NEW(CONCID,TYP) ;Enter data for a new item
+1 NEW DESCT,PNAR,EXLAT,PLAT,ICD,STAT,NODE,DEFST
+2 SET PLAT=$SELECT(TYP="Left":"272741003|7771000",TYP="Right":"272741003|24028007",TYP="Bilateral":"272741003|51440002",1:"")
+3 SET NODE=$$CONC^BSTSAPI(CONCID_"^^^1^^"_$PIECE(PLAT,"|",2))
+4 SET DESCT=$PIECE(NODE,U,3)
+5 SET PNAR=$PIECE(NODE,U,4)
+6 SET ICD=$PIECE(NODE,U,5)
+7 SET EXLAT=""
+8 IF PLAT'=""
SET EXLAT=$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$PIECE(PLAT,"|",2))
+9 SET DEFST=$PIECE(NODE,U,9)
+10 SET DEFST=$SELECT(DEFST="Chronic":"A",DEFST="Sub-acute":"S",DEFST="Episodic":"E",DEFST="Social/Environmental":"O",DEFST="Routine/Admin":"R",DEFST="Admin":"R",1:"")
+11 SET CNT=CNT+1
+12 SET @RET@(CNT)=TYP_U_0_U_CONCID_U_PLAT_U_DESCT_U_PNAR_U_EXLAT_U_ICD_U_DEFST
+13 QUIT
HELPDATA ;;
+1 ;;
+2 ;;When BGOVPOV files VPOV entries, it does not place the primary POV
+3 ;;first. PCC expects the primary POV to always have the lowest IEN
+4 ;;of POV's associated with a visit. This utility aids in identifying
+5 ;;and fixing VPOV entries that are improperly sequenced. The following
+6 ;;entry points are available:
+7 ;;
+8 ;;FIXVPOVS: This entry point accepts a visit IEN as its parameter.
+9 ;;When invoked, it will examine the specified visit and resequence
+10 ;;the associated POV entries if necessary. It will return one of
+11 ;;the following values:
+12 ;;
+13 ;; 0 = No resequencing required
+14 ;; 1 = Resequencing succeeded
+15 ;; 2 = Resequencing failed
+16 ;;
+17 ;;FINDALL: This entry point will search all visits with associated
+18 ;;POV entries and report any with improperly sequenced entries.
+19 ;;It accepts an optional parameter. If this parameter is passed
+20 ;;and has a nonzero value, improperly sequenced entries will be
+21 ;;repaired automatically.
+22 ;;
+23 ;;This entry point stores the results of the search in the
+24 ;;^XTMP("BGOVPOV1") global. This global may be examined to
+25 ;;determine which visits were successfully resequenced
+26 ;;(listed under ^XTMP("BGOVPOV1","FIXED")) and which were not
+27 ;;(listed under ^XTMP("BGOVPOV1","NOT FIXED")).
+28 ;;
+29 ;;
+30 ;;<END>
