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

BGOVPOV1.m

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