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="@"
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS04 4122 printed Apr 09, 2024@21:16:10 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
