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
