VENPCC1P.m

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))