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

BMXADOFS.m

Go to the documentation of this file.
  1. BMXADOFS ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; 31 Jul 2009 12:42 PM
  1. ;;4.0;BMX;**4**;JUN 28, 2010;Build 4
  1. ; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
  1. ; CONTAINS SPECIAL CODE RELATED TO FILING PROPLEMS, POVS, FAMILY HX, PERSONAL HX AND NOTES
  1. ;
  1. ;
  1. TPOV ; ADD POV TEST
  1. S DATA=".01|`8718"_$C(30)_".02|`53"_$C(30)_".03|`3909"_$C(30)_".04|DM---I"_$C(30)_".12|P"_$C(30,31)
  1. D FILE^BMXADOF(.XXX,9000010.07,"",DATA) W !,XXX K XXX,DATA Q
  1. ;
  1. TH ; HX TEST
  1. S DATA=".01|250.00"_$C(30)_".02|`53"_$C(30)_".03|JUL 15,2004"_$C(30)_".04|FAMILY HX OF LUNG CA"_$C(30,31)
  1. D FILE^BMXADOF(.XXX,9000014,"",DATA) W !,XXX K XXX,DATA Q
  1. ;
  1. TNOTE ; TEST ADDING A NOTE TO A PROBLEM
  1. N DATA,XXX,PROBIEN,FACNIEN,FACIEN,DAS
  1. S PROBIEN=3,FACIEN=4587
  1. S FACNIEN=$$FACNIEN(PROBIEN,FACIEN) ; YOU MUST SPECIFY THE PROBLEM IEN AND THE FACILITY IEN
  1. S DAS=PROBIEN_","_FACNIEN_","
  1. S DATA=".03|NEW NOTE #2"_$C(30,31) ; THE DATA STRING JUST CONTAINS THE NOTE FIELD.
  1. ; THE OTHER FIELDS (INCLUDING .01) ARE ADDED BY BMXADOF
  1. D FILE^BMXADOF(.XXX,9000011.1111,DAS,DATA) W !,XXX
  1. Q
  1. ;
  1. ; -----------------------------------------------------------------------------------------------------
  1. ;
  1. SPEC(FILE,DATA,UFLG) ;EP - SPECIAL DATA MODS FOR SPECIFIC FILES
  1. I FILE=9000010.07 S DATA=$$POV(DATA) Q DATA
  1. I FILE=9000011 S DATA=$$PROB(DATA,$G(UFLG)) Q DATA
  1. I FILE=9000013!(FILE=9000014) S DATA=$$HX(DATA) Q DATA
  1. I FILE=9000011.1111 S DATA=$$NOTE(DATA,$G(DAS(2)),$G(DAS(1))) Q DATA
  1. ; I FILE=9000010.18,DATA'["|.04|" G DSTG
  1. Q DATA
  1. ;
  1. HX(DATA) ; INPUT STRING TRANSFORM FOR PHX AND FHX
  1. N NARR,NIEN,%,A,B,X,Y,%DT
  1. I DATA[".01|`" G HNARR
  1. S DATA=$$ICD(DATA,.01) I DATA="" Q ""
  1. HNARR I DATA'[".04|'" G HDT
  1. S DATA=$$NARR(DATA,.04)
  1. HDT I DATA'[".03|" Q DATA
  1. S X=+$P(DATA,".03|",2) I X?7N Q DATA
  1. S %DT="" D ^%DT
  1. I Y'?7N Q DATA
  1. S A=$P(DATA,".03|")
  1. S B=$P(DATA,".03|",2) S B=$P(B,$C(30),2)
  1. S DATA=A_".03|"_Y
  1. I $L(B) S DATA=DATA_$C(30)_B
  1. Q DATA
  1. ;
  1. POV(DATA) ; POV INPUT STRING TRANSFORM
  1. N NARR,NIEN,%,CIEN
  1. S CIEN=$P($P(DATA,$C(30)),".01|",2)
  1. I CIEN?1N.N G PVNARR
  1. S DATA=$$ICD(DATA,.01) I DATA="" Q ""
  1. PVNARR I DATA'[".04|'" Q DATA
  1. S DATA=$$NARR(DATA,.04)
  1. Q DATA
  1. ;
  1. PROB(DATA,UFLG) ; PROBLEM LIST INPUT STRING TRANSFORM
  1. N NARR,NIEN,%,PNUM,FACIEN,DFN,X,A,B
  1. PNARR I DATA'[".05|" G PICD
  1. S %=$P(DATA,".05|",2)
  1. S NARR=$P(%,$C(30))
  1. I NARR'?1"`"1.N S DATA=$$NARR(DATA,.05) ; STUFF THE NARR LOOKUP VALUE IN THE DATA STRING
  1. I '$L(DATA) Q ""
  1. PICD S %=$P(DATA,"|") I %'=.01,DATA'[($C(30)_".01|") G PNUM
  1. S DATA=$$ICD(DATA,.01) I DATA="" Q ""
  1. PNUM I $G(UFLG)="E" Q DATA ; STOP HERE IF IN EDIT MODE
  1. I $P(DATA,($C(30)_".07|"),2) G TODAY ; GET NEXT PROB NUM
  1. S DFN=+$P(DATA,".02|`",2)
  1. I 'DFN S DATA="" Q ""
  1. S FACIEN=+$P(DATA,".06|`",2)
  1. I 'FACIEN Q ""
  1. S PNUM=$$NEXTPBN(DFN,FACIEN)
  1. I 'PNUM Q ""
  1. S X=$L(DATA,$C(30))
  1. S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X)
  1. S DATA=A_$C(30)_".07|"_PNUM_$C(30)_B
  1. TODAY I $P(DATA,($C(30)_".08|"),2) Q DATA ; GET TODAY'S DATE
  1. S X=$L(DATA,$C(30))
  1. S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X)
  1. S DATA=A_$C(30)_".08|"_$G(DT)_$C(30)_B
  1. Q DATA
  1. ;
  1. NOTE(DATA,PIEN,FNIEN) ; GIVEN A DATA STRING CONTAINING THE NOTE, THE PROBLEM IEN, AND THE FAC-NOTE IEN:
  1. ; ADD NOTE # AND STATUS TO THE DATA STRING
  1. I $G(DATA)'[".03|" Q ""
  1. I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q ""
  1. N NUM
  1. I DATA'[".04|" S DATA=".04|A"_$C(30)_DATA
  1. I DATA'[".01|" D
  1. . S NUM=$$NEXTNOTE(PIEN,FNIEN)
  1. . I 'NUM Q
  1. . S DATA=".01|"_NUM_$C(30)_DATA
  1. Q DATA
  1. ;
  1. ;Test ICD lookup
  1. TSTICD N XXICD,PIECE,PARM,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,IEN
  1. S DIR("A",1)="",DIR("A")="Enter the ICD Code: "
  1. S DIR(0)="FA^1:98"
  1. D ^DIR I +Y<1,+$E(Y,2,99)<1 Q
  1. S XXICD=Y
  1. ;
  1. S DIR("A",1)="",DIR("A")="Enter the piece to check (1 or 2): "
  1. S DIR(0)="FA^1:98"
  1. D ^DIR I Y'=1,Y'=2 Q
  1. S PIECE=Y
  1. ;
  1. I PIECE=1 S PARM=".01|"_XXICD_$C(30)_".02|"_$C(30)_".03|ABC"
  1. I PIECE=2 S PARM=".01|"_$C(30)_".02|"_XXICD_$C(30)_".03|ABC"
  1. S X=$$ICD(PARM,$S(PIECE="1":".01",1:".02"))
  1. W !,$TR(X,$C(30),"{")
  1. I PIECE=1 S IEN=$P(X,"|",2)
  1. I PIECE=2 S IEN=$P(X,"|",3)
  1. S IEN=$P($TR($TR(IEN,"`"),"{"),$C(30))
  1. I IEN>0 W !,$$GET1^DIQ(80,IEN_",",.01,"E")
  1. Q
  1. ;
  1. TI N XXX S XXX=$$ICD(".01|250.00"_$C(30)_".02|123"_$C(30)_".03|ABC",.01) W !,$TR(XXX,$C(30),"{") Q
  1. ICD(DATA,FLD) ; VERIFY ICD CODE AND GET LOOKUP VALUE
  1. I '$G(FLD) Q ""
  1. I '$L($G(DATA)) Q ""
  1. N %,A,B
  1. S %=$P(DATA,"|")
  1. ;
  1. ;Process Piece .01
  1. I %=FLD D Q DATA
  1. . NEW IEN,OVAL,CODE
  1. . S IEN=""
  1. . S CODE=$P(DATA,"|",2)
  1. . S (CODE,OVAL)=$P(CODE,$C(30))
  1. . I CODE?1"`"1.N Q
  1. . ;
  1. . ;Pull appropriate ICD-9/ICD-10 code
  1. . ;
  1. . ;ICD-9 Only (Pre-AICD build)
  1. . I $$VERSION^XPDUTL("AICD")<4.0 D
  1. .. S IEN=$O(^ICD9("BA",CODE_" ",0))
  1. .. I $L($T(CODEN^ICDCODE)) S IEN=+$$CODEN^ICDCODE(IEN,80) I IEN<0 S IEN=""
  1. . ;
  1. . ;ICD-9 or ICD-10
  1. . I $$VERSION^XPDUTL("AICD")>3.51 D
  1. .. NEW STR
  1. .. ;
  1. .. ;Date has passed - First look for ICD-10
  1. .. I $$IMP^ICDEXA(30)'>DT D Q:IEN]""
  1. ... S STR=$$ICDDATA^ICDXCODE(30,CODE,DT,"E")
  1. ... S IEN=$P(STR,"^") S:IEN<0 IEN=""
  1. .. ;
  1. .. ;If not found - Look in ICD-9 - Might be lookup of historical info
  1. .. I IEN="" D
  1. ... S STR=$$ICDDATA^ICDXCODE(1,CODE,DT,"E")
  1. ... S IEN=$P(STR,"^") S:IEN<0 IEN=""
  1. . S %=IEN
  1. . ;
  1. . I OVAL=% S DATA="" Q
  1. . I '% S DATA="" Q
  1. . S A=$P(DATA,"|")
  1. . S B=$P(DATA,"|",2,999)
  1. . S B=$P(B,$C(30),2,999)
  1. . S DATA=A_"|`"_%
  1. . I $L(B) S DATA=DATA_$C(30)_B
  1. . Q
  1. ;
  1. ;Process piece .02
  1. S %=$P(DATA,($C(30)_FLD_"|"),2) D
  1. . NEW OVAL,CODE,IEN
  1. . S IEN=""
  1. . S (CODE,OVAL)=$P(%,$C(30))
  1. . I CODE?1"`"1.N Q
  1. . ;
  1. . ;Pull appropriate ICD-9/ICD-10 code
  1. . ;
  1. . ;ICD-9 Only (Pre-AICD build)
  1. . I $$VERSION^XPDUTL("AICD")<4.0 D
  1. .. S IEN=$O(^ICD9("BA",CODE_" ",0))
  1. .. I $L($T(CODEN^ICDCODE)) S IEN=+$$CODEN^ICDCODE(IEN,80) I IEN<0 S IEN=""
  1. . ;
  1. . ;ICD-9 or ICD-10
  1. . I $$VERSION^XPDUTL("AICD")>3.51 D
  1. .. NEW STR
  1. .. ;
  1. .. ;Date has passed - First look for ICD-10
  1. .. I $$IMP^ICDEXA(30)'>DT D Q:IEN]""
  1. ... S STR=$$ICDDATA^ICDXCODE(30,CODE,DT,"E")
  1. ... S IEN=$P(STR,"^") S:IEN<0 IEN=""
  1. .. ;
  1. .. ;If not found - Look in ICD-9 - Might be lookup of historical info
  1. .. I IEN="" D
  1. ... S STR=$$ICDDATA^ICDXCODE(1,CODE,DT,"E")
  1. ... S IEN=$P(STR,"^") S:IEN<0 IEN=""
  1. . S %=IEN
  1. . ;
  1. . I OVAL=% S DATA="" Q
  1. . I '% S DATA="" Q
  1. . S A=$P(DATA,($C(30)_FLD_"|"))
  1. . S B=$P(DATA,($C(30)_FLD_"|"),2,999)
  1. . S B=$P(B,$C(30),2,999)
  1. . S DATA=A_$C(30)_FLD_"|`"_%
  1. . I $L(B) S DATA=DATA_$C(30)_B
  1. . Q
  1. Q DATA
  1. ;
  1. NARR(DATA,FLD) ; SUBSTITUTE A LOOKUP VALUE FOR NARRATIVE DATA IN THE DATA STRING
  1. N A,B,C,X,Y,DIC,Z
  1. I '$G(FLD) Q ""
  1. I '$L($G(DATA)) Q ""
  1. S Z=FLD_"|"
  1. S A=$P(DATA,Z)
  1. S B=$P(DATA,Z,2)
  1. S NARR=$P(B,$C(30))
  1. S NARR=$$UP^XLFSTR(NARR) ; CONVERT ALL NARRATIVE TO UPPERCASE
  1. S C=$P(B,$C(30),2,999)
  1. S DIC="^AUTNPOV(",DIC(0)="L",X=NARR
  1. D ^DIC I Y=-1 Q ""
  1. S DATA=A_FLD_"|`"_+Y
  1. I $L(C) S DATA=DATA_$C(30)_C
  1. D ^XBFMK
  1. Q DATA
  1. ;
  1. FACNIEN(PIEN,FIEN) ; GIVEN A PROBLEM IEN AND FACILITY IEN, RETURN THE FACILITY-NOTE IEN
  1. I '$D(^AUPNPROB(+$G(PIEN),0)) Q ""
  1. I '$D(^DIC(4,+$G(FIEN),0)) Q ""
  1. N FNIEN
  1. S FNIEN=$O(^AUPNPROB(PIEN,11,"B",FIEN,0)) I FNIEN Q FNIEN ; IF AN FNIEN EXISTS RETURN IT
  1. ; OTHERWISE-CREATE THE FM STUB NODES FOR THE FACILITY SUBFILE
  1. S FNIEN=$O(^AUPNPROB(PIEN,11,999999),-1)+1
  1. S ^AUPNPROB(PIEN,11,FNIEN,0)=FIEN
  1. S ^AUPNPROB(PIEN,11,FNIEN,11,0)="^9000011.1111IA^^"
  1. S ^AUPNPROB(PIEN,11,"B",FIEN,FNIEN)=""
  1. Q FNIEN
  1. ;
  1. NEXTPBN(DFN,FIEN) ; RETURN THE NEXT AVAILABLE PROBLEM NUMBER FOR A PATIENT AT THE FACILITY
  1. N MAX,PIEN,X,Y
  1. S MAX=0,PIEN=0
  1. F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D ; FIND ALL PROBLEMS FOR THIS PATIENT
  1. . S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q
  1. . I $P(X,U,6)'=FIEN Q ; ONLY CHECK NUMBERS AT THIS FACILITY
  1. . S Y=$P(X,U,7)
  1. . I Y>MAX S MAX=Y ; GET THE HIGHEST NUMBER THUS FAR
  1. . Q
  1. S MAX=(MAX\1)+1 ; GET NEXT AVAILABLE INTEGER
  1. Q MAX
  1. ;
  1. NN W $$NEXTNOTE(3,1) Q
  1. NEXTNOTE(PIEN,FNIEN) ; RETRUN THE NEXT NOTE NUMBER FOR A PROBLEM AND FACILITY-NOTE IEN
  1. I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q ""
  1. N MAX,NIEN,X,Y
  1. S MAX=0,NIEN=0
  1. F S NIEN=$O(^AUPNPROB(PIEN,11,FNIEN,11,NIEN)) Q:'NIEN D
  1. . S X=$G(^AUPNPROB(PIEN,11,FNIEN,11,NIEN,0)) I '$L(X) Q
  1. . S Y=+X
  1. . I Y>MAX S MAX=Y
  1. . Q
  1. S MAX=MAX+1
  1. Q MAX
  1. ;
  1. PIENN(PIEN) ; GIVEN A PROBLEM IEN, RETURN PROBLEM NARRATIVE (ICD)
  1. N X,IIEN,NARR,ICD,ENTRYDT
  1. S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q ""
  1. S IIEN=$P(X,U) I 'IIEN Q ""
  1. S ENTRYDT=$P(X,U,8)
  1. S ICD=""
  1. ;
  1. ;Pull appropriate ICD-9/ICD-10 code
  1. ;
  1. D
  1. . NEW STR
  1. . ;
  1. . ;First try to locate ICD-10
  1. . S STR=$$ICDDATA^ICDXCODE(30,IIEN,ENTRYDT,"I")
  1. . S ICD=$S($P(STR,"^")<0:"",1:$P(STR,"^",2)) Q:ICD]""
  1. . ;
  1. . ;If not an ICD-10 code try ICD-9 (could be before date or a historical entry)
  1. . S STR=$$ICDDATA^ICDXCODE(1,IIEN,ENTRYDT,"I")
  1. . S ICD=$S($P(STR,"^")<0:"",1:$P(STR,"^",2))
  1. ;
  1. I '$L(ICD) Q ""
  1. S NARR=$$GET1^DIQ(9000011,PIEN,".05") I '$L(NARR) Q ""
  1. S:$E(NARR,1)="*" NARR=$E(NARR,2,9999)
  1. S X=NARR_" ("_ICD_")"
  1. Q X
  1. ;
  1. DESC(CODE) ;EP - Return the description for the specified code
  1. ;
  1. N DESC
  1. S DESC=""
  1. ;
  1. ;Pull appropriate ICD-9/ICD-10 code
  1. ;
  1. ;ICD-9
  1. I $$VERSION^XPDUTL("AICD")<4.0 D
  1. . S CODE=$O(^ICD9("BA",CODE_" ",0))
  1. . S DESC=$$GET1^DIQ(80,CODE_",",3,"E")
  1. ;
  1. ;ICD-9 or ICD-10
  1. I $$VERSION^XPDUTL("AICD")>3.51 D
  1. . NEW STR
  1. . ;
  1. . ;First try to locate ICD-10
  1. . I $$IMP^ICDEXA(30)'>DT D Q:DESC]""
  1. .. S STR=$$ICDDATA^ICDXCODE(30,CODE,DT,"E")
  1. .. S DESC=$P(STR,"^",4)
  1. . ;
  1. . ;If not an ICD-10 code try ICD-9 (could be before date or a historical entry)
  1. . I DESC="" D
  1. .. S STR=$$ICDDATA^ICDXCODE(1,CODE,DT,"E")
  1. .. S DESC=$P(STR,"^",4)
  1. ;
  1. Q DESC