source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCPOS0C.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1MCPOS0C ;HIRMFO/RMP,DAD-ASTM file update ;7/24/96 08:39
2 ;;2.3;Medicine;;09/13/1996
3 ;
4 D STUFF("MCPMVA",690.2)
5 Q
6 ;
7START(FILE) ;DESIGNED TO CREATE MCPMVA - Medicine View ASTM subfile
8 ;Medicine View file entry - template name
9 ;Subfile entires for Field Number
10 ;SubSubfile entry for ASTM value
11 N COUNT,TEMP,REC,PROC,CODE
12 S COUNT=0,TEMP=""
13 F S TEMP=$O(^MCAR(FILE,"B",TEMP)) Q:TEMP="" D
14 . S REC=$O(^MCAR(FILE,"B",TEMP,""))
15 . S TMP=$S($D(^MCAR(FILE,REC,1)):$$TMP(FILE,REC),1:"")
16 . Q:TMP=""
17 . W !,";;",$P(^MCAR(FILE,REC,0),U)_"^"_TMP
18 . Q
19 Q
20TMP(FILE,REC) ;FOR EVERY Template with ASTM pointers in the SUB OR
21 ; SUBSUBfile structure GET ASTM ID's
22 N CNT,ARRAY,TMP,SUBENTRY
23 S CNT=0,(ARRAY)=""
24 F S CNT=$O(^MCAR(FILE,REC,1,CNT)) Q:CNT'?1N.N D
25 . S TMP=^MCAR(FILE,REC,1,CNT,0)
26 . Q:$P(TMP,U,3)="" S SUBENTRY=$P(TMP,U),TMP=$P(TMP,U,3)
27 . S TMP=$P(^MCAR(690.5,TMP,0),U,1,2),TMP=$TR(TMP,U,"~")
28 . S TMP=SUBENTRY_"~"_TMP
29 . S:$L(ARRAY)>0 ARRAY=ARRAY_","
30 . S ARRAY=ARRAY_TMP
31 . Q
32 Q ARRAY
33 ;
34STUFF(ROUTINE,TFILE) ;ROUTINE is set to "MCPMVA"
35 ;FILE is set to 690.2
36 N TEMP,COUNT,HOLD,VALUE,LOOP
37 S MCDATA(1)=""
38 S MCDATA(2)="Update the pointers from the Medicine View file (#690.2)"
39 S MCDATA(3)="to the ASTM file (#690.5)."
40 D MES^XPDUTL(.MCDATA)
41 ;
42 F LOOP=1:1 S HOLD=$P($T(DATA+LOOP^@(ROUTINE)),";;",2) Q:HOLD="" D
43 . S (DLAYGO,DIC)=TFILE,DIC(0)="L"
44 . S (VALUE,X)=$P(HOLD,U)
45 . D ^DIC I Y=-1 K DIC,DA Q
46 . S DA=+Y
47 . D SCODE($P(HOLD,U,2),DA,TFILE)
48 . Q
49 Q
50 ;
51SCODE(STEMP,SDA,FILE) ;
52 N ENTRY,CODE,TYPE,DATE,LOOP
53 F LOOP=1:1 S ENTRY=$P(STEMP,",",LOOP) Q:ENTRY="" D
54 . S ASTM=$$ASTM(ENTRY)
55 . S DA(1)=SDA,DIC="^MCAR("_FILE_","_DA(1)_",1,",DIC(0)="L"
56 . S DIC("P")=$$GET1^DID(FILE,2,"","SPECIFIER"),DLAYGO=FILE
57 . S (X,CODE)=$P(ENTRY,"~"),CODE2=$P(ENTRY,"~",2)
58 . D ^DIC
59 . I Y=-1 K DIC,DA Q
60 . S DIE=DIC,DA=+Y K DIC
61 . S DR="2////^S X=ASTM"
62 . D ^DIE
63 . K DIE,DR,DA,Y
64 . Q
65 Q
66ASTM(ENTRY) ;
67 N TMP,ASTM S (ASTM,TMP)=""
68 S (X,CODE)=$P(ENTRY,"~",2),CODE2=$P(ENTRY,"~",3)
69 F Q:ASTM'="" S TMP=$O(^MCAR(690.5,"B",CODE,TMP)) Q:TMP="" D
70 . S:$D(^MCAR(690.5,"C",CODE2,TMP)) ASTM=TMP
71 . Q
72 Q ASTM
Note: See TracBrowser for help on using the repository browser.