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