VENPCC1P ; IHS/OIT/GIS - NEW ICD PREFERENCES MANAGER - ;
;;2.6;PCC+;;NOV 12, 2007
;
;
;
;
DX(DEFEF,PRV,DFN,DEPTIEN) ; EP - POPULATE THE DX PREFERENCE LIST
N GIEN,PIEN,PCE,CLASS,UID,IX,X,%,DX,IIEN,STG,ICD,TXT,TOT,VAR,VAR1,POS,CPV,IPV,ORD,TORD,TXT,CODE
S GIEN=$P($G(^VEN(7.41,+$G(DEFEF),0)),U,18) ; GET THE ICD GRP ASSOCIATED WITH THIS FORM - IF THERE IS ONE
I GIEN="" S GIEN=$O(^VEN(7.33,"B","PRIMARY",0)) I 'GIEN Q ; OTHERWISE REVERT TO THE 'PRIMARY' GRP
S PIEN="" ; GET THE PROVIDER BASED ON THE DEFAULT HIERARCHY
S %=$O(^VEN(7.34,"AC",(PRV_"_"_GIEN)))
I +%=PRV S PIEN=PRV ; TRY THE PROVIDER LISTED AT CHECKIN
I PIEN="" D ; TRY THE CLINIC'S DEFAULT PROVIDER
. S CPV=$P($G(^VEN(7.95,DEPTIEN,2)),U,2) I '% Q
. S %=$O(^VEN(7.34,"AC",(CPV_"_"_GIEN)))
. I +%=CPV S PIEN=CPV
. Q
I PIEN="" D I PIEN="" Q ; TRY THE INSTITUTIONAL DEFAULT PROVIDER
. S IPV=$P($G(^VEN(7.5,$$CFG^VENPCCU,0)),U,13) I 'IPV Q ; PATCHED BY GIS/OIT 10/6/05 ; PCC+ 2.5 PATCH 1
. S %=$O(^VEN(7.34,"AC",(IPV_"_"_GIEN)))
. I +%=IPV S PIEN=IPV Q
. S X=$O(^VEN(7.33,"B","PRIMARY",0)) I X=GIEN Q ; CHECK FOR SECONDARY SET OF THE INSTITUTIONAL PROVIDER
. S %=$O(^VEN(7.34,"AC",(IPV_"_"_X)))
. I +%=IPV S PIEN=PRV
. Q
S CLASS=$$CLASS^VENPCC1B(DFN) I 'CLASS Q ; GET THE PATENT'S DEMOGRAPHIC CLASS (8 POSSIBLE CLASSES)
S PCE=$P("1^3^7^5^11^9^15^13",U,CLASS) ; GET THE PIECE OF THE NODE THAT CORRESPONDS TO THE PTS CLASS
S (IX,UID)=PIEN_"_"_GIEN
K ORD S TORD=+$P($G(^VEN(7.41,+$G(DEFEF),0)),U,20)
UID ; EP - FOR GENERATING THE ARRAY
F S UID=$O(^VEN(7.34,"AC",UID)) Q:$P(UID,"_",1,2)'=IX D ; LIMIT RESULTS TO PROVIDER AND ICD PREFERENCE GRP
. S IIEN=$O(^VEN(7.34,"AC",UID,0)) I 'IIEN Q
. I '$P($G(^VEN(7.34,IIEN,1)),U,PCE) Q ; CLASS MUST BE ACTIVE FOR THIS ITEM
. I TORD=0 S ORD(IIEN,IIEN)=""
. I TORD=1 S TXT=$P($G(^VEN(7.34,IIEN,0)),U,3) Q:'$L(TXT) S ORD($E(TXT,1,30),IIEN)=""
. I TORD=2 S CODE=$P(UID,"_",3) Q:'$L(CODE) Q:CODE=0 S ORD(CODE,IIEN)=""
. Q
S X="",POS=0 K DX
F S X=$O(ORD(X)) Q:X="" S IIEN=0 F S IIEN=$O(ORD(X,IIEN)) Q:'IIEN S POS=POS+1,DX(POS)=IIEN
S TOT=0 S POS=0
F S POS=$O(DX(POS)) Q:'POS D ; SET THE MAIL MERGE FIELDS
. S IIEN=DX(POS) I 'IIEN Q
. S STG=$G(^VEN(7.34,IIEN,0)) I '$L(STG) Q
. S ICD=$P(STG,U,4),TXT=$P(STG,U,3),TOT=TOT+1
. S VAR="d"_TOT,VAR1=VAR_"c"
. S @TMP@(1,VAR)=TXT,@TMP@(1,VAR1)=ICD
. Q
Q
;
CONVERT ; EP - CONVERT THE OLD ICD PREFERENCES FILE TO THE NEW ONE
N GIEN,IEN,STG,TYPE,DIC,X,Y,DIE,DA,DR,XDR
S GIEN=$O(^VEN(7.33,"B","PRIMARY",0))
I 'GIEN D
. S DIC="^VEN(7.33,",DIC(0)="L",DLAYGO=19707.33
. S X="PRIMARY"
. D ^DIC I Y=-1 Q
. S GIEN=+Y
. Q
I 'GIEN Q
S (DIC,DIE)="^VEN(7.34,",DIC(0)="L",DLAYGO=19707.34
S IEN=0 F S IEN=$O(^VEN(7.1,IEN)) Q:'IEN D STUFF
S DA=$O(^DIC(19,"B","VEN CONVERT ICD TO 25",0)) I 'DA D ^XBFMK Q
S DIE="^DIC(19,",DR="2////Conversion completed..." ; OUT OF ORDER MESSAGE
L +^DIC(19,DA):0 I $T D ^DIE L -^DIC(19,DA)
D ^XBFMK
Q
;
STUFF ; EP-GIVEN THE OLD ICD PREFERENCES IEN, STUFF AN ENTRY INTO THE NEW ICD ITEM FILE
N STG,PIEN,CODE1,NAME,TYPE,CODE2,IX,UID
N INF,CHLD,TF,TM,AF,AM,SF,SM
S STG=$G(^VEN(7.1,IEN,0)) I '$L(STG) Q
S PIEN=+STG I '$D(^VA(200,PIEN,0)) Q ; PROVIDER IEN
S CODE1=+$P(STG,U,2) I '$L(CODE1) Q ; ICD COD
I CODE1=0 Q
S UID=PIEN_"_"_GIEN_"_"_CODE1 ; UID CODE
S NAME=$P(STG,U,3) I '$L(NAME) Q ; DX
S TYPE=$P(STG,U,4) I '$L(TYPE) Q ; DEMOG TYPE (1-8)
S CODE2=$P(STG,U,6) ; SECONDARY CODE (OPTIONAL)
S DA=$O(^VEN(7.34,"AC",UID,0))
I 'DA D ; ADD NEW ITEM
. S X="""`"_PIEN_""""
. D ^DIC I Y=-1 Q
. S DA=+Y
. S DR=".02////^S X=GIEN;.03////^S X=NAME;.04////^SET X=CODE1;.05////^S X=CODE2;.06////^S X=UID"
. L +^VEN(7.34):0 I $T D ^DIE L -^VEN(7.34)
. Q
I '$G(DA) Q
S %=$P("INF,1.01^CHLD,1.03^TM,1.07^TF,1.05^AM,1.11^AF,1.09^SM,1.15^SF,1.13",U,TYPE) I '$L(%) Q
S DR=$P(%,",",2)_"////1"
L +^VEN(7.34,DA):0 I $T D ^DIE L -^VEN(7.34,DA)
Q
;
CLONE ; EP-CLONE A USERS PREFERENCES
N DIC,DA,X,Y,%,STG0,STG1,IEN,UID,PIEN,RIEN,NIEN,OLDDA
W !!,"Enter the name of the provider whose preferences are to be cloned ->"
S DIC("A")="Provider: " S DIC="^VA(200," S DIC(0)="AEQM"
D ^DIC I Y=-1 D ^XBFMK Q
S PIEN=+Y
I '$D(^VEN(7.34,"B",PIEN)),'$D(^VEN(7.1,"B",PIEN)) W !!,"This provider has no ICD preferences. Request terminated..." D ^XBFMK Q
W !!,"Enter the name of the provider who will receive the preferences ->"
S DIC("A")="Provider: " S DIC="^VA(200," S DIC(0)="AEQM"
D ^DIC I Y=-1 D ^XBFMK Q
S RIEN=+Y
W !!,"Cloning preferences...Please be patient."
I $D(^VEN(7.34,"B",PIEN)) G NCLONE ; NEW ICD PREF FILE
OLDCLONE ; CLONE OLD ICD PREFS
S (DIK,DIC)="^VEN(7.1,",DLAYGO=19707.1,DIC(0)="L"
S OLDDA=0 F S OLDDA=$O(^VEN(7.1,"B",PIEN,OLDDA)) Q:'OLDDA D
. S X="""`"_RIEN_""""
. D ^DIC I '$P(Y,U,3) Q ; A NEW ENTRY MUST BE CREATED - OR QUIT
. S NIEN=+Y
. M ^VEN(7.1,NIEN)=^VEN(7.1,OLDDA) ; COPY THE NODES FROM OLD TO NEW
. S $P(^VEN(7.1,NIEN,0),U,1)=RIEN
. S DA=NIEN D IX^DIK ; INDEX THE NEW ENTRY
. Q
G XCLONE
NCLONE S DIC="^VEN(7.34," S DLAYGO=19707.34 S DIC(0)="L"
S IEN=0 F S IEN=$O(^VEN(7.34,"B",PIEN,IEN)) Q:'IEN D
. S STG0=$G(^VEN(7.34,IEN,0)) I '$L(STG0) Q
. S STG1=$G(^VEN(7.34,IEN,1))
. S X="""`"_RIEN_""""
. D ^DIC I Y=-1 Q
. S NIEN=+Y
. S %=STG0 S $P(%,U,1)=RIEN
. S UID=RIEN_"_"_$P(%,U,2)_"_"_$P(%,U,4) S $P(%,U,6)=UID
. S ^VEN(7.34,NIEN,0)=% S ^VEN(7.34,NIEN,1)=STG1
. S ^VEN(7.34,"AC",UID,NIEN)=""
. Q
XCLONE D ^XBFMK
W !,"Done!"
Q
;
DEL ; EP-DELETE A USER'S PREFERENCES
N DIC,DIK,DA,X,Y,%,%Y,FN
W !!,"Enter the name of the provider whose preferences are to be deleted ->"
S DIC("A")="Provider: " S DIC="^VA(200," S DIC(0)="AEQM"
D ^DIC I Y=-1 D ^XBFMK Q
S PIEN=+Y
I '$D(^VEN(7.34,"B",PIEN)),'$D(^VEN(7.1,"B",PIEN)) W !!,"This provider has no ICD preferences. Request terminated..." D ^XBFMK Q
W !,"Are you sure you want to delete these preferences"
S %=0 D YN^DICN I %'=1 D ^XBFMK Q
W !!,"Deleting entries...Please be patient"
F FN=7.1,7.34 S DIK="^VEN("_FN_",",DA=0 F S DA=$O(^VEN(FN,"B",PIEN,DA)) Q:'DA D ^DIK
D ^XBFMK
W !,"Done"
Q
;
AC(DA) ; EP - AUTO-POPULTAE THE UID FIELD OF THE ICD ITEM FILE ; PATCHED BY GIS/OIT 10/6/05 ; PCC+ 2.5 PATCH 5
N X,Y,Z,STG
S STG=$G(^VEN(7.34,+$G(DA),0))
S X=+STG I 'X Q ""
S Y=$P(STG,U,2) I 'Y S Y=1
S Z=$P(STG,U,4) I '$L(Z) Q
Q (X_"_"_Y_"_"_Z)
;
GEN ; EP-GENERATE A NEW SET OF PREFERENCES BASED ON USER HX
D NEWLIST^VENPCCG
Q
;
GED ; EP - OPTION (VEN GLOBAL PRV PREF EDIT (NEW))
N NEWFLAG
S NEWFLAG=1
D ^VENPCCMG
Q
;
PL ; EP - GLOBAL LIST OF ICD PREFERENCES (NEW))
N NEWFLAG
S NEWFLAG=1
D VUE^VENPCCMG
Q
;
ICD(OUT,IN) ; EP - RPC (VEN PCC+ SUBMIT ICD CRITERIA)
; SUBMIT ICD PREFERENCE CRITERIA AND RETURN THE TABLE GENERATION STRING
; START DATE|ASSIGNED PROVIDER|ICD GRP|CLINIC STOP|POLLED PROVIDERS|POLLED DISCIPLINE
N BD,ED,DXPRV,GIEN,CSIEN,PRV,DISC,VEN,X,Y,%,%DT,B,PNP,PROVFLG,SEX,TOTPN,VENFLNO,IO
N CFIGIEN,TMP,TYPE,NEWDXP,UID,I,VD,VDFN,VENDEPT,FL,POP,QUIET,P200
N AGE,AGEBUK,AGEGRP,AGESEX,AP,CC,DESALL,DOB,ICD,ICDPTR,MOST,MOSTPNP,NARR,PAT,VENT,VIS
S OUT="",QUIET=1,%=.06
S P200=(^DD((9000010+%),.01,0)["IC(6,")
S TMP="^TMP(""VEN PREF"",$J)" K @TMP
S CFIGIEN=$$CFG^VENPCCU I 'CFIGIEN Q
S B="|"
S X=$P(IN,B),%DT="P" D ^%DT I Y'?7N Q
S BD=Y,ED=DT
S NEWDXP=$P(IN,B,3)
I 'NEWDXP S NEWDXP=$O(^VEN(7.33,"B","PRIMARY",0)) I 'NEWDXP Q
S TYPE=$S($L($P(IN,B,5)):"P",$L($P(IN,B,6)):"C",1:"A")
I TYPE="C" D I '$D(VEN("PC")) Q
. S X=$P(IN,B,6)
. K VEN("PC")
. F I=1:1:$L(X,",") D
.. S Y=$P(X,",",I)
.. S VEN("PC",+Y)=""
.. S VEN("PC",0)=$G(VEN("PC",0))+1
.. Q
. Q
I TYPE="P" D I '$D(VEN("PRV")) Q
. S X=$P(IN,B,5)
. K VEN("PRV")
. F I=1:1:$L(X,",") D
.. S Y=$P(X,",",I)
.. I P200 S Y=$$PRV1^VENPCCU(Y) I 'Y Q ; CONVERT 6 T0 200
.. S VEN("PRV",+Y)=""
.. S VEN("PRV",0)=$G(VEN("PRV",0))+1
.. Q
. Q
T1 ; SET FILTER FLAGS
S @TMP@("VPOV",0)=BD_"^"_ED
I TYPE="C" D
. S $P(@TMP@("VPOV",0),"^",3)="CLINIC"
. I (VEN("PC",0)=1) S $P(@TMP@("VPOV",0),"^",3)=$O(VEN("PC",0))
. Q
I TYPE="P" D
. S $P(@TMP@("VPOV",0),"^",3)="PROVIDERS"
. I (VEN("PRV",0)=1) S $P(@TMP@("VPOV",0),"^",3)=$O(VEN("PRV",0))
. Q
S %=$P(IN,B,4) I % S VENDEPT=% ; CLINIC STOP FILTER
S %=$P(IN,B,2)
S DXPRV=$$APRV(%) I 'DXPRV Q ; ASSIGNED PROVIDER
S UID=DXPRV_"_"_NEWDXP
POLL D ST^VENPCCG1 ; MINE RAW DATA
D FILE^VENPCCG2 ; FORMAT/SUBMIT DATA FOR THE "TOP 100"
S %=$O(^VEN(7.34,"AC",UID)) I $P(%,"_",1,2)'=UID Q ; THERE MUST BE AT LEAST ONE ITEM!
S OUT="BMX ADO SS^VEN UP ICD ITEMS^^AC~"_UID_"~"_UID_"_zzz~999999"
Q
;
APRV(AP) ; EP-GET THE ASSIGNED PROVIDER
I '$L(%) Q ""
I %,$D(^VA(200,%,0)) Q %
N DIC,X,Y
S DIC="^VA(200,",DIC(0)="L",DLAYGO=200,X=AP
D ^DIC I Y=-1 D ^XBFMK Q ""
S AP=+Y
D ^XBFMK
Q AP
;
PRVLKUP(OUT) ; EP - RPC (VEN PCC+ GET ACTIVE PROVIDERS)
; GIVEN A LOOKUP VALUE, RETURN THE ADO RECORD GENERATION STRING TO VIEW PROVIDERS
S OUT="BMX ADO SS^VEN MOJO CHECKIN PROVIDERS^^~~~~~APRV~BMXADOV2"
Q
;
CSTOPS(OUT) ; EP - RPC (VEN PCC+ GET CLINIC STOPS)
S OUT="BMX ADO SS^VEN UP CLINIC STOPS^^B~~~999999"
Q
;
DISC(OUT) ; EP - RPC (VEN PCC+ GET DISCIPLINES)
S OUT="BMX ADO SS^VEN UP DISCIPLINES^^B~~~999999"
Q
;
ICDITEMS(OUT,IN) ; EP RPC(VEN PCC+ GET ICD ITEMS)
; THE INPUT PARAM 'IN' HAST THE FORMAT "PROVIDER IEN,ICD PREFERENCE GROUP IEN"
N X,Y,PRVIEN,PGIEN
S IN=$G(IN)
S PRVIEN=+IN I '$D(^VEN(7.34,"B",PRVIEN)) Q "" ; THIS PROVIDER MUST HAVE SOME PREFERENCES
S PGIEN=+$P(IN,",",2) I '$D(^VEN(7.33,PGIEN,0)) S PGIEN=1
S X=PRVIEN_"_"_PGIEN
S Y=X_"_zzzz"
S OUT="BMX ADO SS^VEN UP ICD ITEMS^^AC~"_X_"~"_Y_"~999999"
Q
;
ICDGRPS(OUT) ; EP - RPC (VEN PCC+ GET ICD GROUPS)
S OUT="BMX ADO SS^VEN UP ICD GROUPS^^B~~~999999"
Q
;
ICDLIST(OUT) ; EP - RPC(VEN PCC+ GET ICD LISTS)
S OUT="BMX ADO SS^VEN UP ICD LISTS^^~~~~~ILIST~VENPCC1P"
Q
;
ILIST(PARAM,IENS,MAX,OUT,TOT) ; EP - PRINT THE AVAILABLE ICD PREFERENCE LISTS: ONE FOR EACH USER/GROUP PAIR
N IIEN,UID,DA
S UID=""
F S UID=$O(^VEN(7.34,"AC",UID)) Q:UID="" D
. S DA=$O(^VEN(7.34,"AC",UID,0)) I 'DA Q
. X ("D DATA"_$C(94)_"BMXADOV1(IENS,DA)")
. S $P(UID,"_",3)="zzzz"
. Q
Q ""
;
CIDC(CODE) ; EP-CONVERT ICD CODE TO BRIEF ICD TEXT
N TXT,IIEN
S IIEN=$$ICD^VENPCCU($G(CODE)) I 'IIEN Q ""
S TXT=$P($G(^ICD9(IIEN,0)),U,3)
Q TXT
;
VENPCC1P ; IHS/OIT/GIS - NEW ICD PREFERENCES MANAGER - ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ;
+4 ;
+5 ;
DX(DEFEF,PRV,DFN,DEPTIEN) ; EP - POPULATE THE DX PREFERENCE LIST
+1 NEW GIEN,PIEN,PCE,CLASS,UID,IX,X,%,DX,IIEN,STG,ICD,TXT,TOT,VAR,VAR1,POS,CPV,IPV,ORD,TORD,TXT,CODE
+2 ; GET THE ICD GRP ASSOCIATED WITH THIS FORM - IF THERE IS ONE
SET GIEN=$PIECE($GET(^VEN(7.41,+$GET(DEFEF),0)),U,18)
+3 ; OTHERWISE REVERT TO THE 'PRIMARY' GRP
IF GIEN=""
SET GIEN=$ORDER(^VEN(7.33,"B","PRIMARY",0))
IF 'GIEN
QUIT
+4 ; GET THE PROVIDER BASED ON THE DEFAULT HIERARCHY
SET PIEN=""
+5 SET %=$ORDER(^VEN(7.34,"AC",(PRV_"_"_GIEN)))
+6 ; TRY THE PROVIDER LISTED AT CHECKIN
IF +%=PRV
SET PIEN=PRV
+7 ; TRY THE CLINIC'S DEFAULT PROVIDER
IF PIEN=""
Begin DoDot:1
+8 SET CPV=$PIECE($GET(^VEN(7.95,DEPTIEN,2)),U,2)
IF '%
QUIT
+9 SET %=$ORDER(^VEN(7.34,"AC",(CPV_"_"_GIEN)))
+10 IF +%=CPV
SET PIEN=CPV
+11 QUIT
End DoDot:1
+12 ; TRY THE INSTITUTIONAL DEFAULT PROVIDER
IF PIEN=""
Begin DoDot:1
+13 ; PATCHED BY GIS/OIT 10/6/05 ; PCC+ 2.5 PATCH 1
SET IPV=$PIECE($GET(^VEN(7.5,$$CFG^VENPCCU,0)),U,13)
IF 'IPV
QUIT
+14 SET %=$ORDER(^VEN(7.34,"AC",(IPV_"_"_GIEN)))
+15 IF +%=IPV
SET PIEN=IPV
QUIT
+16 ; CHECK FOR SECONDARY SET OF THE INSTITUTIONAL PROVIDER
SET X=$ORDER(^VEN(7.33,"B","PRIMARY",0))
IF X=GIEN
QUIT
+17 SET %=$ORDER(^VEN(7.34,"AC",(IPV_"_"_X)))
+18 IF +%=IPV
SET PIEN=PRV
+19 QUIT
End DoDot:1
IF PIEN=""
QUIT
+20 ; GET THE PATENT'S DEMOGRAPHIC CLASS (8 POSSIBLE CLASSES)
SET CLASS=$$CLASS^VENPCC1B(DFN)
IF 'CLASS
QUIT
+21 ; GET THE PIECE OF THE NODE THAT CORRESPONDS TO THE PTS CLASS
SET PCE=$PIECE("1^3^7^5^11^9^15^13",U,CLASS)
+22 SET (IX,UID)=PIEN_"_"_GIEN
+23 KILL ORD
SET TORD=+$PIECE($GET(^VEN(7.41,+$GET(DEFEF),0)),U,20)
UID ; EP - FOR GENERATING THE ARRAY
+1 ; LIMIT RESULTS TO PROVIDER AND ICD PREFERENCE GRP
FOR
SET UID=$ORDER(^VEN(7.34,"AC",UID))
IF $PIECE(UID,"_",1,2)'=IX
QUIT
Begin DoDot:1
+2 SET IIEN=$ORDER(^VEN(7.34,"AC",UID,0))
IF 'IIEN
QUIT
+3 ; CLASS MUST BE ACTIVE FOR THIS ITEM
IF '$PIECE($GET(^VEN(7.34,IIEN,1)),U,PCE)
QUIT
+4 IF TORD=0
SET ORD(IIEN,IIEN)=""
+5 IF TORD=1
SET TXT=$PIECE($GET(^VEN(7.34,IIEN,0)),U,3)
IF '$LENGTH(TXT)
QUIT
SET ORD($EXTRACT(TXT,1,30),IIEN)=""
+6 IF TORD=2
SET CODE=$PIECE(UID,"_",3)
IF '$LENGTH(CODE)
QUIT
IF CODE=0
QUIT
SET ORD(CODE,IIEN)=""
+7 QUIT
End DoDot:1
+8 SET X=""
SET POS=0
KILL DX
+9 FOR
SET X=$ORDER(ORD(X))
IF X=""
QUIT
SET IIEN=0
FOR
SET IIEN=$ORDER(ORD(X,IIEN))
IF 'IIEN
QUIT
SET POS=POS+1
SET DX(POS)=IIEN
+10 SET TOT=0
SET POS=0
+11 ; SET THE MAIL MERGE FIELDS
FOR
SET POS=$ORDER(DX(POS))
IF 'POS
QUIT
Begin DoDot:1
+12 SET IIEN=DX(POS)
IF 'IIEN
QUIT
+13 SET STG=$GET(^VEN(7.34,IIEN,0))
IF '$LENGTH(STG)
QUIT
+14 SET ICD=$PIECE(STG,U,4)
SET TXT=$PIECE(STG,U,3)
SET TOT=TOT+1
+15 SET VAR="d"_TOT
SET VAR1=VAR_"c"
+16 SET @TMP@(1,VAR)=TXT
SET @TMP@(1,VAR1)=ICD
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
CONVERT ; EP - CONVERT THE OLD ICD PREFERENCES FILE TO THE NEW ONE
+1 NEW GIEN,IEN,STG,TYPE,DIC,X,Y,DIE,DA,DR,XDR
+2 SET GIEN=$ORDER(^VEN(7.33,"B","PRIMARY",0))
+3 IF 'GIEN
Begin DoDot:1
+4 SET DIC="^VEN(7.33,"
SET DIC(0)="L"
SET DLAYGO=19707.33
+5 SET X="PRIMARY"
+6 DO ^DIC
IF Y=-1
QUIT
+7 SET GIEN=+Y
+8 QUIT
End DoDot:1
+9 IF 'GIEN
QUIT
+10 SET (DIC,DIE)="^VEN(7.34,"
SET DIC(0)="L"
SET DLAYGO=19707.34
+11 SET IEN=0
FOR
SET IEN=$ORDER(^VEN(7.1,IEN))
IF 'IEN
QUIT
DO STUFF
+12 SET DA=$ORDER(^DIC(19,"B","VEN CONVERT ICD TO 25",0))
IF 'DA
DO ^XBFMK
QUIT
+13 ; OUT OF ORDER MESSAGE
SET DIE="^DIC(19,"
SET DR="2////Conversion completed..."
+14 LOCK +^DIC(19,DA):0
IF $TEST
DO ^DIE
LOCK -^DIC(19,DA)
+15 DO ^XBFMK
+16 QUIT
+17 ;
STUFF ; EP-GIVEN THE OLD ICD PREFERENCES IEN, STUFF AN ENTRY INTO THE NEW ICD ITEM FILE
+1 NEW STG,PIEN,CODE1,NAME,TYPE,CODE2,IX,UID
+2 NEW INF,CHLD,TF,TM,AF,AM,SF,SM
+3 SET STG=$GET(^VEN(7.1,IEN,0))
IF '$LENGTH(STG)
QUIT
+4 ; PROVIDER IEN
SET PIEN=+STG
IF '$DATA(^VA(200,PIEN,0))
QUIT
+5 ; ICD COD
SET CODE1=+$PIECE(STG,U,2)
IF '$LENGTH(CODE1)
QUIT
+6 IF CODE1=0
QUIT
+7 ; UID CODE
SET UID=PIEN_"_"_GIEN_"_"_CODE1
+8 ; DX
SET NAME=$PIECE(STG,U,3)
IF '$LENGTH(NAME)
QUIT
+9 ; DEMOG TYPE (1-8)
SET TYPE=$PIECE(STG,U,4)
IF '$LENGTH(TYPE)
QUIT
+10 ; SECONDARY CODE (OPTIONAL)
SET CODE2=$PIECE(STG,U,6)
+11 SET DA=$ORDER(^VEN(7.34,"AC",UID,0))
+12 ; ADD NEW ITEM
IF 'DA
Begin DoDot:1
+13 SET X="""`"_PIEN_""""
+14 DO ^DIC
IF Y=-1
QUIT
+15 SET DA=+Y
+16 SET DR=".02////^S X=GIEN;.03////^S X=NAME;.04////^SET X=CODE1;.05////^S X=CODE2;.06////^S X=UID"
+17 LOCK +^VEN(7.34):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.34)
+18 QUIT
End DoDot:1
+19 IF '$GET(DA)
QUIT
+20 SET %=$PIECE("INF,1.01^CHLD,1.03^TM,1.07^TF,1.05^AM,1.11^AF,1.09^SM,1.15^SF,1.13",U,TYPE)
IF '$LENGTH(%)
QUIT
+21 SET DR=$PIECE(%,",",2)_"////1"
+22 LOCK +^VEN(7.34,DA):0
IF $TEST
DO ^DIE
LOCK -^VEN(7.34,DA)
+23 QUIT
+24 ;
CLONE ; EP-CLONE A USERS PREFERENCES
+1 NEW DIC,DA,X,Y,%,STG0,STG1,IEN,UID,PIEN,RIEN,NIEN,OLDDA
+2 WRITE !!,"Enter the name of the provider whose preferences are to be cloned ->"
+3 SET DIC("A")="Provider: "
SET DIC="^VA(200,"
SET DIC(0)="AEQM"
+4 DO ^DIC
IF Y=-1
DO ^XBFMK
QUIT
+5 SET PIEN=+Y
+6 IF '$DATA(^VEN(7.34,"B",PIEN))
IF '$DATA(^VEN(7.1,"B",PIEN))
WRITE !!,"This provider has no ICD preferences. Request terminated..."
DO ^XBFMK
QUIT
+7 WRITE !!,"Enter the name of the provider who will receive the preferences ->"
+8 SET DIC("A")="Provider: "
SET DIC="^VA(200,"
SET DIC(0)="AEQM"
+9 DO ^DIC
IF Y=-1
DO ^XBFMK
QUIT
+10 SET RIEN=+Y
+11 WRITE !!,"Cloning preferences...Please be patient."
+12 ; NEW ICD PREF FILE
IF $DATA(^VEN(7.34,"B",PIEN))
GOTO NCLONE
OLDCLONE ; CLONE OLD ICD PREFS
+1 SET (DIK,DIC)="^VEN(7.1,"
SET DLAYGO=19707.1
SET DIC(0)="L"
+2 SET OLDDA=0
FOR
SET OLDDA=$ORDER(^VEN(7.1,"B",PIEN,OLDDA))
IF 'OLDDA
QUIT
Begin DoDot:1
+3 SET X="""`"_RIEN_""""
+4 ; A NEW ENTRY MUST BE CREATED - OR QUIT
DO ^DIC
IF '$PIECE(Y,U,3)
QUIT
+5 SET NIEN=+Y
+6 ; COPY THE NODES FROM OLD TO NEW
MERGE ^VEN(7.1,NIEN)=^VEN(7.1,OLDDA)
+7 SET $PIECE(^VEN(7.1,NIEN,0),U,1)=RIEN
+8 ; INDEX THE NEW ENTRY
SET DA=NIEN
DO IX^DIK
+9 QUIT
End DoDot:1
+10 GOTO XCLONE
NCLONE SET DIC="^VEN(7.34,"
SET DLAYGO=19707.34
SET DIC(0)="L"
+1 SET IEN=0
FOR
SET IEN=$ORDER(^VEN(7.34,"B",PIEN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+2 SET STG0=$GET(^VEN(7.34,IEN,0))
IF '$LENGTH(STG0)
QUIT
+3 SET STG1=$GET(^VEN(7.34,IEN,1))
+4 SET X="""`"_RIEN_""""
+5 DO ^DIC
IF Y=-1
QUIT
+6 SET NIEN=+Y
+7 SET %=STG0
SET $PIECE(%,U,1)=RIEN
+8 SET UID=RIEN_"_"_$PIECE(%,U,2)_"_"_$PIECE(%,U,4)
SET $PIECE(%,U,6)=UID
+9 SET ^VEN(7.34,NIEN,0)=%
SET ^VEN(7.34,NIEN,1)=STG1
+10 SET ^VEN(7.34,"AC",UID,NIEN)=""
+11 QUIT
End DoDot:1
XCLONE DO ^XBFMK
+1 WRITE !,"Done!"
+2 QUIT
+3 ;
DEL ; EP-DELETE A USER'S PREFERENCES
+1 NEW DIC,DIK,DA,X,Y,%,%Y,FN
+2 WRITE !!,"Enter the name of the provider whose preferences are to be deleted ->"
+3 SET DIC("A")="Provider: "
SET DIC="^VA(200,"
SET DIC(0)="AEQM"
+4 DO ^DIC
IF Y=-1
DO ^XBFMK
QUIT
+5 SET PIEN=+Y
+6 IF '$DATA(^VEN(7.34,"B",PIEN))
IF '$DATA(^VEN(7.1,"B",PIEN))
WRITE !!,"This provider has no ICD preferences. Request terminated..."
DO ^XBFMK
QUIT
+7 WRITE !,"Are you sure you want to delete these preferences"
+8 SET %=0
DO YN^DICN
IF %'=1
DO ^XBFMK
QUIT
+9 WRITE !!,"Deleting entries...Please be patient"
+10 FOR FN=7.1,7.34
SET DIK="^VEN("_FN_","
SET DA=0
FOR
SET DA=$ORDER(^VEN(FN,"B",PIEN,DA))
IF 'DA
QUIT
DO ^DIK
+11 DO ^XBFMK
+12 WRITE !,"Done"
+13 QUIT
+14 ;
AC(DA) ; EP - AUTO-POPULTAE THE UID FIELD OF THE ICD ITEM FILE ; PATCHED BY GIS/OIT 10/6/05 ; PCC+ 2.5 PATCH 5
+1 NEW X,Y,Z,STG
+2 SET STG=$GET(^VEN(7.34,+$GET(DA),0))
+3 SET X=+STG
IF 'X
QUIT ""
+4 SET Y=$PIECE(STG,U,2)
IF 'Y
SET Y=1
+5 SET Z=$PIECE(STG,U,4)
IF '$LENGTH(Z)
QUIT
+6 QUIT (X_"_"_Y_"_"_Z)
+7 ;
GEN ; EP-GENERATE A NEW SET OF PREFERENCES BASED ON USER HX
+1 DO NEWLIST^VENPCCG
+2 QUIT
+3 ;
GED ; EP - OPTION (VEN GLOBAL PRV PREF EDIT (NEW))
+1 NEW NEWFLAG
+2 SET NEWFLAG=1
+3 DO ^VENPCCMG
+4 QUIT
+5 ;
PL ; EP - GLOBAL LIST OF ICD PREFERENCES (NEW))
+1 NEW NEWFLAG
+2 SET NEWFLAG=1
+3 DO VUE^VENPCCMG
+4 QUIT
+5 ;
ICD(OUT,IN) ; EP - RPC (VEN PCC+ SUBMIT ICD CRITERIA)
+1 ; SUBMIT ICD PREFERENCE CRITERIA AND RETURN THE TABLE GENERATION STRING
+2 ; START DATE|ASSIGNED PROVIDER|ICD GRP|CLINIC STOP|POLLED PROVIDERS|POLLED DISCIPLINE
+3 NEW BD,ED,DXPRV,GIEN,CSIEN,PRV,DISC,VEN,X,Y,%,%DT,B,PNP,PROVFLG,SEX,TOTPN,VENFLNO,IO
+4 NEW CFIGIEN,TMP,TYPE,NEWDXP,UID,I,VD,VDFN,VENDEPT,FL,POP,QUIET,P200
+5 NEW AGE,AGEBUK,AGEGRP,AGESEX,AP,CC,DESALL,DOB,ICD,ICDPTR,MOST,MOSTPNP,NARR,PAT,VENT,VIS
+6 SET OUT=""
SET QUIET=1
SET %=.06
+7 SET P200=(^DD((9000010+%),.01,0)["IC(6,")
+8 SET TMP="^TMP(""VEN PREF"",$J)"
KILL @TMP
+9 SET CFIGIEN=$$CFG^VENPCCU
IF 'CFIGIEN
QUIT
+10 SET B="|"
+11 SET X=$PIECE(IN,B)
SET %DT="P"
DO ^%DT
IF Y'?7N
QUIT
+12 SET BD=Y
SET ED=DT
+13 SET NEWDXP=$PIECE(IN,B,3)
+14 IF 'NEWDXP
SET NEWDXP=$ORDER(^VEN(7.33,"B","PRIMARY",0))
IF 'NEWDXP
QUIT
+15 SET TYPE=$SELECT($LENGTH($PIECE(IN,B,5)):"P",$LENGTH($PIECE(IN,B,6)):"C",1:"A")
+16 IF TYPE="C"
Begin DoDot:1
+17 SET X=$PIECE(IN,B,6)
+18 KILL VEN("PC")
+19 FOR I=1:1:$LENGTH(X,",")
Begin DoDot:2
+20 SET Y=$PIECE(X,",",I)
+21 SET VEN("PC",+Y)=""
+22 SET VEN("PC",0)=$GET(VEN("PC",0))+1
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
IF '$DATA(VEN("PC"))
QUIT
+25 IF TYPE="P"
Begin DoDot:1
+26 SET X=$PIECE(IN,B,5)
+27 KILL VEN("PRV")
+28 FOR I=1:1:$LENGTH(X,",")
Begin DoDot:2
+29 SET Y=$PIECE(X,",",I)
+30 ; CONVERT 6 T0 200
IF P200
SET Y=$$PRV1^VENPCCU(Y)
IF 'Y
QUIT
+31 SET VEN("PRV",+Y)=""
+32 SET VEN("PRV",0)=$GET(VEN("PRV",0))+1
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
IF '$DATA(VEN("PRV"))
QUIT
T1 ; SET FILTER FLAGS
+1 SET @TMP@("VPOV",0)=BD_"^"_ED
+2 IF TYPE="C"
Begin DoDot:1
+3 SET $PIECE(@TMP@("VPOV",0),"^",3)="CLINIC"
+4 IF (VEN("PC",0)=1)
SET $PIECE(@TMP@("VPOV",0),"^",3)=$ORDER(VEN("PC",0))
+5 QUIT
End DoDot:1
+6 IF TYPE="P"
Begin DoDot:1
+7 SET $PIECE(@TMP@("VPOV",0),"^",3)="PROVIDERS"
+8 IF (VEN("PRV",0)=1)
SET $PIECE(@TMP@("VPOV",0),"^",3)=$ORDER(VEN("PRV",0))
+9 QUIT
End DoDot:1
+10 ; CLINIC STOP FILTER
SET %=$PIECE(IN,B,4)
IF %
SET VENDEPT=%
+11 SET %=$PIECE(IN,B,2)
+12 ; ASSIGNED PROVIDER
SET DXPRV=$$APRV(%)
IF 'DXPRV
QUIT
+13 SET UID=DXPRV_"_"_NEWDXP
POLL ; MINE RAW DATA
DO ST^VENPCCG1
+1 ; FORMAT/SUBMIT DATA FOR THE "TOP 100"
DO FILE^VENPCCG2
+2 ; THERE MUST BE AT LEAST ONE ITEM!
SET %=$ORDER(^VEN(7.34,"AC",UID))
IF $PIECE(%,"_",1,2)'=UID
QUIT
+3 SET OUT="BMX ADO SS^VEN UP ICD ITEMS^^AC~"_UID_"~"_UID_"_zzz~999999"
+4 QUIT
+5 ;
APRV(AP) ; EP-GET THE ASSIGNED PROVIDER
+1 IF '$LENGTH(%)
QUIT ""
+2 IF %
IF $DATA(^VA(200,%,0))
QUIT %
+3 NEW DIC,X,Y
+4 SET DIC="^VA(200,"
SET DIC(0)="L"
SET DLAYGO=200
SET X=AP
+5 DO ^DIC
IF Y=-1
DO ^XBFMK
QUIT ""
+6 SET AP=+Y
+7 DO ^XBFMK
+8 QUIT AP
+9 ;
PRVLKUP(OUT) ; EP - RPC (VEN PCC+ GET ACTIVE PROVIDERS)
+1 ; GIVEN A LOOKUP VALUE, RETURN THE ADO RECORD GENERATION STRING TO VIEW PROVIDERS
+2 SET OUT="BMX ADO SS^VEN MOJO CHECKIN PROVIDERS^^~~~~~APRV~BMXADOV2"
+3 QUIT
+4 ;
CSTOPS(OUT) ; EP - RPC (VEN PCC+ GET CLINIC STOPS)
+1 SET OUT="BMX ADO SS^VEN UP CLINIC STOPS^^B~~~999999"
+2 QUIT
+3 ;
DISC(OUT) ; EP - RPC (VEN PCC+ GET DISCIPLINES)
+1 SET OUT="BMX ADO SS^VEN UP DISCIPLINES^^B~~~999999"
+2 QUIT
+3 ;
ICDITEMS(OUT,IN) ; EP RPC(VEN PCC+ GET ICD ITEMS)
+1 ; THE INPUT PARAM 'IN' HAST THE FORMAT "PROVIDER IEN,ICD PREFERENCE GROUP IEN"
+2 NEW X,Y,PRVIEN,PGIEN
+3 SET IN=$GET(IN)
+4 ; THIS PROVIDER MUST HAVE SOME PREFERENCES
SET PRVIEN=+IN
IF '$DATA(^VEN(7.34,"B",PRVIEN))
QUIT ""
+5 SET PGIEN=+$PIECE(IN,",",2)
IF '$DATA(^VEN(7.33,PGIEN,0))
SET PGIEN=1
+6 SET X=PRVIEN_"_"_PGIEN
+7 SET Y=X_"_zzzz"
+8 SET OUT="BMX ADO SS^VEN UP ICD ITEMS^^AC~"_X_"~"_Y_"~999999"
+9 QUIT
+10 ;
ICDGRPS(OUT) ; EP - RPC (VEN PCC+ GET ICD GROUPS)
+1 SET OUT="BMX ADO SS^VEN UP ICD GROUPS^^B~~~999999"
+2 QUIT
+3 ;
ICDLIST(OUT) ; EP - RPC(VEN PCC+ GET ICD LISTS)
+1 SET OUT="BMX ADO SS^VEN UP ICD LISTS^^~~~~~ILIST~VENPCC1P"
+2 QUIT
+3 ;
ILIST(PARAM,IENS,MAX,OUT,TOT) ; EP - PRINT THE AVAILABLE ICD PREFERENCE LISTS: ONE FOR EACH USER/GROUP PAIR
+1 NEW IIEN,UID,DA
+2 SET UID=""
+3 FOR
SET UID=$ORDER(^VEN(7.34,"AC",UID))
IF UID=""
QUIT
Begin DoDot:1
+4 SET DA=$ORDER(^VEN(7.34,"AC",UID,0))
IF 'DA
QUIT
+5 XECUTE ("D DATA"_$CHAR(94)_"BMXADOV1(IENS,DA)")
+6 SET $PIECE(UID,"_",3)="zzzz"
+7 QUIT
End DoDot:1
+8 QUIT ""
+9 ;
CIDC(CODE) ; EP-CONVERT ICD CODE TO BRIEF ICD TEXT
+1 NEW TXT,IIEN
+2 SET IIEN=$$ICD^VENPCCU($GET(CODE))
IF 'IIEN
QUIT ""
+3 SET TXT=$PIECE($GET(^ICD9(IIEN,0)),U,3)
+4 QUIT TXT
+5 ;
