Routine: MCPOS04

MCPOS04 ;HIRMFO/DAD-CONSULT CONVERSION 699 >>>===> 699.5 ;7/5/96  10:33

 ;;2.3;Medicine;;09/13/1996

 S MCONSULT=+$O(^MCAR(697.2,"B","CONSULT",0))

 S MCFOUND=$S($P($G(^MCAR(697.2,MCONSULT,0)),U)'="CONSULT":0,1:1)

 I $D(XPDNM) D  G:'MCFOUND EXIT

 . K MCDATA

 . S MCDATA(1)=""

 . S MCDATA(2)="Moving the Consult data from the Endoscopy/Consult"

 . S MCDATA(3)="file (#699) to the Generalized Procedure/Consult"

 . S MCDATA(4)="file (#699.5)."

. ;

 . I 'MCFOUND D

 .. S MCDATA(5)=""

 .. S MCDATA(6)="The CONSULT entry was not found in the"

 .. S MCDATA(7)="PROCEDURE/SPECIALTY file (#697.2), data cannot"

 .. S MCDATA(8)="be converted without this entry being present."

 .. Q

 . D MES^XPDUTL(.MCDATA) K MCDATA

. Q

 E  D  G EXIT

 . W !!,"Moving the Consult data from the Endoscopy/Consult"

 . W !,"file (#699) to the Generalized Procedure/Consult"

 . W !,"file (#699.5)."

. ;

 . I 'MCFOUND D  Q

 .. W !!,"The CONSULT entry was not found in the"

 .. W !,"PROCEDURE/SPECIALTY file (#697.2), data cannot"

 .. W !,"be converted without this entry being present."

 .. Q

. ;

 . S ZTRTN="TASK^MCPOS04"

 . S ZTDESC="Medicine Consult Conversion"

 . S ZTSAVE("MCONSULT")=""

 . S ZTIO=""

 . W ! D ^%ZTLOAD

 . W !!,"Conversion",$S($G(ZTSK)'>0:" not ",1:" "),"queued."

 . I $G(ZTSK)>0 W !,"Task # ",ZTSK,"."

. Q

TASK ;

 S MC699D0=0

 F  S MC699D0=$O(^MCAR(699,"D",MCONSULT,MC699D0)) Q:MC699D0'>0  D MAIN

EXIT ;

 I '$D(XPDNM),$D(ZTQUEUED) S ZTREQ="@"

MAIN ;

 K MCDATA

 F MCNODE=0,.2,15,"PCC","OR","ES","PROV" D

 . S MCDATA(MCNODE)=$G(^MCAR(699,MC699D0,MCNODE))

. Q

 I $P(MCDATA(0),U,12)'=MCONSULT Q

 S MCDATE=$P(MCDATA(0),U),MCDFN=$P(MCDATA(0),U,2)

 S MCPRC=$P(MCDATA(0),U,12)

 S (MC6995D0,MCIEN)=0

 F  S MCIEN=$O(^MCAR(699.5,"B",MCDATE,MCIEN)) Q:MCIEN'>0!MC6995D0  D

 . S MC=$G(^MCAR(699.5,MCIEN,0))

 . S MCNEWDFN=$P(MC,U,2),MCNEWPRC=$P(MC,U,6)

 . I MCNEWDFN=MCDFN,MCNEWPRC=MCPRC S MC6995D0=MCIEN

. Q

 I MC6995D0'>0 D

 . K DD,DIC,DINUM,DO

 . S DIC="^MCAR(699.5,",DIC(0)="L",DLAYGO=699.5

 . S DIC("DR")=".02///`"_MCDFN_";.05////"_MCPRC

 . S X=MCDATE D FILE^DICN S MC6995D0=+Y

. Q

 I MC6995D0'>0 Q

 S MCINDCOM=$P(MCDATA(0),U,6),MCSUMMRY=$P(MCDATA(.2),U)

 S MCPRCSUM=$P(MCDATA(.2),U,2),MCCONTYP=$P(MCDATA(15),U,11)

 S MCPROVID=$P(MCDATA(0),U,8)

 I MCPROVID'>0 S MCPROVID=$P(MCDATA("PROV"),U)

 K DA,DIC,DIE,DR S MCDRNUM=1

 S DR="2///1"

 I MCINDCOM]"" S DR(1,699.5,MCDRNUM)="3///^S X=$E(MCINDCOM,1,110)",MCDRNUM=MCDRNUM+1

 I $P($G(^VA(200,+MCPROVID,0)),U)]"",$D(^XUSEC("PROVIDER",+MCPROVID))#2 S DR(1,699.5,MCDRNUM)="6///`"_MCPROVID,MCDRNUM=MCDRNUM+1

 I "^A^N^I^"[(U_MCSUMMRY_U) S DR(1,699.5,MCDRNUM)="601///"_MCSUMMRY,MCDRNUM=MCDRNUM+1

 I MCPRCSUM]"" S DR(1,699.5,MCDRNUM)="600///^S X=$E(MCPRCSUM,1,79)",MCDRNUM=MCDRNUM+1

 I $P($G(^MCAR(699.82,+MCCONTYP,0)),U)]"" S DR(1,699.5,MCDRNUM)="31.5///`"_MCCONTYP,MCDRNUM=MCDRNUM+1

 I $P($G(^AUPNVSIT(+$P(MCDATA("PCC"),U),0)),U)]"" S DR(1,699.5,MCDRNUM)="900////"_+$P(MCDATA("PCC"),U),MCDRNUM=MCDRNUM+1

 S ORIFN=+$P(MCDATA("OR"),U),GMRCO=+$P(MCDATA("OR"),U,2)

 I $P($G(^OR(100,ORIFN,0)),U)]"" S DR(1,699.5,MCDRNUM)="1000////"_ORIFN,MCDRNUM=MCDRNUM+1

 I $P($G(^GMR(123,GMRCO,0)),U)]"" S DR(1,699.5,MCDRNUM)="1001////"_GMRCO,MCDRNUM=MCDRNUM+1

 F MCPIECE=1:1:16 D

 . S MCDATA=$P(MCDATA("ES"),U,MCPIECE) Q:MCDATA=""

 . S MCSLASH="///"

 . I "^1^4^13^"[(U_MCPIECE_U) S MCSLASH=MCSLASH_"`" I $P($G(^VA(200,+MCDATA,0)),U)="" Q

 . I "^2^5^"[(U_MCPIECE_U) D

 .. S MCVALCOD(MCPIECE)=$E(MCDATA,1,40)

 .. S MCSLASH=MCSLASH_"^S X="

 .. S MCDATA="MCVALCOD("_MCPIECE_")"

 .. Q

 . I 7=MCPIECE I "^D^PD^RV^ROV^RNV^S^SRV^SROV^"'[(U_MCDATA_U) Q

 . I 10=MCPIECE I MCDATA<0!(MCDATA>999999999) Q

 . I 11=MCPIECE I MCDATA<0!(MCDATA>99999999999999) Q

 . I 16=MCPIECE I MCDATA<0!(MCDATA>999) Q

 . I 14=MCPIECE S X=MCDATA,%DT="TX" D ^%DT S MCDATA=Y

 . I "^3^6^8^9^14^15^"[(U_MCPIECE_U) Q:MCDATA\1'?7N

 . I 12=MCPIECE I MCDATA'=1 Q

 . S DR(1,699.5,MCDRNUM)=(1499+MCPIECE)_MCSLASH_MCDATA

 . S MCDRNUM=MCDRNUM+1

. Q

 S DIE="^MCAR(699.5,",DA=MC6995D0 D ^DIE ; ALL FLAT FIELDS

 D ^MCPOS04A ; MULTIPLES

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS04   4122     printed  Mar 13, 2025@21:21:22                                                                                                                                                                                                     Page 2

MCPOS04   ;HIRMFO/DAD-CONSULT CONVERSION 699 >>>===> 699.5 ;7/5/96  10:33

 +1       ;;2.3;Medicine;;09/13/1996

 +2       ;

 +3        SET MCONSULT=+$ORDER(^MCAR(697.2,"B","CONSULT",0))

 +4        SET MCFOUND=$SELECT($PIECE($GET(^MCAR(697.2,MCONSULT,0)),U)'="CONSULT":0,1:1)

 +5       ;

 +6        IF $DATA(XPDNM)

               Begin DoDot:1

 +7                KILL MCDATA

 +8                SET MCDATA(1)=""

 +9                SET MCDATA(2)="Moving the Consult data from the Endoscopy/Consult"

 +10               SET MCDATA(3)="file (#699) to the Generalized Procedure/Consult"

 +11               SET MCDATA(4)="file (#699.5)."

 +12      ;

 +13               IF 'MCFOUND

                       Begin DoDot:2

 +14                       SET MCDATA(5)=""

 +15                       SET MCDATA(6)="The CONSULT entry was not found in the"

 +16                       SET MCDATA(7)="PROCEDURE/SPECIALTY file (#697.2), data cannot"

 +17                       SET MCDATA(8)="be converted without this entry being present."

 +18                       QUIT

                       End DoDot:2

 +19               DO MES^XPDUTL(.MCDATA)

                   KILL MCDATA

 +20               QUIT

               End DoDot:1

               if 'MCFOUND

                   GOTO EXIT

 +21      IF '$TEST

               Begin DoDot:1

 +22               WRITE !!,"Moving the Consult data from the Endoscopy/Consult"

 +23               WRITE !,"file (#699) to the Generalized Procedure/Consult"

 +24               WRITE !,"file (#699.5)."

 +25      ;

 +26               IF 'MCFOUND

                       Begin DoDot:2

 +27                       WRITE !!,"The CONSULT entry was not found in the"

 +28                       WRITE !,"PROCEDURE/SPECIALTY file (#697.2), data cannot"

 +29                       WRITE !,"be converted without this entry being present."

 +30                       QUIT

                       End DoDot:2

                       QUIT

 +31      ;

 +32               SET ZTRTN="TASK^MCPOS04"

 +33               SET ZTDESC="Medicine Consult Conversion"

 +34               SET ZTSAVE("MCONSULT")=""

 +35               SET ZTIO=""

 +36               WRITE !

                   DO ^%ZTLOAD

 +37               WRITE !!,"Conversion",$SELECT($GET(ZTSK)'>0:" not ",1:" "),"queued."

 +38               IF $GET(ZTSK)>0

                       WRITE !,"Task # ",ZTSK,"."

 +39               QUIT

               End DoDot:1

               GOTO EXIT

TASK      ;

 +1        SET MC699D0=0

 +2        FOR

               SET MC699D0=$ORDER(^MCAR(699,"D",MCONSULT,MC699D0))

               if MC699D0'>0

                   QUIT

               DO MAIN

EXIT      ;

 +1        IF '$DATA(XPDNM)

               IF $DATA(ZTQUEUED)

                   SET ZTREQ="@"

 +2        QUIT

MAIN      ;

 +1        KILL MCDATA

 +2        FOR MCNODE=0,.2,15,"PCC","OR","ES","PROV"

               Begin DoDot:1

 +3                SET MCDATA(MCNODE)=$GET(^MCAR(699,MC699D0,MCNODE))

 +4                QUIT

               End DoDot:1

 +5        IF $PIECE(MCDATA(0),U,12)'=MCONSULT

               QUIT

 +6        SET MCDATE=$PIECE(MCDATA(0),U)

           SET MCDFN=$PIECE(MCDATA(0),U,2)

 +7        SET MCPRC=$PIECE(MCDATA(0),U,12)

 +8        SET (MC6995D0,MCIEN)=0

 +9        FOR

               SET MCIEN=$ORDER(^MCAR(699.5,"B",MCDATE,MCIEN))

               if MCIEN'>0!MC6995D0

                   QUIT

               Begin DoDot:1

 +10               SET MC=$GET(^MCAR(699.5,MCIEN,0))

 +11               SET MCNEWDFN=$PIECE(MC,U,2)

                   SET MCNEWPRC=$PIECE(MC,U,6)

 +12               IF MCNEWDFN=MCDFN

                       IF MCNEWPRC=MCPRC

                           SET MC6995D0=MCIEN

 +13               QUIT

               End DoDot:1

 +14       IF MC6995D0'>0

               Begin DoDot:1

 +15               KILL DD,DIC,DINUM,DO

 +16               SET DIC="^MCAR(699.5,"

                   SET DIC(0)="L"

                   SET DLAYGO=699.5

 +17               SET DIC("DR")=".02///`"_MCDFN_";.05////"_MCPRC

 +18               SET X=MCDATE

                   DO FILE^DICN

                   SET MC6995D0=+Y

 +19               QUIT

               End DoDot:1

 +20      ;

 +21       IF MC6995D0'>0

               QUIT

 +22       SET MCINDCOM=$PIECE(MCDATA(0),U,6)

           SET MCSUMMRY=$PIECE(MCDATA(.2),U)

 +23       SET MCPRCSUM=$PIECE(MCDATA(.2),U,2)

           SET MCCONTYP=$PIECE(MCDATA(15),U,11)

 +24       SET MCPROVID=$PIECE(MCDATA(0),U,8)

 +25       IF MCPROVID'>0

               SET MCPROVID=$PIECE(MCDATA("PROV"),U)

 +26       KILL DA,DIC,DIE,DR

           SET MCDRNUM=1

 +27       SET DR="2///1"

 +28       IF MCINDCOM]""

               SET DR(1,699.5,MCDRNUM)="3///^S X=$E(MCINDCOM,1,110)"

               SET MCDRNUM=MCDRNUM+1

 +29       IF $PIECE($GET(^VA(200,+MCPROVID,0)),U)]""

               IF $DATA(^XUSEC("PROVIDER",+MCPROVID))#2

                   SET DR(1,699.5,MCDRNUM)="6///`"_MCPROVID

                   SET MCDRNUM=MCDRNUM+1

 +30       IF "^A^N^I^"[(U_MCSUMMRY_U)

               SET DR(1,699.5,MCDRNUM)="601///"_MCSUMMRY

               SET MCDRNUM=MCDRNUM+1

 +31       IF MCPRCSUM]""

               SET DR(1,699.5,MCDRNUM)="600///^S X=$E(MCPRCSUM,1,79)"

               SET MCDRNUM=MCDRNUM+1

 +32       IF $PIECE($GET(^MCAR(699.82,+MCCONTYP,0)),U)]""

               SET DR(1,699.5,MCDRNUM)="31.5///`"_MCCONTYP

               SET MCDRNUM=MCDRNUM+1

 +33       IF $PIECE($GET(^AUPNVSIT(+$PIECE(MCDATA("PCC"),U),0)),U)]""

               SET DR(1,699.5,MCDRNUM)="900////"_+$PIECE(MCDATA("PCC"),U)

               SET MCDRNUM=MCDRNUM+1

 +34       SET ORIFN=+$PIECE(MCDATA("OR"),U)

           SET GMRCO=+$PIECE(MCDATA("OR"),U,2)

 +35       IF $PIECE($GET(^OR(100,ORIFN,0)),U)]""

               SET DR(1,699.5,MCDRNUM)="1000////"_ORIFN

               SET MCDRNUM=MCDRNUM+1

 +36       IF $PIECE($GET(^GMR(123,GMRCO,0)),U)]""

               SET DR(1,699.5,MCDRNUM)="1001////"_GMRCO

               SET MCDRNUM=MCDRNUM+1

 +37       FOR MCPIECE=1:1:16

               Begin DoDot:1

 +38               SET MCDATA=$PIECE(MCDATA("ES"),U,MCPIECE)

                   if MCDATA=""

                       QUIT

 +39               SET MCSLASH="///"

 +40               IF "^1^4^13^"[(U_MCPIECE_U)

                       SET MCSLASH=MCSLASH_"`"

                       IF $PIECE($GET(^VA(200,+MCDATA,0)),U)=""

                           QUIT

 +41               IF "^2^5^"[(U_MCPIECE_U)

                       Begin DoDot:2

 +42                       SET MCVALCOD(MCPIECE)=$EXTRACT(MCDATA,1,40)

 +43                       SET MCSLASH=MCSLASH_"^S X="

 +44                       SET MCDATA="MCVALCOD("_MCPIECE_")"

 +45                       QUIT

                       End DoDot:2

 +46               IF 7=MCPIECE

                       IF "^D^PD^RV^ROV^RNV^S^SRV^SROV^"'[(U_MCDATA_U)

                           QUIT

 +47               IF 10=MCPIECE

                       IF MCDATA<0!(MCDATA>999999999)

                           QUIT

 +48               IF 11=MCPIECE

                       IF MCDATA<0!(MCDATA>99999999999999)

                           QUIT

 +49               IF 16=MCPIECE

                       IF MCDATA<0!(MCDATA>999)

                           QUIT

 +50               IF 14=MCPIECE

                       SET X=MCDATA

                       SET %DT="TX"

                       DO ^%DT

                       SET MCDATA=Y

 +51               IF "^3^6^8^9^14^15^"[(U_MCPIECE_U)

                       if MCDATA\1'?7N

                           QUIT

 +52               IF 12=MCPIECE

                       IF MCDATA'=1

                           QUIT

 +53               SET DR(1,699.5,MCDRNUM)=(1499+MCPIECE)_MCSLASH_MCDATA

 +54               SET MCDRNUM=MCDRNUM+1

 +55               QUIT

               End DoDot:1

 +56      ; ALL FLAT FIELDS

           SET DIE="^MCAR(699.5,"

           SET DA=MC6995D0

           DO ^DIE

 +57      ;

 +58      ; MULTIPLES

           DO ^MCPOS04A

 +59       QUIT

MCPOS04.m