MCPOS0B ;HIRMFO/RMP,DAD-Medicine View file update ;5/1/96 13:30
;;2.3;Medicine;;09/13/1996
;
D STUFF("MCPMV",690.2)
Q
;
START(FILE) ;DESIGNED TO CREATE MCPMV - Medicine View file
N COUNT,TEMP,REC,PROC,CODE
S COUNT=0,TEMP=""
F S TEMP=$O(^MCAR(FILE,"B",TEMP)) Q:TEMP="" D
. S REC=$O(^MCAR(FILE,"B",TEMP,""))
. S COUNT=COUNT+1
. S PROC=$S($D(^MCAR(FILE,REC,3)):$$PROC(REC),1:"")
. W !,";;",$P(^MCAR(FILE,REC,0),U)_"^"_PROC
. Q
Q
PROC(REC) ;
N CNT,ARRAY,TEMP,SUBENTRY
S CNT=0,(ARRAY)=""
F S CNT=$O(^MCAR(FILE,REC,3,CNT)) Q:CNT'?1N.N D
. S TEMP=$P(^MCAR(697.2,^MCAR(FILE,REC,3,CNT,0),0),U)
. S:$L(ARRAY)>0 ARRAY=ARRAY_","
. S ARRAY=ARRAY_TEMP
. Q
Q ARRAY
;
STUFF(ROUTINE,FILE) ;ROUTINE is set to "MCPMV"
;FILE is set to 690.2
N TEMP,COUNT,HOLD,VALUE,LOOP,MCD0,MCD1,MCDATA
S MCDATA(1)=""
S MCDATA(2)="Update the pointers from the Medicine View file (#690.2)"
S MCDATA(3)="to the Procedure/Subspecialty file (#697.2)."
D MES^XPDUTL(.MCDATA)
;
F LOOP=1:1 S HOLD=$P($T(DATA+LOOP^@(ROUTINE)),";;",2) Q:HOLD="" D
. S (DLAYGO,DIC)=FILE,DIC(0)="L"
. S (VALUE,X)=$P(HOLD,U)
. D ^DIC I Y=-1 K DIC,DA Q
. S (MCD0,DA)=+Y
. S MCD1=0
. F S MCD1=$O(^MCAR(FILE,MCD0,3,MCD1)) Q:MCD1'>0 D
.. S DIK="^MCAR("_FILE_","_MCD0_",3,",(D0,DA(1))=MCD0,(D1,DA)=MCD1
.. D ^DIK
.. Q
. D SCODE($P(HOLD,U,2),MCD0,FILE)
. Q
Q
;
SCODE(STEMP,SDA,FILE) ;
N ENTRY,CODE,TYPE,DATE,LOOP
F LOOP=1:1 S ENTRY=$P(STEMP,",",LOOP) Q:ENTRY="" D
. K DD,DIC,DINUM,DO
. S DA(1)=SDA,DIC="^MCAR("_FILE_","_DA(1)_",3,",DIC(0)="L"
. S DIC("P")=$$GET1^DID(FILE,4,"","SPECIFIER"),DLAYGO=FILE
. S (X,CODE)=$P(ENTRY,"~")
. S X=+$O(^MCAR(697.2,"B",X,0))
. I $P($G(^MCAR(697.2,X,0)),U)'=CODE Q
. D FILE^DICN
. K DIE,DR,DA,Y
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS0B 1791 printed Apr 09, 2024@21:15:50 Page 2
MCPOS0B ;HIRMFO/RMP,DAD-Medicine View file update ;5/1/96 13:30
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 DO STUFF("MCPMV",690.2)
+4 QUIT
+5 ;
START(FILE) ;DESIGNED TO CREATE MCPMV - Medicine View file
+1 NEW COUNT,TEMP,REC,PROC,CODE
+2 SET COUNT=0
SET TEMP=""
+3 FOR
SET TEMP=$ORDER(^MCAR(FILE,"B",TEMP))
if TEMP=""
QUIT
Begin DoDot:1
+4 SET REC=$ORDER(^MCAR(FILE,"B",TEMP,""))
+5 SET COUNT=COUNT+1
+6 SET PROC=$SELECT($DATA(^MCAR(FILE,REC,3)):$$PROC(REC),1:"")
+7 WRITE !,";;",$PIECE(^MCAR(FILE,REC,0),U)_"^"_PROC
+8 QUIT
End DoDot:1
+9 QUIT
PROC(REC) ;
+1 NEW CNT,ARRAY,TEMP,SUBENTRY
+2 SET CNT=0
SET (ARRAY)=""
+3 FOR
SET CNT=$ORDER(^MCAR(FILE,REC,3,CNT))
if CNT'?1N.N
QUIT
Begin DoDot:1
+4 SET TEMP=$PIECE(^MCAR(697.2,^MCAR(FILE,REC,3,CNT,0),0),U)
+5 if $LENGTH(ARRAY)>0
SET ARRAY=ARRAY_","
+6 SET ARRAY=ARRAY_TEMP
+7 QUIT
End DoDot:1
+8 QUIT ARRAY
+9 ;
STUFF(ROUTINE,FILE) ;ROUTINE is set to "MCPMV"
+1 ;FILE is set to 690.2
+2 NEW TEMP,COUNT,HOLD,VALUE,LOOP,MCD0,MCD1,MCDATA
+3 SET MCDATA(1)=""
+4 SET MCDATA(2)="Update the pointers from the Medicine View file (#690.2)"
+5 SET MCDATA(3)="to the Procedure/Subspecialty file (#697.2)."
+6 DO MES^XPDUTL(.MCDATA)
+7 ;
+8 FOR LOOP=1:1
SET HOLD=$PIECE($TEXT(DATA+LOOP^@(ROUTINE)),";;",2)
if HOLD=""
QUIT
Begin DoDot:1
+9 SET (DLAYGO,DIC)=FILE
SET DIC(0)="L"
+10 SET (VALUE,X)=$PIECE(HOLD,U)
+11 DO ^DIC
IF Y=-1
KILL DIC,DA
QUIT
+12 SET (MCD0,DA)=+Y
+13 SET MCD1=0
+14 FOR
SET MCD1=$ORDER(^MCAR(FILE,MCD0,3,MCD1))
if MCD1'>0
QUIT
Begin DoDot:2
+15 SET DIK="^MCAR("_FILE_","_MCD0_",3,"
SET (D0,DA(1))=MCD0
SET (D1,DA)=MCD1
+16 DO ^DIK
+17 QUIT
End DoDot:2
+18 DO SCODE($PIECE(HOLD,U,2),MCD0,FILE)
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
SCODE(STEMP,SDA,FILE) ;
+1 NEW ENTRY,CODE,TYPE,DATE,LOOP
+2 FOR LOOP=1:1
SET ENTRY=$PIECE(STEMP,",",LOOP)
if ENTRY=""
QUIT
Begin DoDot:1
+3 KILL DD,DIC,DINUM,DO
+4 SET DA(1)=SDA
SET DIC="^MCAR("_FILE_","_DA(1)_",3,"
SET DIC(0)="L"
+5 SET DIC("P")=$$GET1^DID(FILE,4,"","SPECIFIER")
SET DLAYGO=FILE
+6 SET (X,CODE)=$PIECE(ENTRY,"~")
+7 SET X=+$ORDER(^MCAR(697.2,"B",X,0))
+8 IF $PIECE($GET(^MCAR(697.2,X,0)),U)'=CODE
QUIT
+9 DO FILE^DICN
+10 KILL DIE,DR,DA,Y
+11 QUIT
End DoDot:1
+12 QUIT
