MCPOS0C ;HIRMFO/RMP,DAD-ASTM file update ;7/24/96 08:39
;;2.3;Medicine;;09/13/1996
;
D STUFF("MCPMVA",690.2)
Q
;
START(FILE) ;DESIGNED TO CREATE MCPMVA - Medicine View ASTM subfile
;Medicine View file entry - template name
;Subfile entires for Field Number
;SubSubfile entry for ASTM value
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 TMP=$S($D(^MCAR(FILE,REC,1)):$$TMP(FILE,REC),1:"")
. Q:TMP=""
. W !,";;",$P(^MCAR(FILE,REC,0),U)_"^"_TMP
. Q
Q
TMP(FILE,REC) ;FOR EVERY Template with ASTM pointers in the SUB OR
; SUBSUBfile structure GET ASTM ID's
N CNT,ARRAY,TMP,SUBENTRY
S CNT=0,(ARRAY)=""
F S CNT=$O(^MCAR(FILE,REC,1,CNT)) Q:CNT'?1N.N D
. S TMP=^MCAR(FILE,REC,1,CNT,0)
. Q:$P(TMP,U,3)="" S SUBENTRY=$P(TMP,U),TMP=$P(TMP,U,3)
. S TMP=$P(^MCAR(690.5,TMP,0),U,1,2),TMP=$TR(TMP,U,"~")
. S TMP=SUBENTRY_"~"_TMP
. S:$L(ARRAY)>0 ARRAY=ARRAY_","
. S ARRAY=ARRAY_TMP
. Q
Q ARRAY
;
STUFF(ROUTINE,TFILE) ;ROUTINE is set to "MCPMVA"
;FILE is set to 690.2
N TEMP,COUNT,HOLD,VALUE,LOOP
S MCDATA(1)=""
S MCDATA(2)="Update the pointers from the Medicine View file (#690.2)"
S MCDATA(3)="to the ASTM file (#690.5)."
D MES^XPDUTL(.MCDATA)
;
F LOOP=1:1 S HOLD=$P($T(DATA+LOOP^@(ROUTINE)),";;",2) Q:HOLD="" D
. S (DLAYGO,DIC)=TFILE,DIC(0)="L"
. S (VALUE,X)=$P(HOLD,U)
. D ^DIC I Y=-1 K DIC,DA Q
. S DA=+Y
. D SCODE($P(HOLD,U,2),DA,TFILE)
. Q
Q
;
SCODE(STEMP,SDA,FILE) ;
N ENTRY,CODE,TYPE,DATE,LOOP
F LOOP=1:1 S ENTRY=$P(STEMP,",",LOOP) Q:ENTRY="" D
. S ASTM=$$ASTM(ENTRY)
. S DA(1)=SDA,DIC="^MCAR("_FILE_","_DA(1)_",1,",DIC(0)="L"
. S DIC("P")=$$GET1^DID(FILE,2,"","SPECIFIER"),DLAYGO=FILE
. S (X,CODE)=$P(ENTRY,"~"),CODE2=$P(ENTRY,"~",2)
. D ^DIC
. I Y=-1 K DIC,DA Q
. S DIE=DIC,DA=+Y K DIC
. S DR="2////^S X=ASTM"
. D ^DIE
. K DIE,DR,DA,Y
. Q
Q
ASTM(ENTRY) ;
N TMP,ASTM S (ASTM,TMP)=""
S (X,CODE)=$P(ENTRY,"~",2),CODE2=$P(ENTRY,"~",3)
F Q:ASTM'="" S TMP=$O(^MCAR(690.5,"B",CODE,TMP)) Q:TMP="" D
. S:$D(^MCAR(690.5,"C",CODE2,TMP)) ASTM=TMP
. Q
Q ASTM
MCPOS0C ;HIRMFO/RMP,DAD-ASTM file update ;7/24/96 08:39
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 DO STUFF("MCPMVA",690.2)
+4 QUIT
+5 ;
START(FILE) ;DESIGNED TO CREATE MCPMVA - Medicine View ASTM subfile
+1 ;Medicine View file entry - template name
+2 ;Subfile entires for Field Number
+3 ;SubSubfile entry for ASTM value
+4 NEW COUNT,TEMP,REC,PROC,CODE
+5 SET COUNT=0
SET TEMP=""
+6 FOR
SET TEMP=$ORDER(^MCAR(FILE,"B",TEMP))
IF TEMP=""
QUIT
Begin DoDot:1
+7 SET REC=$ORDER(^MCAR(FILE,"B",TEMP,""))
+8 SET TMP=$SELECT($DATA(^MCAR(FILE,REC,1)):$$TMP(FILE,REC),1:"")
+9 IF TMP=""
QUIT
+10 WRITE !,";;",$PIECE(^MCAR(FILE,REC,0),U)_"^"_TMP
+11 QUIT
End DoDot:1
+12 QUIT
TMP(FILE,REC) ;FOR EVERY Template with ASTM pointers in the SUB OR
+1 ; SUBSUBfile structure GET ASTM ID's
+2 NEW CNT,ARRAY,TMP,SUBENTRY
+3 SET CNT=0
SET (ARRAY)=""
+4 FOR
SET CNT=$ORDER(^MCAR(FILE,REC,1,CNT))
IF CNT'?1N.N
QUIT
Begin DoDot:1
+5 SET TMP=^MCAR(FILE,REC,1,CNT,0)
+6 IF $PIECE(TMP,U,3)=""
QUIT
SET SUBENTRY=$PIECE(TMP,U)
SET TMP=$PIECE(TMP,U,3)
+7 SET TMP=$PIECE(^MCAR(690.5,TMP,0),U,1,2)
SET TMP=$TRANSLATE(TMP,U,"~")
+8 SET TMP=SUBENTRY_"~"_TMP
+9 IF $LENGTH(ARRAY)>0
SET ARRAY=ARRAY_","
+10 SET ARRAY=ARRAY_TMP
+11 QUIT
End DoDot:1
+12 QUIT ARRAY
+13 ;
STUFF(ROUTINE,TFILE) ;ROUTINE is set to "MCPMVA"
+1 ;FILE is set to 690.2
+2 NEW TEMP,COUNT,HOLD,VALUE,LOOP
+3 SET MCDATA(1)=""
+4 SET MCDATA(2)="Update the pointers from the Medicine View file (#690.2)"
+5 SET MCDATA(3)="to the ASTM file (#690.5)."
+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)=TFILE
SET DIC(0)="L"
+10 SET (VALUE,X)=$PIECE(HOLD,U)
+11 DO ^DIC
IF Y=-1
KILL DIC,DA
QUIT
+12 SET DA=+Y
+13 DO SCODE($PIECE(HOLD,U,2),DA,TFILE)
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
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 SET ASTM=$$ASTM(ENTRY)
+4 SET DA(1)=SDA
SET DIC="^MCAR("_FILE_","_DA(1)_",1,"
SET DIC(0)="L"
+5 SET DIC("P")=$$GET1^DID(FILE,2,"","SPECIFIER")
SET DLAYGO=FILE
+6 SET (X,CODE)=$PIECE(ENTRY,"~")
SET CODE2=$PIECE(ENTRY,"~",2)
+7 DO ^DIC
+8 IF Y=-1
KILL DIC,DA
QUIT
+9 SET DIE=DIC
SET DA=+Y
KILL DIC
+10 SET DR="2////^S X=ASTM"
+11 DO ^DIE
+12 KILL DIE,DR,DA,Y
+13 QUIT
End DoDot:1
+14 QUIT
ASTM(ENTRY) ;
+1 NEW TMP,ASTM
SET (ASTM,TMP)=""
+2 SET (X,CODE)=$PIECE(ENTRY,"~",2)
SET CODE2=$PIECE(ENTRY,"~",3)
+3 FOR
IF ASTM'=""
QUIT
SET TMP=$ORDER(^MCAR(690.5,"B",CODE,TMP))
IF TMP=""
QUIT
Begin DoDot:1
+4 IF $DATA(^MCAR(690.5,"C",CODE2,TMP))
SET ASTM=TMP
+5 QUIT
End DoDot:1
+6 QUIT ASTM
