- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS0C 2172 printed Feb 18, 2025@23:43 Page 2
- 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
